SRONOP ;B;HAM ISC/MAM - NON-O.R. PROCEDURES ; [ 01/30/01 1:07 PM ]
;;3.0;Surgery;**44,58,64,67,70,100,177**;24 Jun 93;Build 89
K SROEDIT S:$D(^XUSEC("SROEDIT",DUZ))&'$D(DUZ("SAV")) SROEDIT=1 S (SRNEWOP,SRSOUT)=0 W @IOF,!
K DIC S DIC("A")="Select Patient: ",DIC=2,DIC(0)="QEAMZ" D ^DIC K DIC I Y<0 S SRSOUT=1 G END
S DFN=+Y D DEM^VADPT S SRNM=VADM(1) D HDR
ADT S (SRBACK,SRDT,CNT)=0 F S SRDT=$O(^SRF("ADT",DFN,SRDT)) Q:'SRDT!SRSOUT!SRNEWOP!$D(SRTN)!SRBACK S SROP=0 F S SROP=$O(^SRF("ADT",DFN,SRDT,SROP)) Q:'SROP!$D(SRTN)!SRSOUT!SRNEWOP!SRBACK D LIST
G:SRBACK ADT G:$D(SRTN) ASK G:SRNEWOP ^SRONOP1 G:SRSOUT END
I $D(SROEDIT) S CNT=CNT+1,SRCASE(CNT)="" W !,CNT_".",?4,"NEW PROCEDURE"
SEL W !!,"Select Procedure: " R X:DTIME I '$T!("^"[X) S SRSOUT=1 G END
I $D(SROEDIT),X="NEW"!(X="new")!(X=CNT) G ^SRONOP1
I '$D(SRCASE(X)) W !!,"Enter the number corresponding to the procedure you want to edit." W:$D(SROEDIT) !,"Enter '"_CNT_"' or 'NEW' to create a new procedure" G SEL
S SRTN=SRCASE(X)
ASK S SROP=SRTN,SRSDATE=$P(^SRF(SRTN,0),"^",9) I $E(SRSDATE,1,7)>DT D FUTURE G:SRSOUT END I '$D(SRTN) D HDR G ADT
Q:'$D(SROEDIT) D HDR W !,?1 D CASE W !!,"Do you want to edit or delete this procedure ? "
W !!,"1. Edit",!,"2. Delete",!!,"Select Number: 1// " R X:DTIME I '$T!(X["^") S SRSOUT=1 G END
S:X="" X=1 I X<1!(X>2) W !!,"Enter '1' to edit information related to this procedure, or '2' to delete",!,"this procedure from your records.",!!,"Press RETURN to continue " R X:DTIME G ASK
I X=1 K SROEDIT Q
D DEL^SRONOP1
END I 'SRSOUT W !!,"Press RETURN to continue " R X:DTIME
D ^SRSKILL K SROEDIT,SRTN W @IOF
Q
EDIT ; edit procedure
Q:'$D(SRTN) I '$D(SRNM),$D(VADM(1)) S SRNM=VADM(1)
I '$D(SRNM) S DFN=$P(^SRF(SRTN,0),"^") D DEM^VADPT S SRNM=VADM(1)
D ^SROLOCK I SROLOCK S Q3("VIEW")=""
N SRLCK S SRLCK=$$LOCK^SROUTL(SRTN) I 'SRLCK S Q3("VIEW")=""
N SRICDV S SRICDV=$$ICDSTR^SROICD(SRTN)
D RT K DR S SRDTIME=DTIME,DTIME=3600,SRSOUT=1,ST="NON-O.R. PROCEDURE"_$S(SROLOCK:" **LOCKED",1:""),DIE=130,DR="[SRNON-OR]",DA=SRTN D EN2^SROVAR,^SRCUSS S DTIME=SRDTIME I 'SROLOCK D ^SROPCE1
S SROERR=SRTN D ^SROERR0
I $G(SRLCK) D UNLOCK^SROUTL(SRTN)
D ^SRSKILL
Q
LIST ; list case
Q:$P($G(^SRF(SROP,"NON")),"^")'="Y"
I $Y+5>IOSL S SRBACK=0 D CONT Q:$D(SRTN)!SRSOUT!SRNEWOP D HDR Q:SRBACK
S CNT=CNT+1,SRSDATE=$P(^SRF(SROP,0),"^",9) W !,CNT_". "
CASE S SROPER=$P(^SRF(SROP,"OP"),"^"),SRCASE(CNT)=SROP D LOCK
K SROPS,MM,MMM S:$L(SROPER)<60 SROPS(1)=SROPER I $L(SROPER)>59 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 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
LOCK ; case locked?
I $D(SRTN),$P($G(^SRF(SRTN,"LOCK")),"^") S SROPER=SROPER_" **LOCKED**"
Q
LOOP ; break procedure if greater than 60 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)'<60 S SROPS(M)=SROPS(M)_MM_" ",SROPER=MMM
Q
RT ; start RT logging
I $D(XRTL) S XRTN="SRONOP" D T0^%ZOSV
Q
CONT W ! K DIR S DIR("A")="Select procedure or press RETURN to continue listing procedures: ",DIR(0)="FOA"
S DIR("?",1)="Enter the number corresponding to the desired procedures"_$S($D(SROEDIT):", enter 'NEW' to",1:"")
S DIR("?")=$S($D(SROEDIT):"create a new procedure, ",1:"")_"or press RETURN to continue listing procedures." D ^DIR Q:Y="" I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 Q
I $D(SROEDIT),Y="NEW"!(Y="new") S SRNEWOP=1 Q
I Y'?.N!'$D(SRCASE(+Y)) S SRBACK=1 D
.W !!,"Enter the number corresponding to the procedure you want to edit.",!,"If the desired procedure does not appear, press RETURN to continue",!,"listing additional procedures"
.W:$D(SROEDIT) ", or enter 'NEW' to create a new procedure" W ".",!
I SRBACK K DIR S DIR("A")=" Press RETURN to continue. ",DIR("0")="FOA" D ^DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1
I 'SRBACK S SRTN=+SRCASE(Y)
Q
FUTURE D HDR W !,?1 D CASE W !,$C(7) K DIR
S DIR("A",1)=">>> The procedure you have selected has a future date.",DIR("A")=" Are you sure you have selected the correct procedure ? ",DIR("B")="NO",DIR(0)="YA" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 Q
I 'Y K SRTN
Q
HDR ; print heading
W @IOF,!,?1,VADM(1)_" "_VA("PID") S X=$P($G(VADM(6)),"^") W:X " * Died "_$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3)_" *" W !
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSRONOP 4429 printed Oct 16, 2024@18:44:58 Page 2
SRONOP ;B;HAM ISC/MAM - NON-O.R. PROCEDURES ; [ 01/30/01 1:07 PM ]
+1 ;;3.0;Surgery;**44,58,64,67,70,100,177**;24 Jun 93;Build 89
+2 KILL SROEDIT
if $DATA(^XUSEC("SROEDIT",DUZ))&'$DATA(DUZ("SAV"))
SET SROEDIT=1
SET (SRNEWOP,SRSOUT)=0
WRITE @IOF,!
+3 KILL DIC
SET DIC("A")="Select Patient: "
SET DIC=2
SET DIC(0)="QEAMZ"
DO ^DIC
KILL DIC
IF Y<0
SET SRSOUT=1
GOTO END
+4 SET DFN=+Y
DO DEM^VADPT
SET SRNM=VADM(1)
DO HDR
ADT SET (SRBACK,SRDT,CNT)=0
FOR
SET SRDT=$ORDER(^SRF("ADT",DFN,SRDT))
if 'SRDT!SRSOUT!SRNEWOP!$DATA(SRTN)!SRBACK
QUIT
SET SROP=0
FOR
SET SROP=$ORDER(^SRF("ADT",DFN,SRDT,SROP))
if 'SROP!$DATA(SRTN)!SRSOUT!SRNEWOP!SRBACK
QUIT
DO LIST
+1 if SRBACK
GOTO ADT
if $DATA(SRTN)
GOTO ASK
if SRNEWOP
GOTO ^SRONOP1
if SRSOUT
GOTO END
+2 IF $DATA(SROEDIT)
SET CNT=CNT+1
SET SRCASE(CNT)=""
WRITE !,CNT_".",?4,"NEW PROCEDURE"
SEL WRITE !!,"Select Procedure: "
READ X:DTIME
IF '$TEST!("^"[X)
SET SRSOUT=1
GOTO END
+1 IF $DATA(SROEDIT)
IF X="NEW"!(X="new")!(X=CNT)
GOTO ^SRONOP1
+2 IF '$DATA(SRCASE(X))
WRITE !!,"Enter the number corresponding to the procedure you want to edit."
if $DATA(SROEDIT)
WRITE !,"Enter '"_CNT_"' or 'NEW' to create a new procedure"
GOTO SEL
+3 SET SRTN=SRCASE(X)
ASK SET SROP=SRTN
SET SRSDATE=$PIECE(^SRF(SRTN,0),"^",9)
IF $EXTRACT(SRSDATE,1,7)>DT
DO FUTURE
if SRSOUT
GOTO END
IF '$DATA(SRTN)
DO HDR
GOTO ADT
+1 if '$DATA(SROEDIT)
QUIT
DO HDR
WRITE !,?1
DO CASE
WRITE !!,"Do you want to edit or delete this procedure ? "
+2 WRITE !!,"1. Edit",!,"2. Delete",!!,"Select Number: 1// "
READ X:DTIME
IF '$TEST!(X["^")
SET SRSOUT=1
GOTO END
+3 if X=""
SET X=1
IF X<1!(X>2)
WRITE !!,"Enter '1' to edit information related to this procedure, or '2' to delete",!,"this procedure from your records.",!!,"Press RETURN to continue "
READ X:DTIME
GOTO ASK
+4 IF X=1
KILL SROEDIT
QUIT
+5 DO DEL^SRONOP1
END IF 'SRSOUT
WRITE !!,"Press RETURN to continue "
READ X:DTIME
+1 DO ^SRSKILL
KILL SROEDIT,SRTN
WRITE @IOF
+2 QUIT
EDIT ; edit procedure
+1 if '$DATA(SRTN)
QUIT
IF '$DATA(SRNM)
IF $DATA(VADM(1))
SET SRNM=VADM(1)
+2 IF '$DATA(SRNM)
SET DFN=$PIECE(^SRF(SRTN,0),"^")
DO DEM^VADPT
SET SRNM=VADM(1)
+3 DO ^SROLOCK
IF SROLOCK
SET Q3("VIEW")=""
+4 NEW SRLCK
SET SRLCK=$$LOCK^SROUTL(SRTN)
IF 'SRLCK
SET Q3("VIEW")=""
+5 NEW SRICDV
SET SRICDV=$$ICDSTR^SROICD(SRTN)
+6 DO RT
KILL DR
SET SRDTIME=DTIME
SET DTIME=3600
SET SRSOUT=1
SET ST="NON-O.R. PROCEDURE"_$SELECT(SROLOCK:" **LOCKED",1:"")
SET DIE=130
SET DR="[SRNON-OR]"
SET DA=SRTN
DO EN2^SROVAR
DO ^SRCUSS
SET DTIME=SRDTIME
IF 'SROLOCK
DO ^SROPCE1
+7 SET SROERR=SRTN
DO ^SROERR0
+8 IF $GET(SRLCK)
DO UNLOCK^SROUTL(SRTN)
+9 DO ^SRSKILL
+10 QUIT
LIST ; list case
+1 if $PIECE($GET(^SRF(SROP,"NON")),"^")'="Y"
QUIT
+2 IF $Y+5>IOSL
SET SRBACK=0
DO CONT
if $DATA(SRTN)!SRSOUT!SRNEWOP
QUIT
DO HDR
if SRBACK
QUIT
+3 SET CNT=CNT+1
SET SRSDATE=$PIECE(^SRF(SROP,0),"^",9)
WRITE !,CNT_". "
CASE SET SROPER=$PIECE(^SRF(SROP,"OP"),"^")
SET SRCASE(CNT)=SROP
DO LOCK
+1 KILL SROPS,MM,MMM
if $LENGTH(SROPER)<60
SET SROPS(1)=SROPER
IF $LENGTH(SROPER)>59
SET SROPER=SROPER_" "
FOR M=1:1
DO LOOP
if MMM=""
QUIT
+2 SET Y=SRSDATE
DO D^DIQ
SET SRSDATE=$PIECE(Y,"@")_" "_$PIECE(Y,"@",2)
+3 WRITE 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)
+4 WRITE !
+5 QUIT
LOCK ; case locked?
+1 IF $DATA(SRTN)
IF $PIECE($GET(^SRF(SRTN,"LOCK")),"^")
SET SROPER=SROPER_" **LOCKED**"
+2 QUIT
LOOP ; break procedure if greater than 60 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)'<60
QUIT
SET SROPS(M)=SROPS(M)_MM_" "
SET SROPER=MMM
+2 QUIT
RT ; start RT logging
+1 IF $DATA(XRTL)
SET XRTN="SRONOP"
DO T0^%ZOSV
+2 QUIT
CONT WRITE !
KILL DIR
SET DIR("A")="Select procedure or press RETURN to continue listing procedures: "
SET DIR(0)="FOA"
+1 SET DIR("?",1)="Enter the number corresponding to the desired procedures"_$SELECT($DATA(SROEDIT):", enter 'NEW' to",1:"")
+2 SET DIR("?")=$SELECT($DATA(SROEDIT):"create a new procedure, ",1:"")_"or press RETURN to continue listing procedures."
DO ^DIR
if Y=""
QUIT
IF $DATA(DTOUT)!$DATA(DUOUT)
SET SRSOUT=1
QUIT
+3 IF $DATA(SROEDIT)
IF Y="NEW"!(Y="new")
SET SRNEWOP=1
QUIT
+4 IF Y'?.N!'$DATA(SRCASE(+Y))
SET SRBACK=1
Begin DoDot:1
+5 WRITE !!,"Enter the number corresponding to the procedure you want to edit.",!,"If the desired procedure does not appear, press RETURN to continue",!,"listing additional procedures"
+6 if $DATA(SROEDIT)
WRITE ", or enter 'NEW' to create a new procedure"
WRITE ".",!
End DoDot:1
+7 IF SRBACK
KILL DIR
SET DIR("A")=" Press RETURN to continue. "
SET DIR("0")="FOA"
DO ^DIR
IF $DATA(DTOUT)!$DATA(DUOUT)
SET SRSOUT=1
+8 IF 'SRBACK
SET SRTN=+SRCASE(Y)
+9 QUIT
FUTURE DO HDR
WRITE !,?1
DO CASE
WRITE !,$CHAR(7)
KILL DIR
+1 SET DIR("A",1)=">>> The procedure you have selected has a future date."
SET DIR("A")=" Are you sure you have selected the correct procedure ? "
SET DIR("B")="NO"
SET DIR(0)="YA"
DO ^DIR
KILL DIR
IF $DATA(DTOUT)!$DATA(DUOUT)
SET SRSOUT=1
QUIT
+2 IF 'Y
KILL SRTN
+3 QUIT
HDR ; print heading
+1 WRITE @IOF,!,?1,VADM(1)_" "_VA("PID")
SET X=$PIECE($GET(VADM(6)),"^")
if X
WRITE " * Died "_$EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)_"/"_$EXTRACT(X,2,3)_" *"
WRITE !
+2 QUIT
