SROANP ;B'HAM ISC/MAM - LIST OF ANESTHETIC PROCEDURES ; [ 09/07/00 11:27 AM ]
;;3.0; Surgery ;**38,53,50,95,151**;24 Jun 93
;
;Reference to ^PSS50 supported by DBIA #4533
;
SET ; set and print information for a case
S SRNON=0 I $P($G(^SRF(SRTN,"NON")),"^")="Y" S SRNON=1
I SRFLG=1!(SRFLG=3&('SRNON)) Q:$P($G(^SRF(SRTN,.2)),"^",12)=""
I SRFLG=2 Q:'SRNON
K S(.2),SRAGNT,SRTECH,SRPRIN,SRANE3
S S(0)=^SRF(SRTN,0),DFN=+S(0) D DEM^VADPT S SRDPT=VADM(1),SRSSN=VA("PID"),SRDATE=$P(S(0),"^",9),Y=SRDATE,SRDT=$E(SRDATE,4,5)_"/"_$E(SRDATE,6,7)_"/"_$E(SRDATE,2,3)
D D^DIQ S SRFIND=$F(Y,":") S SRDATE=$S(SRFIND:SRDT_" "_$E(Y,SRFIND-3,SRFIND+1),1:SRDT)
S:SRDPT>18 SRDPT=$P(SRDPT,",")_", "_$E($P(SRDPT,",",2))
I 'SRNON S SRICD=$S($D(^SRF(SRTN,34)):$P(^(34),"^"),$D(^SRF(SRTN,33)):$P(^(33),"^"),1:"")
I SRNON S SRICD=$P($G(^SRF(SRTN,33)),"^",2)
OPS S SROPER=$P(^SRF(SRTN,"OP"),"^"),OPER=0 F S OPER=$O(^SRF(SRTN,13,OPER)) Q:OPER="" D OTHER
K SROPS,MM,MMM S:$L(SROPER)<50 SROPS(1)=SROPER I $L(SROPER)>49 S SROPER=SROPER_" " F M=1:1 D LOOP Q:MMM=""
S SRPRIN=$S($D(^SRF(SRTN,.3)):$P(^(.3),"^"),1:"") I SRPRIN'="" S SRPRIN=$P(^VA(200,SRPRIN,0),"^")
S Y=$P($G(^SRF(SRTN,1.1)),"^",3),C=$P(^DD(130,1.13,0),"^",2) D:Y'="" Y^DIQ S SRASA=$P(Y,"-",2,3)
K SRTECH S (SRT,SRZ)=0 F S SRT=$O(^SRF(SRTN,6,SRT)) Q:SRT=""!(SRZ) D ^SROPRIN I SRZ D AGENT
I '$D(SRTECH) S (SRTECH,SRAGNT)=""
S:'$D(SRAGNT) SRAGNT=""
I SRTECH'="" S Y=SRTECH,C=$P(^DD(130.06,.01,0),"^",2) D Y^DIQ S SRTECH=Y
I $D(^SRF(SRTN,.2)) S S(.2)=^(.2),SRANE1=$P(S(.2),"^",1),SRANE2=$P(S(.2),"^",4) S X1=SRANE2,X=SRANE1 I X1,X D MINS^SRSUTL2 S SRANE3=X
S:'$D(SRANE3) SRANE3="" I '$D(S(.2)) S (SRANE1,SRANE2)=""
I SRANE1 S Y=SRANE1 D D^DIQ S SRFIND=$F(Y,":"),SRANE1=$S(SRFIND:$E(Y,SRFIND-3,SRFIND+1),1:"")
I SRANE2 S Y=SRANE2 D D^DIQ S SRFIND=$F(Y,":"),SRANE2=$S(SRFIND:$E(Y,SRFIND-3,SRFIND+1),1:"")
PRINT ; print results
I $Y+7>IOSL D PAGE
Q:SRF W !,SRDATE,?16,SRDPT,?40,SRICD,?97,$E(SRPRIN,1,15),?118,SRANE1,!,SRTN,?16,VA("PID"),?40,SROPS(1),?97,$E(SRTECH,1,20),?118,SRANE2
W ! W:SRFLG=3&(SRNON) "NON-O.R." W ?16,SRASA W:$D(SROPS(2)) ?40,SROPS(2) W ?97,$E(SRAGNT,1,20),?118,SRANE3,!
I $D(SROPS(3)) W ?40,SROPS(3),! I $D(SROPS(4)) W ?40,SROPS(4),! I $D(SROPS(5)) W ?40,SROPS(5),! I $D(SROPS(6)) W ?40,SROPS(6),!
Q
OTHER ; other operations
S SRLONG=1 I $L(SROPER)+$L($P(^SRF(SRTN,13,OPER,0),"^"))>250 S SRLONG=0,OPER=999,SROPERS=" ..."
I SRLONG S SROPERS=$P(^SRF(SRTN,13,OPER,0),"^")
S SROPER=SROPER_$S(SROPERS=" ...":SROPERS,1:", "_SROPERS)
Q
LOOP ; break procedure name if greater than 50 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)'<50 S SROPS(M)=SROPS(M)_MM_" ",SROPER=MMM
Q
AGENT S SRAGNT=$O(^SRF(SRTN,6,SRT,1,0)) Q:SRAGNT="" S SRAGNT=$P(^SRF(SRTN,6,SRT,1,SRAGNT,0),"^") D
.D DATA^PSS50(SRAGNT,,,,,"SRRX") S SRAGNT=$P($G(^TMP($J,"SRRX",SRAGNT,.01)),"^") K ^TMP($J,"SRRX",SRAGNT)
Q
BEG ;
U IO N SRFRTO S SRED1=SRED_.9999,SRF=0,PAGE=1,Y=DT X ^DD("DD") S SRPRINT="DATE PRINTED: "_Y S Y=SRSD X ^DD("DD") S SRFRTO="FROM: "_Y_" TO: ",Y=SRED X ^DD("DD") S SRFRTO=SRFRTO_Y
S SRINST=SRSITE("SITE"),SRINSTP=SRSITE("DIV") D HDR^SROANP1 Q:SRF
S DATE=SRSD-.0009 F S DATE=$O(^SRF("AC",DATE)) Q:DATE>SRED1!(DATE="")!SRF S SRTN=0 F S SRTN=$O(^SRF("AC",DATE,SRTN)) Q:SRTN=""!SRF I $D(^SRF(SRTN,0)),$$DIV^SROUTL0(SRTN) D SET
Q
PAGE I $E(IOST)'="P" W !!,"Press RETURN to continue, '^' to quit " R ASK:DTIME I '$T!(ASK="^") S SRF=1 Q
D HDR^SROANP1 Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSROANP 3541 printed Sep 23, 2025@20:17:35 Page 2
SROANP ;B'HAM ISC/MAM - LIST OF ANESTHETIC PROCEDURES ; [ 09/07/00 11:27 AM ]
+1 ;;3.0; Surgery ;**38,53,50,95,151**;24 Jun 93
+2 ;
+3 ;Reference to ^PSS50 supported by DBIA #4533
+4 ;
SET ; set and print information for a case
+1 SET SRNON=0
IF $PIECE($GET(^SRF(SRTN,"NON")),"^")="Y"
SET SRNON=1
+2 IF SRFLG=1!(SRFLG=3&('SRNON))
if $PIECE($GET(^SRF(SRTN,.2)),"^",12)=""
QUIT
+3 IF SRFLG=2
if 'SRNON
QUIT
+4 KILL S(.2),SRAGNT,SRTECH,SRPRIN,SRANE3
+5 SET S(0)=^SRF(SRTN,0)
SET DFN=+S(0)
DO DEM^VADPT
SET SRDPT=VADM(1)
SET SRSSN=VA("PID")
SET SRDATE=$PIECE(S(0),"^",9)
SET Y=SRDATE
SET SRDT=$EXTRACT(SRDATE,4,5)_"/"_$EXTRACT(SRDATE,6,7)_"/"_$EXTRACT(SRDATE,2,3)
+6 DO D^DIQ
SET SRFIND=$FIND(Y,":")
SET SRDATE=$SELECT(SRFIND:SRDT_" "_$EXTRACT(Y,SRFIND-3,SRFIND+1),1:SRDT)
+7 if SRDPT>18
SET SRDPT=$PIECE(SRDPT,",")_", "_$EXTRACT($PIECE(SRDPT,",",2))
+8 IF 'SRNON
SET SRICD=$SELECT($DATA(^SRF(SRTN,34)):$PIECE(^(34),"^"),$DATA(^SRF(SRTN,33)):$PIECE(^(33),"^"),1:"")
+9 IF SRNON
SET SRICD=$PIECE($GET(^SRF(SRTN,33)),"^",2)
OPS SET SROPER=$PIECE(^SRF(SRTN,"OP"),"^")
SET OPER=0
FOR
SET OPER=$ORDER(^SRF(SRTN,13,OPER))
if OPER=""
QUIT
DO OTHER
+1 KILL SROPS,MM,MMM
if $LENGTH(SROPER)<50
SET SROPS(1)=SROPER
IF $LENGTH(SROPER)>49
SET SROPER=SROPER_" "
FOR M=1:1
DO LOOP
if MMM=""
QUIT
+2 SET SRPRIN=$SELECT($DATA(^SRF(SRTN,.3)):$PIECE(^(.3),"^"),1:"")
IF SRPRIN'=""
SET SRPRIN=$PIECE(^VA(200,SRPRIN,0),"^")
+3 SET Y=$PIECE($GET(^SRF(SRTN,1.1)),"^",3)
SET C=$PIECE(^DD(130,1.13,0),"^",2)
if Y'=""
DO Y^DIQ
SET SRASA=$PIECE(Y,"-",2,3)
+4 KILL SRTECH
SET (SRT,SRZ)=0
FOR
SET SRT=$ORDER(^SRF(SRTN,6,SRT))
if SRT=""!(SRZ)
QUIT
DO ^SROPRIN
IF SRZ
DO AGENT
+5 IF '$DATA(SRTECH)
SET (SRTECH,SRAGNT)=""
+6 if '$DATA(SRAGNT)
SET SRAGNT=""
+7 IF SRTECH'=""
SET Y=SRTECH
SET C=$PIECE(^DD(130.06,.01,0),"^",2)
DO Y^DIQ
SET SRTECH=Y
+8 IF $DATA(^SRF(SRTN,.2))
SET S(.2)=^(.2)
SET SRANE1=$PIECE(S(.2),"^",1)
SET SRANE2=$PIECE(S(.2),"^",4)
SET X1=SRANE2
SET X=SRANE1
IF X1
IF X
DO MINS^SRSUTL2
SET SRANE3=X
+9 if '$DATA(SRANE3)
SET SRANE3=""
IF '$DATA(S(.2))
SET (SRANE1,SRANE2)=""
+10 IF SRANE1
SET Y=SRANE1
DO D^DIQ
SET SRFIND=$FIND(Y,":")
SET SRANE1=$SELECT(SRFIND:$EXTRACT(Y,SRFIND-3,SRFIND+1),1:"")
+11 IF SRANE2
SET Y=SRANE2
DO D^DIQ
SET SRFIND=$FIND(Y,":")
SET SRANE2=$SELECT(SRFIND:$EXTRACT(Y,SRFIND-3,SRFIND+1),1:"")
PRINT ; print results
+1 IF $Y+7>IOSL
DO PAGE
+2 if SRF
QUIT
WRITE !,SRDATE,?16,SRDPT,?40,SRICD,?97,$EXTRACT(SRPRIN,1,15),?118,SRANE1,!,SRTN,?16,VA("PID"),?40,SROPS(1),?97,$EXTRACT(SRTECH,1,20),?118,SRANE2
+3 WRITE !
if SRFLG=3&(SRNON)
WRITE "NON-O.R."
WRITE ?16,SRASA
if $DATA(SROPS(2))
WRITE ?40,SROPS(2)
WRITE ?97,$EXTRACT(SRAGNT,1,20),?118,SRANE3,!
+4 IF $DATA(SROPS(3))
WRITE ?40,SROPS(3),!
IF $DATA(SROPS(4))
WRITE ?40,SROPS(4),!
IF $DATA(SROPS(5))
WRITE ?40,SROPS(5),!
IF $DATA(SROPS(6))
WRITE ?40,SROPS(6),!
+5 QUIT
OTHER ; other operations
+1 SET SRLONG=1
IF $LENGTH(SROPER)+$LENGTH($PIECE(^SRF(SRTN,13,OPER,0),"^"))>250
SET SRLONG=0
SET OPER=999
SET SROPERS=" ..."
+2 IF SRLONG
SET SROPERS=$PIECE(^SRF(SRTN,13,OPER,0),"^")
+3 SET SROPER=SROPER_$SELECT(SROPERS=" ...":SROPERS,1:", "_SROPERS)
+4 QUIT
LOOP ; break procedure name if greater than 50 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)'<50
QUIT
SET SROPS(M)=SROPS(M)_MM_" "
SET SROPER=MMM
+2 QUIT
AGENT SET SRAGNT=$ORDER(^SRF(SRTN,6,SRT,1,0))
if SRAGNT=""
QUIT
SET SRAGNT=$PIECE(^SRF(SRTN,6,SRT,1,SRAGNT,0),"^")
Begin DoDot:1
+1 DO DATA^PSS50(SRAGNT,,,,,"SRRX")
SET SRAGNT=$PIECE($GET(^TMP($JOB,"SRRX",SRAGNT,.01)),"^")
KILL ^TMP($JOB,"SRRX",SRAGNT)
End DoDot:1
+2 QUIT
BEG ;
+1 USE IO
NEW SRFRTO
SET SRED1=SRED_.9999
SET SRF=0
SET PAGE=1
SET Y=DT
XECUTE ^DD("DD")
SET SRPRINT="DATE PRINTED: "_Y
SET Y=SRSD
XECUTE ^DD("DD")
SET SRFRTO="FROM: "_Y_" TO: "
SET Y=SRED
XECUTE ^DD("DD")
SET SRFRTO=SRFRTO_Y
+2 SET SRINST=SRSITE("SITE")
SET SRINSTP=SRSITE("DIV")
DO HDR^SROANP1
if SRF
QUIT
+3 SET DATE=SRSD-.0009
FOR
SET DATE=$ORDER(^SRF("AC",DATE))
if DATE>SRED1!(DATE="")!SRF
QUIT
SET SRTN=0
FOR
SET SRTN=$ORDER(^SRF("AC",DATE,SRTN))
if SRTN=""!SRF
QUIT
IF $DATA(^SRF(SRTN,0))
IF $$DIV^SROUTL0(SRTN)
DO SET
+4 QUIT
PAGE IF $EXTRACT(IOST)'="P"
WRITE !!,"Press RETURN to continue, '^' to quit "
READ ASK:DTIME
IF '$TEST!(ASK="^")
SET SRF=1
QUIT
+1 DO HDR^SROANP1
QUIT
