Routine: SROSPLG2

SROSPLG2 ;B'HAM ISC/ADM - COPY INFO FROM OPERATION RECORD; 09 AUG 1993  9:57 AM ;4/12/94  08:56

 ;;3.0; Surgery ;**28**;24 Jun 93

HIS I '$O(^SRF(SRTN,39,0)) G PRE

 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

PRE I $O(^LR(LRDFN,LRSS,LRI,.3,0)) G FIND

 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),"^")

 I SRD(1)'="" S SRN=.3 D WP

FIND I '$O(^SRF(SRTN,38,0)) G POST

 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

POST I $O(^LR(LRDFN,LRSS,LRI,.5,0)) Q

 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),"^")

 I SRD(1)="" Q

 Q:SRD(1)=""  S SRN=.5

WP S DIWL=1,DIWR=75,DIWF="",SRJ=J K ^UTILITY($J,"W") F SRK=1:1:SRJ S X=SRD(SRK) D ^DIWP

 S J=^UTILITY($J,"W",DIWL),^LR(LRDFN,LRSS,LRI,SRN,0)="^^"_J_"^"_J_"^"_DT_"^"

 F K=1:1:J S ^LR(LRDFN,LRSS,LRI,SRN,K,0)=^UTILITY($J,"W",DIWL,K,0)

 K ^UTILITY($J,"W"),SRD

SROSPLG2  ;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

HIS        IF '$ORDER(^SRF(SRTN,39,0))

               GOTO PRE

 +1        IF '$ORDER(^LR(LRDFN,LRSS,LRI,.2,0))

               SET %X="^SRF(SRTN,39,"

               SET %Y="^LR(LRDFN,LRSS,LRI,.2,"

               DO %XY^%RCR

               SET SRN=.2

PRE        IF $ORDER(^LR(LRDFN,LRSS,LRI,.3,0))

               GOTO FIND

 +1        SET J=1

           SET SRD(1)=$PIECE($GET(^SRF(SRTN,33)),"^")

           IF SRD(1)'=""

               SET K=0

FOR

                   SET K=$ORDER(^SRF(SRTN,14,K))

                   IF 'K

                       QUIT

                   SET SRD(J)=SRD(J)_","

                   SET J=J+1

                   SET SRD(J)=$PIECE(^SRF(SRTN,14,K,0),"^")

 +2        IF SRD(1)'=""

               SET SRN=.3

               DO WP

FIND       IF '$ORDER(^SRF(SRTN,38,0))

               GOTO POST

 +1        IF '$ORDER(^LR(LRDFN,LRSS,LRI,.4,0))

               SET %X="^SRF(SRTN,38,"

               SET %Y="^LR(LRDFN,LRSS,LRI,.4,"

               DO %XY^%RCR

               SET SRN=.4

POST       IF $ORDER(^LR(LRDFN,LRSS,LRI,.5,0))

               QUIT

 +1        SET J=1

           SET SRD(1)=$PIECE($GET(^SRF(SRTN,34)),"^")

           IF SRD(1)'=""

               SET K=0

FOR

                   SET K=$ORDER(^SRF(SRTN,15,K))

                   IF 'K

                       QUIT

                   SET SRD(J)=SRD(J)_","

                   SET J=J+1

                   SET SRD(J)=$PIECE(^SRF(SRTN,15,K,0),"^")

 +2        IF SRD(1)=""

               QUIT

 +3        IF SRD(1)=""

               QUIT

           SET SRN=.5

WP         SET DIWL=1

           SET DIWR=75

           SET DIWF=""

           SET SRJ=J

           KILL ^UTILITY($JOB,"W")

           FOR SRK=1:1:SRJ

               SET X=SRD(SRK)

               DO ^DIWP

 +1        SET J=^UTILITY($JOB,"W",DIWL)

           SET ^LR(LRDFN,LRSS,LRI,SRN,0)="^^"_J_"^"_J_"^"_DT_"^"

 +2        FOR K=1:1:J

               SET ^LR(LRDFN,LRSS,LRI,SRN,K,0)=^UTILITY($JOB,"W",DIWL,K,0)

 +3        KILL ^UTILITY($JOB,"W"),SRD

 +4        QUIT

SROSPLG2.m