SRONP2 ;BIR/ADM - PROCEDURE REPORT (NON-OR) ;07/26/04 9:45 AM
;;3.0; Surgery ;**132,142**;24 Jun 93
Q
OPTOP(SRTN) ; send op-top to ^TMP
; SRTN - case number in file 130
;
N ANE,DFN,ICD,J,NUM,SR,SRATT,SRCASE,SRDIV,SRI,SRL,SRLINE,SRLOC,SRN,SROPTOP,SRSPEC,SRSTATUS,SRTECH,X,Y
S SRCASE=SRTN,SRG=$NA(^TMP("SRNOR",$J,SRCASE)) K @SRG
S SRI=0,SRDIV=$$SITE^SROUTL0(SRTN)
I $P($G(^SRF(SRTN,30)),"^")!$P($G(^SRF(SRTN,31)),"^",8) D LINE(1) S @SRG@(SRI)=" * * PROCEDURE ABORTED * *" D LINE(1)
F SRN=0:.1:1.1,"NON" S SR(SRN)=$G(^SRF(SRTN,SRN))
S Y=$P(SR("NON"),"^",8),C=$P(^DD(130,125,0),"^",2) D:Y'="" Y^DIQ S SRSPEC=$S(Y="":"NOT ENTERED",1:$E(Y,1,25))
S SRLOC="NOT ENTERED",SRL=$P(SR("NON"),"^",2) S:SRL SRLOC=$E($P(^SC(SRL,0),"^"),1,25)
D LINE(1) S @SRG@(SRI)="Med. Specialty: "_SRSPEC,@SRG@(SRI)=@SRG@(SRI)_$$SPACE(44)_"Location: "_SRLOC
S X=$P($G(^SRF(SRTN,33)),"^",2) D LINE(2) S @SRG@(SRI)="Principal Diagnosis: " D
.I X="" S @SRG@(SRI)=@SRG@(SRI)_"NOT ENTERED" Q
.D LINE(1) S @SRG@(SRI)=" "_X
.S @SRG@(SRI)=@SRG@(SRI)
.N OTH,CNT S (OTH,CNT)=0 F S OTH=$O(^SRF(SRTN,15,OTH)) Q:'OTH S CNT=CNT+1 D DIAG
S Y=$P(SR("NON"),"^",6),C=$P(^DD(130,123,0),"^",2) D:Y'="" Y^DIQ D LINE(2) S @SRG@(SRI)="Provider: "_Y
S X=$P($G(SR(0)),"^",12),SRSTATUS=$S(X="I":"INPATIENT",X="O":"OUTPATIENT",1:"NOT ENTERED")
S @SRG@(SRI)=@SRG@(SRI)_$$SPACE(50)_"Patient Status: "_SRSTATUS
S Y=$P(SR("NON"),"^",7),C=$P(^DD(130,124,0),"^",2) D:Y'="" Y^DIQ,N(28) S:Y="" Y="N/A" D LINE(1) S @SRG@(SRI)="Attending: "_Y
D RS S:SRATT="" SRATT="NOT ENTERED" D LINE(1) S @SRG@(SRI)="Attending Code: "_SRATT
S Y=$P(SR(.3),"^",4),C=$P(^DD(130,.34,0),"^",2) D:Y'="" Y^DIQ S:Y="" Y="N/A" D LINE(2) S @SRG@(SRI)="Attend Anesth: "_Y
S X=$P(SR(.3),"^",6),X=$S(X:$P(^SRO(132.95,X,0),"^"),1:"N/A")
D LINE(1) S @SRG@(SRI)="Anesthesia Supervisor Code: "_X
S Y=$P(SR(.3),"^"),C=$P(^DD(130,.31,0),"^",2) D:Y'="" Y^DIQ S:Y="" Y="N/A" D LINE(1) S @SRG@(SRI)="Anesthetist: "_Y
D LINE(2) S @SRG@(SRI)="Anesthesia Technique(s): " D
.I '$O(^SRF(SRTN,6,0)) S @SRG@(SRI)=@SRG@(SRI)_"N/A" Q
.S ANE=0 F S ANE=$O(^SRF(SRTN,6,ANE)) Q:'ANE D ANE
D TECH I $E(SRTECH,1,2)'="NO" S X=$P($G(^SRF(SRTN,31)),"^",9),X=$S(X="N":"NO",X="Y":"YES",1:"") I X'="" D LINE(2) S @SRG@(SRI)="Diagnostic/Therapeutic: "_X
D ^SRONP0
Q
DIAG D LINE(1) S X=$G(^SRF(SRTN,15,OTH,0)),@SRG@(SRI)=$S(CNT=1:" Other: ",1:" ")_$P(X,"^"),ICD=$P(X,"^",3)
S ICD=$S(ICD:$P(^ICD9(ICD,0),"^"),1:"NOT ENTERED"),@SRG@(SRI)=@SRG@(SRI)_$$SPACE(50)_"ICD9 Code: "_ICD
Q
N(SRL) N SRNM I $L(Y)>SRL S SRNM=$P(Y,",")_","_$E($P(Y,",",2))_".",Y=SRNM
Q
TECH N SRT,SRZ D TECH^SROPRIN
Q
ANE ; print anesthesia technique
N A,AGNT,C,CNT
S A=^SRF(SRTN,6,ANE,0),Y=$P(A,"^"),C=$P(^DD(130.06,.01,0),"^",2) D:Y'="" Y^DIQ D LINE(1) S Y=Y_$S($P(A,"^",3)="Y":" (PRINCIPAL)",1:""),@SRG@(SRI)=$$SPACE(2)_Y D AGENT
Q
AGENT ; print agents
Q:$P(A,"^")="N" N SRDOSE,SRY
D LINE(1) S @SRG@(SRI)=" Agent: " I '$O(^SRF(SRTN,6,ANE,1,0)) S @SRG@(SRI)=@SRG@(SRI)_"NONE ENTERED" Q
S (AGNT,CNT)=0 F S AGNT=$O(^SRF(SRTN,6,ANE,1,AGNT)) Q:'AGNT S CNT=CNT+1 D
.S SRY=^SRF(SRTN,6,ANE,1,AGNT,0),SRDOSE=$P(SRY,"^",2)
.S Y=$P(SRY,"^"),C=$P(^DD(130.47,.01,0),"^",2) D Y^DIQ
.D:CNT>1 LINE(1) S @SRG@(SRI)=@SRG@(SRI)_$$SPACE(13)_Y
.I SRDOSE S @SRG@(SRI)=@SRG@(SRI)_" "_SRDOSE_" mg"
Q
RS ; attending code
I $$GET1^DID(130,.166,"","LABEL")["ATTENDING CODE" D Q
.S Y=$P(SR(.1),"^",10),C=$P(^DD(130,.166,0),"^",2) D Y^DIQ S SRATT=Y
S Y=$P(SR(.1),"^",16),C=$P(^DD(130,.165,0),"^",2) D Y^DIQ S SRATT=Y
Q
COMM(X,NUM) ; output word-processing text
; X = line of text to be processed
; NUM = left margin
N I,J,K,Y,SRL S SRL=80-NUM
I $L(X)<(SRL+1)!($E(X,1,SRL)'[" ") D LINE(1) S @SRG@(SRI)=$$SPACE(NUM)_X Q
S K=1 F D I $L(X)<SRL+1 S X(K)=X Q
.F I=0:1:SRL-1 S J=SRL-I,Y=$E(X,J) I Y=" " S X(K)=$E(X,1,J-1),X=$E(X,J+1,$L(X)) S K=K+1 Q
F I=1:1:K D LINE(1) S @SRG@(SRI)=$$SPACE(NUM)_X(I)
Q
SPACE(NUM) ; create spaces
; pass in position returns number of needed spaces
I '$D(@SRG@(SRI)) S @SRG@(SRI)=""
Q $J("",NUM-$L(@SRG@(SRI)))
LINE(NUM) ; create carriage returns
F J=1:1:NUM S SRI=SRI+1,@SRG@(SRI)=""
Q
SRONP2 ;BIR/ADM - PROCEDURE REPORT (NON-OR) ;07/26/04 9:45 AM
+1 ;;3.0; Surgery ;**132,142**;24 Jun 93
+2 QUIT
OPTOP(SRTN) ; send op-top to ^TMP
+1 ; SRTN - case number in file 130
+2 ;
+3 NEW ANE,DFN,ICD,J,NUM,SR,SRATT,SRCASE,SRDIV,SRI,SRL,SRLINE,SRLOC,SRN,SROPTOP,SRSPEC,SRSTATUS,SRTECH,X,Y
+4 SET SRCASE=SRTN
SET SRG=$NAME(^TMP("SRNOR",$JOB,SRCASE))
KILL @SRG
+5 SET SRI=0
SET SRDIV=$$SITE^SROUTL0(SRTN)
+6 IF $PIECE($GET(^SRF(SRTN,30)),"^")!$PIECE($GET(^SRF(SRTN,31)),"^",8)
DO LINE(1)
SET @SRG@(SRI)=" * * PROCEDURE ABORTED * *"
DO LINE(1)
+7 FOR SRN=0:.1:1.1,"NON"
SET SR(SRN)=$GET(^SRF(SRTN,SRN))
+8 SET Y=$PIECE(SR("NON"),"^",8)
SET C=$PIECE(^DD(130,125,0),"^",2)
IF Y'=""
DO Y^DIQ
SET SRSPEC=$SELECT(Y="":"NOT ENTERED",1:$EXTRACT(Y,1,25))
+9 SET SRLOC="NOT ENTERED"
SET SRL=$PIECE(SR("NON"),"^",2)
IF SRL
SET SRLOC=$EXTRACT($PIECE(^SC(SRL,0),"^"),1,25)
+10 DO LINE(1)
SET @SRG@(SRI)="Med. Specialty: "_SRSPEC
SET @SRG@(SRI)=@SRG@(SRI)_$$SPACE(44)_"Location: "_SRLOC
+11 SET X=$PIECE($GET(^SRF(SRTN,33)),"^",2)
DO LINE(2)
SET @SRG@(SRI)="Principal Diagnosis: "
Begin DoDot:1
+12 IF X=""
SET @SRG@(SRI)=@SRG@(SRI)_"NOT ENTERED"
QUIT
+13 DO LINE(1)
SET @SRG@(SRI)=" "_X
+14 SET @SRG@(SRI)=@SRG@(SRI)
+15 NEW OTH,CNT
SET (OTH,CNT)=0
FOR
SET OTH=$ORDER(^SRF(SRTN,15,OTH))
IF 'OTH
QUIT
SET CNT=CNT+1
DO DIAG
End DoDot:1
+16 SET Y=$PIECE(SR("NON"),"^",6)
SET C=$PIECE(^DD(130,123,0),"^",2)
IF Y'=""
DO Y^DIQ
DO LINE(2)
SET @SRG@(SRI)="Provider: "_Y
+17 SET X=$PIECE($GET(SR(0)),"^",12)
SET SRSTATUS=$SELECT(X="I":"INPATIENT",X="O":"OUTPATIENT",1:"NOT ENTERED")
+18 SET @SRG@(SRI)=@SRG@(SRI)_$$SPACE(50)_"Patient Status: "_SRSTATUS
+19 SET Y=$PIECE(SR("NON"),"^",7)
SET C=$PIECE(^DD(130,124,0),"^",2)
IF Y'=""
DO Y^DIQ
DO N(28)
IF Y=""
SET Y="N/A"
DO LINE(1)
SET @SRG@(SRI)="Attending: "_Y
+20 DO RS
IF SRATT=""
SET SRATT="NOT ENTERED"
DO LINE(1)
SET @SRG@(SRI)="Attending Code: "_SRATT
+21 SET Y=$PIECE(SR(.3),"^",4)
SET C=$PIECE(^DD(130,.34,0),"^",2)
IF Y'=""
DO Y^DIQ
IF Y=""
SET Y="N/A"
DO LINE(2)
SET @SRG@(SRI)="Attend Anesth: "_Y
+22 SET X=$PIECE(SR(.3),"^",6)
SET X=$SELECT(X:$PIECE(^SRO(132.95,X,0),"^"),1:"N/A")
+23 DO LINE(1)
SET @SRG@(SRI)="Anesthesia Supervisor Code: "_X
+24 SET Y=$PIECE(SR(.3),"^")
SET C=$PIECE(^DD(130,.31,0),"^",2)
IF Y'=""
DO Y^DIQ
IF Y=""
SET Y="N/A"
DO LINE(1)
SET @SRG@(SRI)="Anesthetist: "_Y
+25 DO LINE(2)
SET @SRG@(SRI)="Anesthesia Technique(s): "
Begin DoDot:1
+26 IF '$ORDER(^SRF(SRTN,6,0))
SET @SRG@(SRI)=@SRG@(SRI)_"N/A"
QUIT
+27 SET ANE=0
FOR
SET ANE=$ORDER(^SRF(SRTN,6,ANE))
IF 'ANE
QUIT
DO ANE
End DoDot:1
+28 DO TECH
IF $EXTRACT(SRTECH,1,2)'="NO"
SET X=$PIECE($GET(^SRF(SRTN,31)),"^",9)
SET X=$SELECT(X="N":"NO",X="Y":"YES",1:"")
IF X'=""
DO LINE(2)
SET @SRG@(SRI)="Diagnostic/Therapeutic: "_X
+29 DO ^SRONP0
+30 QUIT
DIAG DO LINE(1)
SET X=$GET(^SRF(SRTN,15,OTH,0))
SET @SRG@(SRI)=$SELECT(CNT=1:" Other: ",1:" ")_$PIECE(X,"^")
SET ICD=$PIECE(X,"^",3)
+1 SET ICD=$SELECT(ICD:$PIECE(^ICD9(ICD,0),"^"),1:"NOT ENTERED")
SET @SRG@(SRI)=@SRG@(SRI)_$$SPACE(50)_"ICD9 Code: "_ICD
+2 QUIT
N(SRL) NEW SRNM
IF $LENGTH(Y)>SRL
SET SRNM=$PIECE(Y,",")_","_$EXTRACT($PIECE(Y,",",2))_"."
SET Y=SRNM
+1 QUIT
TECH NEW SRT,SRZ
DO TECH^SROPRIN
+1 QUIT
ANE ; print anesthesia technique
+1 NEW A,AGNT,C,CNT
+2 SET A=^SRF(SRTN,6,ANE,0)
SET Y=$PIECE(A,"^")
SET C=$PIECE(^DD(130.06,.01,0),"^",2)
IF Y'=""
DO Y^DIQ
DO LINE(1)
SET Y=Y_$SELECT($PIECE(A,"^",3)="Y":" (PRINCIPAL)",1:"")
SET @SRG@(SRI)=$$SPACE(2)_Y
DO AGENT
+3 QUIT
AGENT ; print agents
+1 IF $PIECE(A,"^")="N"
QUIT
NEW SRDOSE,SRY
+2 DO LINE(1)
SET @SRG@(SRI)=" Agent: "
IF '$ORDER(^SRF(SRTN,6,ANE,1,0))
SET @SRG@(SRI)=@SRG@(SRI)_"NONE ENTERED"
QUIT
+3 SET (AGNT,CNT)=0
FOR
SET AGNT=$ORDER(^SRF(SRTN,6,ANE,1,AGNT))
IF 'AGNT
QUIT
SET CNT=CNT+1
Begin DoDot:1
+4 SET SRY=^SRF(SRTN,6,ANE,1,AGNT,0)
SET SRDOSE=$PIECE(SRY,"^",2)
+5 SET Y=$PIECE(SRY,"^")
SET C=$PIECE(^DD(130.47,.01,0),"^",2)
DO Y^DIQ
+6 IF CNT>1
DO LINE(1)
SET @SRG@(SRI)=@SRG@(SRI)_$$SPACE(13)_Y
+7 IF SRDOSE
SET @SRG@(SRI)=@SRG@(SRI)_" "_SRDOSE_" mg"
End DoDot:1
+8 QUIT
RS ; attending code
+1 IF $$GET1^DID(130,.166,"","LABEL")["ATTENDING CODE"
Begin DoDot:1
+2 SET Y=$PIECE(SR(.1),"^",10)
SET C=$PIECE(^DD(130,.166,0),"^",2)
DO Y^DIQ
SET SRATT=Y
End DoDot:1
QUIT
+3 SET Y=$PIECE(SR(.1),"^",16)
SET C=$PIECE(^DD(130,.165,0),"^",2)
DO Y^DIQ
SET SRATT=Y
+4 QUIT
COMM(X,NUM) ; output word-processing text
+1 ; X = line of text to be processed
+2 ; NUM = left margin
+3 NEW I,J,K,Y,SRL
SET SRL=80-NUM
+4 IF $LENGTH(X)<(SRL+1)!($EXTRACT(X,1,SRL)'[" ")
DO LINE(1)
SET @SRG@(SRI)=$$SPACE(NUM)_X
QUIT
+5 SET K=1
FOR
Begin DoDot:1
+6 FOR I=0:1:SRL-1
SET J=SRL-I
SET Y=$EXTRACT(X,J)
IF Y=" "
SET X(K)=$EXTRACT(X,1,J-1)
SET X=$EXTRACT(X,J+1,$LENGTH(X))
SET K=K+1
QUIT
End DoDot:1
IF $LENGTH(X)<SRL+1
SET X(K)=X
QUIT
+7 FOR I=1:1:K
DO LINE(1)
SET @SRG@(SRI)=$$SPACE(NUM)_X(I)
+8 QUIT
SPACE(NUM) ; create spaces
+1 ; pass in position returns number of needed spaces
+2 IF '$DATA(@SRG@(SRI))
SET @SRG@(SRI)=""
+3 QUIT $JUSTIFY("",NUM-$LENGTH(@SRG@(SRI)))
LINE(NUM) ; create carriage returns
+1 FOR J=1:1:NUM
SET SRI=SRI+1
SET @SRG@(SRI)=""
+2 QUIT
