SRONPEN ;B'HAM ISC/ADM - NON-O.R. PROCEDURE REPORT ; [ 07/26/04 9:50 AM ]
;;3.0; Surgery ;**132**;24 Jun 93
I '$D(SRSITE) D ^SROVAR G:'$D(SRSITE) END S SRSITE("KILL")=1
S SRSOUT=0 I '$D(SRTN) D NON G:'$D(SRTN) END S SRTN("KILL")=1
I $P($G(^SRF(SRTN,"NON")),"^")'="Y" W !!,?5,"The case selected is not a Non-OR Procedure.",! D FOOT G END
N SRAGE,SRDIV,SRHDR,SRLOC,SRPRINT,SRSEL,SRSINED,SRDTITL
S SRDTITL="Procedure Report"
DISPLY K %ZIS,IO("Q") S %ZIS="Q" D ^%ZIS I POP G END
I $D(IO("Q")) K IO("Q") S ZTDESC="Procedure Report",ZTRTN="EN^SRONPEN",(ZTSAVE("SRSITE("),ZTSAVE("SRTN"))="" D ^%ZTLOAD G END
EN D OPTOP^SRONP2(SRTN) S DFN=$P(^SRF(SRTN,0),"^"),VAINDT=$P(^SRF(SRTN,0),"^",9)
S Y=$E(VAINDT,1,7) D D^DIQ S SRSDATE=Y D OERR^VADPT
S SRHDR=" "_VADM(1)_" ("_VA("PID")_") Case #"_SRTN_" - "_SRSDATE
S Y=$E($$NOW^XLFDT,1,12) D DD^%DT S SRPRINT="Printed: "_Y
S SRLOC=" Pt Loc: "_$P(VAIN(4),"^",2)_" "_VAIN(5)
S SRAGE="",Z=$P(VADM(3),"^") I Z S X=$E($P(^SRF(SRTN,0),"^",9),1,12),Y=$E(X,1,7),SRAGE=$E(Y,1,3)-$E(Z,1,3)-($E(Y,4,7)<$E(Z,4,7))
S SRDIV=$$SITE^SROUTL0(SRTN) I SRDIV S X=$P(^SRO(133,SRDIV,0),"^"),SRDIV=$$EXTERNAL^DILFD(133,.01,"",X)
S SRDIV=$S(SRDIV'="":SRDIV,1:SRSITE("SITE"))
U IO S (SRPAGE,SRSOUT)=0,$P(SRLINE,"-",80)="" D HDR
S SRI=0 F S SRI=$O(^TMP("SRNOR",$J,SRTN,SRI)) Q:'SRI D Q:SRSOUT
.I $E(IOST)="P",$Y+11>IOSL D FOOT Q:SRSOUT D HDR
.I $E(IOST)'="P",$Y+3>IOSL D FOOT Q:SRSOUT D HDR
.W !,^TMP("SRNOR",$J,SRTN,SRI)
D:'SRSOUT FOOT D END
Q
SRHDR S DFN=$P(^SRF(SRTN,0),"^") D DEM^VADPT
S Y=$E($P(^SRF(SRTN,0),"^",9),1,7) D D^DIQ S SRSDATE=Y
S SRHDR=" "_VADM(1)_" ("_VA("PID")_") Case #"_SRTN_" - "_SRSDATE
Q
END K ^TMP("SRNOR",$J)
W @IOF I $D(ZTQUEUED) Q:$G(ZTSTOP) S ZTREQ="@" Q
D ^SRSKILL K VAIN,VAINDT I $D(SRSITE("KILL")) K SRSITE
I $D(SRTN("KILL")) K SRTN
D ^%ZISC
Q
NON ; select patient and case
K DIC S DIC("A")="Select Patient: ",DIC=2,DIC(0)="QEAMZ" D ^DIC I Y<0 S SRSOUT=1 G END
S DFN=+Y D DEM^VADPT S SRNM=VADM(1)
W @IOF,!,"Non-O.R. Procedures for "_SRNM_" ("_VA("PID")_")" I $D(^DPT(DFN,.35)) S Y=$P(^(.35),"^") I Y D D^DIQ S Y=$P(Y,"@")_" "_$P(Y,"@",2) W !," (DIED ON "_Y_")"
W !! S (SRDT,CNT)=0 F S SRDT=$O(^SRF("ADT",DFN,SRDT)) Q:'SRDT!$D(SRTN) S SROP=0 F S SROP=$O(^SRF("ADT",DFN,SRDT,SROP)) Q:'SROP!$D(SRTN) I $P($G(^SRF(SROP,"NON")),"^")="Y" D LIST
SEL W !!!,"Select Procedure: " R X:DTIME I '$T!("^"[X) G END
I '$D(SRCASE(X)) W !!,"Enter the number corresponding to the procedure for which you want to print",!,"a report." G SEL
S SRTN=+SRCASE(X)
Q
LIST ; list case
I $Y+5>IOSL S SRBACK=0 D SEL^SROPER Q:$D(SRTN)!(SRSOUT) W @IOF,!,?1,"NON-O.R. PROCEDURES FOR "_VADM(1)_" ("_VA("PID")_")",! I SRBACK S CNT=0,SROP=SRCASE(1)-1,SRDT=$P(SRCASE(1),"^",2)
S CNT=CNT+1,SRSDATE=$P(^SRF(SROP,0),"^",9),SROPER=$P(^SRF(SROP,"OP"),"^"),SRCASE(CNT)=SROP
K SROPS,MM,MMM S:$L(SROPER)<55 SROPS(1)=SROPER I $L(SROPER)>54 S SROPER=SROPER_" " F M=1:1 D LOOP Q:MMM=""
S Y=SRSDATE D D^DIQ S SRSDATE=$P(Y,"@")_" "_$P(Y,"@",2)
W !,CNT_".",?4,SRSDATE,?20,SROPS(1) I $D(SROPS(2)) W !,?20,SROPS(2) I $D(SROPS(3)) W !,?20,SROPS(3) I $D(SROPS(4)) W !,?20,SROPS(4)
W !
Q
LOOP ; break procedure if greater than 55 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)'<55 S SROPS(M)=SROPS(M)_MM_" ",SROPER=MMM
Q
Q
HDR ; heading
I $D(ZTQUEUED) D ^SROSTOP I SRHALT S SRSOUT=1 Q
S SRPAGE=SRPAGE+1 I $Y'=0 W @IOF
W !,VADM(1)_" ("_VA("PID"),") Age: "_SRAGE,?(79-$L("PAGE "_SRPAGE)),"PAGE "_SRPAGE
W !,"NON-O.R. PROCEDURE - CASE #"_SRTN,?52,SRPRINT,!,SRLINE,!
Q
SRONPEN ;B'HAM ISC/ADM - NON-O.R. PROCEDURE REPORT ; [ 07/26/04 9:50 AM ]
+1 ;;3.0; Surgery ;**132**;24 Jun 93
+2 IF '$DATA(SRSITE)
DO ^SROVAR
IF '$DATA(SRSITE)
GOTO END
SET SRSITE("KILL")=1
+3 SET SRSOUT=0
IF '$DATA(SRTN)
DO NON
IF '$DATA(SRTN)
GOTO END
SET SRTN("KILL")=1
+4 IF $PIECE($GET(^SRF(SRTN,"NON")),"^")'="Y"
WRITE !!,?5,"The case selected is not a Non-OR Procedure.",!
DO FOOT
GOTO END
+5 NEW SRAGE,SRDIV,SRHDR,SRLOC,SRPRINT,SRSEL,SRSINED,SRDTITL
+6 SET SRDTITL="Procedure Report"
DISPLY KILL %ZIS,IO("Q")
SET %ZIS="Q"
DO ^%ZIS
IF POP
GOTO END
+1 IF $DATA(IO("Q"))
KILL IO("Q")
SET ZTDESC="Procedure Report"
SET ZTRTN="EN^SRONPEN"
SET (ZTSAVE("SRSITE("),ZTSAVE("SRTN"))=""
DO ^%ZTLOAD
GOTO END
EN DO OPTOP^SRONP2(SRTN)
SET DFN=$PIECE(^SRF(SRTN,0),"^")
SET VAINDT=$PIECE(^SRF(SRTN,0),"^",9)
+1 SET Y=$EXTRACT(VAINDT,1,7)
DO D^DIQ
SET SRSDATE=Y
DO OERR^VADPT
+2 SET SRHDR=" "_VADM(1)_" ("_VA("PID")_") Case #"_SRTN_" - "_SRSDATE
+3 SET Y=$EXTRACT($$NOW^XLFDT,1,12)
DO DD^%DT
SET SRPRINT="Printed: "_Y
+4 SET SRLOC=" Pt Loc: "_$PIECE(VAIN(4),"^",2)_" "_VAIN(5)
+5 SET SRAGE=""
SET Z=$PIECE(VADM(3),"^")
IF Z
SET X=$EXTRACT($PIECE(^SRF(SRTN,0),"^",9),1,12)
SET Y=$EXTRACT(X,1,7)
SET SRAGE=$EXTRACT(Y,1,3)-$EXTRACT(Z,1,3)-($EXTRACT(Y,4,7)<$EXTRACT(Z,4,7))
+6 SET SRDIV=$$SITE^SROUTL0(SRTN)
IF SRDIV
SET X=$PIECE(^SRO(133,SRDIV,0),"^")
SET SRDIV=$$EXTERNAL^DILFD(133,.01,"",X)
+7 SET SRDIV=$SELECT(SRDIV'="":SRDIV,1:SRSITE("SITE"))
+8 USE IO
SET (SRPAGE,SRSOUT)=0
SET $PIECE(SRLINE,"-",80)=""
DO HDR
+9 SET SRI=0
FOR
SET SRI=$ORDER(^TMP("SRNOR",$JOB,SRTN,SRI))
IF 'SRI
QUIT
Begin DoDot:1
+10 IF $EXTRACT(IOST)="P"
IF $Y+11>IOSL
DO FOOT
IF SRSOUT
QUIT
DO HDR
+11 IF $EXTRACT(IOST)'="P"
IF $Y+3>IOSL
DO FOOT
IF SRSOUT
QUIT
DO HDR
+12 WRITE !,^TMP("SRNOR",$JOB,SRTN,SRI)
End DoDot:1
IF SRSOUT
QUIT
+13 IF 'SRSOUT
DO FOOT
DO END
+14 QUIT
SRHDR SET DFN=$PIECE(^SRF(SRTN,0),"^")
DO DEM^VADPT
+1 SET Y=$EXTRACT($PIECE(^SRF(SRTN,0),"^",9),1,7)
DO D^DIQ
SET SRSDATE=Y
+2 SET SRHDR=" "_VADM(1)_" ("_VA("PID")_") Case #"_SRTN_" - "_SRSDATE
+3 QUIT
END KILL ^TMP("SRNOR",$JOB)
+1 WRITE @IOF
IF $DATA(ZTQUEUED)
IF $GET(ZTSTOP)
QUIT
SET ZTREQ="@"
QUIT
+2 DO ^SRSKILL
KILL VAIN,VAINDT
IF $DATA(SRSITE("KILL"))
KILL SRSITE
+3 IF $DATA(SRTN("KILL"))
KILL SRTN
+4 DO ^%ZISC
+5 QUIT
NON ; select patient and case
+1 KILL DIC
SET DIC("A")="Select Patient: "
SET DIC=2
SET DIC(0)="QEAMZ"
DO ^DIC
IF Y<0
SET SRSOUT=1
GOTO END
+2 SET DFN=+Y
DO DEM^VADPT
SET SRNM=VADM(1)
+3 WRITE @IOF,!,"Non-O.R. Procedures for "_SRNM_" ("_VA("PID")_")"
IF $DATA(^DPT(DFN,.35))
SET Y=$PIECE(^(.35),"^")
IF Y
DO D^DIQ
SET Y=$PIECE(Y,"@")_" "_$PIECE(Y,"@",2)
WRITE !," (DIED ON "_Y_")"
+4 WRITE !!
SET (SRDT,CNT)=0
FOR
SET SRDT=$ORDER(^SRF("ADT",DFN,SRDT))
IF 'SRDT!$DATA(SRTN)
QUIT
SET SROP=0
FOR
SET SROP=$ORDER(^SRF("ADT",DFN,SRDT,SROP))
IF 'SROP!$DATA(SRTN)
QUIT
IF $PIECE($GET(^SRF(SROP,"NON")),"^")="Y"
DO LIST
SEL WRITE !!!,"Select Procedure: "
READ X:DTIME
IF '$TEST!("^"[X)
GOTO END
+1 IF '$DATA(SRCASE(X))
WRITE !!,"Enter the number corresponding to the procedure for which you want to print",!,"a report."
GOTO SEL
+2 SET SRTN=+SRCASE(X)
+3 QUIT
LIST ; list case
+1 IF $Y+5>IOSL
SET SRBACK=0
DO SEL^SROPER
IF $DATA(SRTN)!(SRSOUT)
QUIT
WRITE @IOF,!,?1,"NON-O.R. PROCEDURES FOR "_VADM(1)_" ("_VA("PID")_")",!
IF SRBACK
SET CNT=0
SET SROP=SRCASE(1)-1
SET SRDT=$PIECE(SRCASE(1),"^",2)
+2 SET CNT=CNT+1
SET SRSDATE=$PIECE(^SRF(SROP,0),"^",9)
SET SROPER=$PIECE(^SRF(SROP,"OP"),"^")
SET SRCASE(CNT)=SROP
+3 KILL SROPS,MM,MMM
IF $LENGTH(SROPER)<55
SET SROPS(1)=SROPER
IF $LENGTH(SROPER)>54
SET SROPER=SROPER_" "
FOR M=1:1
DO LOOP
IF MMM=""
QUIT
+4 SET Y=SRSDATE
DO D^DIQ
SET SRSDATE=$PIECE(Y,"@")_" "_$PIECE(Y,"@",2)
+5 WRITE !,CNT_".",?4,SRSDATE,?20,SROPS(1)
IF $DATA(SROPS(2))
WRITE !,?20,SROPS(2)
IF $DATA(SROPS(3))
WRITE !,?20,SROPS(3)
IF $DATA(SROPS(4))
WRITE !,?20,SROPS(4)
+6 WRITE !
+7 QUIT
LOOP ; break procedure if greater than 55 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)'<55
QUIT
SET SROPS(M)=SROPS(M)_MM_" "
SET SROPER=MMM
+2 QUIT
WRITE !
KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
IF $DATA(DTOUT)!$DATA(DUOUT)
SET SRSOUT=1
+1 QUIT
HDR ; heading
+1 IF $DATA(ZTQUEUED)
DO ^SROSTOP
IF SRHALT
SET SRSOUT=1
QUIT
+2 SET SRPAGE=SRPAGE+1
IF $Y'=0
WRITE @IOF
+3 WRITE !,VADM(1)_" ("_VA("PID"),") Age: "_SRAGE,?(79-$LENGTH("PAGE "_SRPAGE)),"PAGE "_SRPAGE
+4 WRITE !,"NON-O.R. PROCEDURE - CASE #"_SRTN,?52,SRPRINT,!,SRLINE,!
+5 QUIT
