SRONPEN.m

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

FOOT I $E(IOST)'="P" W ! K DIR S DIR(0)="E" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1

 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

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---SRONPEN   3738     printed  Mar 13, 2025@21:49:44                                                                                                                                                                                                     Page 2

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 

FOOT       IF $EXTRACT(IOST)'="P"

               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