Routine: SROSRPT

SROSRPT ;BIR/ADM - OPERATION REPORT ; [ 10/06/03  2:45 PM ]

 ;;3.0; Surgery ;**100**;24 Jun 93

 ;** NOTICE: This routine is part of an implementation of a nationally

 ;**         controlled procedure.  Local modifications to this routine

 ;**         are prohibited.

 ; Reference to EXTRACT^TIULQ supported by DBIA #2693

OPTOP(SRTN,SRLAST,SRG) ; send op-top to ^TMP

 ; SRTN   - case number in file 130

 ; SRLAST - (optional)

 ;          0 or null : include summary status at end

 ;          1 : omit summary status at end

 ;          2 : include summary status at end plus summary in TIU

 ; SRG    - (optional) return array

 Q:'$D(SROVP)

 N J,LOOP,SR,SRALL,SRCASE,SRERR,SRI,SRLF,SRSTAT,SRT,SRTIU

 S SRTIU=$P($G(^SRF(SRTN,"TIU")),"^") Q:'SRTIU

 D STATUS Q:SRSTAT>1

 S SRCASE=SRTN S:'$L($G(SRG)) SRG=$NA(^TMP("SROP",$J,SRCASE)) K @SRG

 S SRI=0,SRLAST=$S($G(SRLAST):SRLAST,1:1),@SRG@(SRI)=3

 I $P($G(^SRF(SRTN,30)),"^")!$P($G(^SRF(SRTN,31)),"^",8) D LINE(1) S @SRG@(SRI)="  * * OPERATION ABORTED * *" D LINE(1)

 S SR(0)=^SRF(SRTN,0)

 D PRIN I $O(^SRF(SRTN,13,0)) D OTHER

STATUS ; check status of TIU document

 D EXTRACT^TIULQ(SRTIU,"SRT",.SRERR,".05") S SRSTAT=SRT(SRTIU,.05,"I")

PRIN ; print principal procedure information

 N I,M,MM,MMM,SRJ,SROPER,SROPS

 D LINE(1) S @SRG@(SRI)="Procedure(s) Performed:"

PRIN2 S SROPER=$P(^SRF(SRTN,"OP"),"^")

 I $P($G(^SRF(SRTN,30)),"^")&$P($G(^SRF(SRTN,.2)),"^",10) S SROPER="** ABORTED ** "_SROPER

 K SROPS,MM,MMM S:$L(SROPER)<70 SROPS(1)=SROPER I $L(SROPER)>69 S SROPER=SROPER_"  " F M=1:1 D LOOP Q:MMM=""

 F I=1:1 Q:'$D(SROPS(I))  D LINE(1) S @SRG@(SRI)=$S(I=1:" Principal: ",1:"         ")_SROPS(I)

OTHER ; other procedures

 N CNT,OTH,OTHER

 S (OTH,CNT)=0 F  S OTH=$O(^SRF(SRTN,13,OTH)) Q:'OTH  S CNT=CNT+1 D OTH

OTH S OTHER=$P(^SRF(SRTN,13,OTH,0),"^")

 D LINE(1) S @SRG@(SRI)="     Other: "_OTHER

LOOP ; break procedure if greater than 70 characters

 S SROPS(M)="" F LOOP=1:1 S MM=$P(SROPER," "),MMM=$P(SROPER," ",2,200) Q:MMM=""  Q:$L(SROPS(M))+$L(MM)'<70  S SROPS(M)=SROPS(M)_MM_" ",SROPER=MMM

LINE(NUM) ;create carriage returns

 I $G(SRLF) S NUM=NUM+1,SRLF=0

 F J=1:1:NUM S SRI=SRI+1,@SRG@(SRI)=" "

SROSRPT   ;BIR/ADM - OPERATION REPORT ; [ 10/06/03  2:45 PM ]

 +1       ;;3.0; Surgery ;**100**;24 Jun 93

 +2       ;

 +3       ;** NOTICE: This routine is part of an implementation of a nationally

 +4       ;**         controlled procedure.  Local modifications to this routine

 +5       ;**         are prohibited.

 +6       ;

 +7       ; Reference to EXTRACT^TIULQ supported by DBIA #2693

 +8       ;

 +9        QUIT

OPTOP(SRTN,SRLAST,SRG) ; send op-top to ^TMP

 +1       ; SRTN   - case number in file 130

 +2       ; SRLAST - (optional)

 +3       ;          0 or null : include summary status at end

 +4       ;          1 : omit summary status at end

 +5       ;          2 : include summary status at end plus summary in TIU

 +6       ; SRG    - (optional) return array

 +7       ;

 +8        IF '$DATA(SROVP)

               QUIT

 +9        NEW J,LOOP,SR,SRALL,SRCASE,SRERR,SRI,SRLF,SRSTAT,SRT,SRTIU

 +10       SET SRTIU=$PIECE($GET(^SRF(SRTN,"TIU")),"^")

           IF 'SRTIU

               QUIT

 +11       DO STATUS

           IF SRSTAT>1

               QUIT

 +12       SET SRCASE=SRTN

           IF '$LENGTH($GET(SRG))

               SET SRG=$NAME(^TMP("SROP",$JOB,SRCASE))

           KILL @SRG

 +13       SET SRI=0

           SET SRLAST=$SELECT($GET(SRLAST):SRLAST,1:1)

           SET @SRG@(SRI)=3

 +14       IF $PIECE($GET(^SRF(SRTN,30)),"^")!$PIECE($GET(^SRF(SRTN,31)),"^",8)

               DO LINE(1)

               SET @SRG@(SRI)="  * * OPERATION ABORTED * *"

               DO LINE(1)

 +15       SET SR(0)=^SRF(SRTN,0)

 +16       DO PRIN

           IF $ORDER(^SRF(SRTN,13,0))

               DO OTHER

 +17       QUIT

STATUS    ; check status of TIU document

 +1        DO EXTRACT^TIULQ(SRTIU,"SRT",.SRERR,".05")

           SET SRSTAT=SRT(SRTIU,.05,"I")

 +2        QUIT

PRIN      ; print principal procedure information

 +1        NEW I,M,MM,MMM,SRJ,SROPER,SROPS

 +2        DO LINE(1)

           SET @SRG@(SRI)="Procedure(s) Performed:"

PRIN2      SET SROPER=$PIECE(^SRF(SRTN,"OP"),"^")

 +1        IF $PIECE($GET(^SRF(SRTN,30)),"^")&$PIECE($GET(^SRF(SRTN,.2)),"^",10)

               SET SROPER="** ABORTED ** "_SROPER

 +2        KILL SROPS,MM,MMM

           IF $LENGTH(SROPER)<70

               SET SROPS(1)=SROPER

           IF $LENGTH(SROPER)>69

               SET SROPER=SROPER_"  "

               FOR M=1:1

                   DO LOOP

                   IF MMM=""

                       QUIT

 +3        FOR I=1:1

               IF '$DATA(SROPS(I))

                   QUIT

               DO LINE(1)

               SET @SRG@(SRI)=$SELECT(I=1:" Principal: ",1:"         ")_SROPS(I)

 +4        QUIT

OTHER     ; other procedures

 +1        NEW CNT,OTH,OTHER

 +2        SET (OTH,CNT)=0

FOR

               SET OTH=$ORDER(^SRF(SRTN,13,OTH))

               IF 'OTH

                   QUIT

               SET CNT=CNT+1

               DO OTH

 +3        QUIT

OTH        SET OTHER=$PIECE(^SRF(SRTN,13,OTH,0),"^")

 +1        DO LINE(1)

           SET @SRG@(SRI)="     Other: "_OTHER

 +2        QUIT

LOOP      ; break procedure if greater than 70 characters

 +1        SET SROPS(M)=""

           FOR LOOP=1:1

               SET MM=$PIECE(SROPER," ")

               SET MMM=$PIECE(SROPER," ",2,200)

               IF MMM=""

                   QUIT

               IF $LENGTH(SROPS(M))+$LENGTH(MM)'<70

                   QUIT

               SET SROPS(M)=SROPS(M)_MM_" "

               SET SROPER=MMM

 +2        QUIT

LINE(NUM) ;create carriage returns

 +1        IF $GET(SRLF)

               SET NUM=NUM+1

               SET SRLF=0

 +2        FOR J=1:1:NUM

               SET SRI=SRI+1

               SET @SRG@(SRI)=" "

 +3        QUIT

SROSRPT.m