Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LROSPLG2

LROSPLG2.m

Go to the documentation of this file.
  1. LROSPLG2 ;B'HAM ISC/ADM - COPY INFO FROM OPERATION RECORD; 09 AUG 1993 9:57 AM ;4/12/94 08:56
  1. ;;3.0; Surgery ;**28**;24 Jun 93
  1. HIS I '$O(^SRF(SRTN,39,0)) G PRE
  1. I '$O(^LR(LRDFN,LRSS,LRI,.2,0)) S %X="^SRF(SRTN,39,",%Y="^LR(LRDFN,LRSS,LRI,.2," D %XY^%RCR S SRN=.2
  1. PRE I $O(^LR(LRDFN,LRSS,LRI,.3,0)) G FIND
  1. S J=1,SRD(1)=$P($G(^SRF(SRTN,33)),"^") I SRD(1)'="" S K=0 F S K=$O(^SRF(SRTN,14,K)) Q:'K S SRD(J)=SRD(J)_",",J=J+1,SRD(J)=$P(^SRF(SRTN,14,K,0),"^")
  1. I SRD(1)'="" S SRN=.3 D WP
  1. FIND I '$O(^SRF(SRTN,38,0)) G POST
  1. I '$O(^LR(LRDFN,LRSS,LRI,.4,0)) S %X="^SRF(SRTN,38,",%Y="^LR(LRDFN,LRSS,LRI,.4," D %XY^%RCR S SRN=.4
  1. POST I $O(^LR(LRDFN,LRSS,LRI,.5,0)) Q
  1. S J=1,SRD(1)=$P($G(^SRF(SRTN,34)),"^") I SRD(1)'="" S K=0 F S K=$O(^SRF(SRTN,15,K)) Q:'K S SRD(J)=SRD(J)_",",J=J+1,SRD(J)=$P(^SRF(SRTN,15,K,0),"^")
  1. I SRD(1)="" Q
  1. Q:SRD(1)="" S SRN=.5
  1. WP S DIWL=1,DIWR=75,DIWF="",SRJ=J K ^UTILITY($J,"W") F SRK=1:1:SRJ S X=SRD(SRK) D ^DIWP
  1. S J=^UTILITY($J,"W",DIWL),^LR(LRDFN,LRSS,LRI,SRN,0)="^^"_J_"^"_J_"^"_DT_"^"
  1. F K=1:1:J S ^LR(LRDFN,LRSS,LRI,SRN,K,0)=^UTILITY($J,"W",DIWL,K,0)
  1. K ^UTILITY($J,"W"),SRD
  1. Q