- SRONP ;BIR/ADM - PROCEDURE REPORT (NON-OR) ; [ 10/06/03 10:45 AM ]
- ;;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")),"^",3) Q:'SRTIU
- D STATUS Q:SRSTAT>1
- S SRCASE=SRTN S:'$L($G(SRG)) SRG=$NA(^TMP("SRNOR",$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)=" * * PROCEDURE ABORTED * *" D LINE(1)
- S SR(0)=^SRF(SRTN,0)
- D PRIN I $O(^SRF(SRTN,13,0)) D OTHER
- Q
- STATUS ; check status of TIU document
- D EXTRACT^TIULQ(SRTIU,"SRT",.SRERR,".05") S SRSTAT=SRT(SRTIU,.05,"I")
- Q
- PRIN ; print principal procedure information
- N I,M,MM,MMM,SRJ,SROPER,SROPS
- D LINE(1) S @SRG@(SRI)="Non-O.R. Procedure(s) Performed:"
- PRIN2 S SROPER=$P(^SRF(SRTN,"OP"),"^")
- I $P($G(^SRF(SRTN,30)),"^") 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)
- Q
- 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
- Q
- OTH S OTHER=$P(^SRF(SRTN,13,OTH,0),"^")
- D LINE(1) S @SRG@(SRI)=" Other: "_OTHER
- Q
- 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
- Q
- 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)=" "
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSRONP 2217 printed Feb 19, 2025@00:10:58 Page 2
- SRONP ;BIR/ADM - PROCEDURE REPORT (NON-OR) ; [ 10/06/03 10:45 AM ]
- +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 ;
- 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")),"^",3)
- if 'SRTIU
- QUIT
- +11 DO STATUS
- if SRSTAT>1
- QUIT
- +12 SET SRCASE=SRTN
- if '$LENGTH($GET(SRG))
- SET SRG=$NAME(^TMP("SRNOR",$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)=" * * PROCEDURE 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)="Non-O.R. Procedure(s) Performed:"
- PRIN2 SET SROPER=$PIECE(^SRF(SRTN,"OP"),"^")
- +1 IF $PIECE($GET(^SRF(SRTN,30)),"^")
- 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