SROVAR ;BIR/MAM,ADM - SITE PARAMETERS ;10/04/05
;;3.0; Surgery ;**17,38,48,67,77,50,87,88,102,107,100,134,144,157**;24 Jun 93;Build 3
;
; Reference to ^TMP("CSLSUR1" supported by DBIA #3498
;
K ^TMP("CSLSUR1",$J),^TMP("SRPFSS",$J) D CLEAR
I $D(SRSITE) Q
D CPT
K SRL S (SRCNT,X)=0 F S X=$O(^SRO(133,X)) Q:'X I '$P($G(^SRO(133,X,0)),"^",21) S SRCNT=SRCNT+1,SRL(SRCNT)=X
I SRCNT=1 S SRSITE=SRL(1) G SET
K XQUIT,DIR W ! I SRCNT>1 S DIR("?",1)=" Because there is more than one division in the SURGERY SITE PARAMETERS",DIR("?")=" file, a division must be selected."
S DIR(0)="P^133:EM",DIR("A")="Select Division",DIR("S")="I '$P(^SRO(133,+Y,0),U,21)" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) D ^SRSKILL S XQUIT="" Q
S SRSITE=+Y
SET ; set site parameters
S S(0)=^SRO(133,SRSITE,0),SRSITE("AML")=$P(S(0),"^",4),SRSITE("REQ")=$P(S(0),"^",2) K:SRSITE("REQ")="" SRSITE("REQ")
S SRSITE("IV")=$P(S(0),"^",7) K:SRSITE("IV")="" SRSITE("IV")
S SRSITE("DIV")=$P(S(0),"^"),SRSITE("SITE")=$$GET1^DIQ(4,SRSITE("DIV"),.01)
S SRSITE("NRPT")=$P(S(0),"^",6) I SRSITE("NRPT")="" S SRSITE("NRPT")=1
I '$D(SRSITE("OPTION")),$D(XQY) S SRSITE("OPTION")=XQY
K S
Q
CPT ; display CPT copyright notice
N SRCPT,SRDIV S (SRCPT,SRDIV)=0 F S SRDIV=$O(^SRO(133,SRDIV)) Q:'SRDIV I $D(^SRO(133,SRDIV,6,DT,1,DUZ)) S SRCPT=1 Q
Q:SRCPT D COPY^ICPTAPIU I $G(IOST)'["P-" W ! K DIR S DIR("A")="Press the 'Return' key to continue",DIR(0)="FOA" D ^DIR K DIR
K DD,DO,DA,DIC S SRDIV=$O(^SRO(133,0))
I '$D(^SRO(133,SRDIV,6,DT,0)) S X=DT,DA(1)=SRDIV,DIC="^SRO(133,SRDIV,6,",DIC("P")=$P(^DD(133,36,0),"^",2),DIC(0)="L",DINUM=X D FILE^DICN K DD,DO,DA,DIC I Y=-1 Q
S X=DUZ,DA(2)=SRDIV,DA(1)=DT,DIC="^SRO(133,SRDIV,6,DT,1,",DIC("P")=$P(^DD(133.036,1,0),"^",2),DIC(0)="L",DINUM=X D FILE^DICN K DA,DD,DIC,DO
Q
EN2 ; set view only and titles for screens
I '$D(^XUSEC("SROEDIT",DUZ)) S Q3("VIEW")=""
Q:'$D(SRTN) Q:SRTN<1 S:'$D(ST) ST="SCHEDULING" S DFN=$P(^SRF(SRTN,0),"^") D DEM^VADPT S SRN=$E(VADM(1),1,20),Q3(1)="** "_ST_" ** CASE #"_SRTN_" "_SRN_" "
Q
DEV S SRION=$S($D(ION):ION,1:"HOME") K %ZIS S %ZIS="QN",IOP=X D ^%ZIS I POP S IOP=SRION D ^%ZIS K %ZIS,IOP,SRION,X Q
W $S(X=$E(ION,1,$L(X)):$E(ION,$L(X)+1,$L(ION)),1:" "_ION) S X=ION D ^%ZISC K %ZIS,SRION,IOP Q
Q
TIME ; transform time to date of operation at that time
I $D(SRSMED) S DA=SRTN
S:$D(SRTN) SRTDA=DA,DA=SRTN S X=$S(X?1.4N.A!(X?1.2N1":"2N.A):Z_"@"_X,1:X)
S %DT="EPTXR" D ^%DT S X=Y G:'$D(^SRF(DA,.2)) RESET I X>0 S SRSTART=$P(^SRF($S($D(SRTN):SRTN,1:DA),.2),"^",15) I SRSTART'="" D BEFORE
S:$D(SRTDA) DA=SRTDA Q
BEFORE W:X<SRSTART !!,"The time entered is before the 'TIME PAT IN HOLD AREA'. Please check the",!,"DATE/TIME entered for this field." H 2
Q
RESET S:$D(SRTDA) DA=SRTDA Q
INPUT ; input transfor for ASA CLASS
S:'$D(DA) DA=SRTN S SRFLD=1.13 I $D(^SRF(DA,"CON")),$P(^("CON"),"^") D ^SROCON Q
Q
PARAM ; enter/edit site parameters
W @IOF K DIC,DINUM S DIC=133,DIC(0)="QEAMZL",DLAYGO=133,DIC("A")="Edit Parameters for which Surgery Site: " D ^DIC K DIC I Y<0 W @IOF Q
N SRDIV,SRN,SRNAME,SRNUM S SRDIV=+Y,SRN=+Y(0),SRNAME=Y(0,0),SRNUM=$$GET1^DIQ(4,SRN,99),Q3(1)=" "_SRNAME_" ("_SRNUM_") "
K DIE,DR,DA,Y S DA=SRDIV,DR="[SRPARAM]",DIE=133 D ^SRCUSS K DR,DIE,DA,ST W @IOF I $D(SRSITE) D SET
Q
EXIT ; exit action for all Surgery options
I $D(XQY),$G(SRSITE("OPTION"))=XQY K SRSITE,SRTN,^TMP("SRCUSS",$J)
D CLEAR
Q
SITE() ; extrinsic call to output Institution file pointer (from Default Institution field in file 4.3)^Institution name^Station number
N SITE,SRI,SRX,SRY
S SITE=$$KSP^XUPARAM("INST") I 'SITE Q SITE
S SRX=SITE F SRI=.01,99 S SRY=$$GET1^DIQ(4,SRX,SRI),SITE=SITE_"^"_SRY
Q SITE
OFF1 ; compare time off with time on
S Z=$E($P(^SRF($S($D(SRTN):SRTN,1:DA(1)),0),"^",9),1,7),X=$S(X?1.4N.A!(X?1.2N1":"2N.A):Z_"@"_X,1:X) K %DT,Z S %DT="PTXR" D ^%DT S X=Y I Y<1 D OUT Q
S SRSTART=$P(^SRF(DA(1),SRSUB,DA,0),"^",SRP) D COMP
Q
OFF2 ; compare time off with time on
S Z=$E($P(^SRF($S($D(SRTN):SRTN,1:DA(2)),0),"^",9),1,7),X=$S(X?1.4N.A!(X?1.2N1":"2N.A):Z_"@"_X,1:X) K %DT,Z S %DT="PTXR" D ^%DT S X=Y I Y<1 D OUT Q
S SRSTART=$P(^SRF(DA(2),SRSUB,DA(1),1,DA,0),"^",SRP)
COMP I X<SRSTART W !!,"Time Off should be later than Time On.",! S X=-1
OUT K %DT,SR130,SRN,SRP,SRSTART,SRSUB
Q
TERM ; compare stop time with start time
N SRINOR,SRSTART,SRV,SRY,T,Z
I $D(DA) S SRINOR=$S($P($G(^SRF(DA,"NON")),"^")="Y":$P($G(^SRF(DA,"NON")),"^",4),1:$P($G(^SRF(DA,.2)),"^",10)) I 'SRINOR D K X D OUT Q
.D EN^DDIOL(">>> Please enter 'TIME "_$S($P($G(^SRF(DA,"NON")),"^")="Y":"PROCEDURE BEGAN",1:"PAT IN OR")_"' first !! <<<","","!!?5")
.D EN^DDIOL("","","!")
S Z=$E(SRINOR,1,7),X=$S(X?1.4N.A!(X?1.2N1":"2N.A):Z_"@"_X,1:X)
K %DT,Z S %DT="PTXR" D ^%DT S X=Y I Y<1 D OUT Q
I $D(DA) S Z=$P($G(^SRF(DA,SRN)),"^",SRP),SRSTART=$S(Z:Z,1:SRINOR),SRNULL=$S(Z:0,1:1) I X<SRSTART S Z=$P(SRINOR,"."),T=$P(X,".",2),X1=Z_"."_T,X2=1 D C^%DTC D PLUS24 I '$D(X) D OUT Q
K %DT S %DT="EPTXR" D ^%DT S X=Y D OUT
Q
PLUS24 S:SRNULL SR130="TIME PAT IN OR" S (SRV,Y)=X X ^DD("DD") S SRY=Y
K DIR S DIR("A",1)="",DIR("A",2)="The time you have entered is earlier than "_SR130_".",DIR("A")="Do you mean "_SRY_" (Y/N) ? ",DIR(0)="YA" D ^DIR K DIR I 'Y!$D(DTOUT)!$D(DUOUT) K X Q
S X=SRV
Q
CLEAR ; clean-up case edit/lock flags in ^XTMP
N SRC,SRJ,SRL,SRNOW,SRNOW1,SRZ S SRNOW=$$NOW^XLFDT
S SRC="SRLOCK-0" F S SRC=$O(^XTMP(SRC)) Q:SRC'["SRLOCK-" D
.S SRJ=0 F S SRJ=$O(^XTMP(SRC,DUZ,SRJ)) Q:'SRJ D
..I SRJ=$J L -^XTMP(SRC,DUZ,SRJ) K ^XTMP(SRC,DUZ,SRJ) I '$O(^XTMP(SRC,0)) L -^XTMP(SRC) K ^XTMP(SRC) Q
..S SRNOW1=$P($G(^XTMP(SRC,0)),"^") I SRNOW>SRNOW1 L -^XTMP(SRC) K ^XTMP(SRC)
Q
EN3 ; the Sterility Expiration Date should be after the Date of Operation
S:$D(SRTN) SRTDA=DA,DA=SRTN S X=$S(X?1.4N.A!(X?1.2N1":"2N.A):Z_"@"_X,1:X)
S %DT="E" D ^%DT S X=Y I X>0 S SRSTART=$E($P(^SRF($S($D(SRTN):SRTN,1:D0),0),U,9),1,7) I SRSTART'="" D BEF
S:$D(SRTDA) DA=SRTDA Q
BEF I X<SRSTART W !!,"The date entered is before the 'DATE OF OPERATION'. Please check the",!,"DATE entered for this field." K X H 2
Q
SROVAR ;BIR/MAM,ADM - SITE PARAMETERS ;10/04/05
+1 ;;3.0; Surgery ;**17,38,48,67,77,50,87,88,102,107,100,134,144,157**;24 Jun 93;Build 3
+2 ;
+3 ; Reference to ^TMP("CSLSUR1" supported by DBIA #3498
+4 ;
+5 KILL ^TMP("CSLSUR1",$JOB),^TMP("SRPFSS",$JOB)
DO CLEAR
+6 IF $DATA(SRSITE)
QUIT
+7 DO CPT
+8 KILL SRL
SET (SRCNT,X)=0
FOR
SET X=$ORDER(^SRO(133,X))
IF 'X
QUIT
IF '$PIECE($GET(^SRO(133,X,0)),"^",21)
SET SRCNT=SRCNT+1
SET SRL(SRCNT)=X
+9 IF SRCNT=1
SET SRSITE=SRL(1)
GOTO SET
+10 KILL XQUIT,DIR
WRITE !
IF SRCNT>1
SET DIR("?",1)=" Because there is more than one division in the SURGERY SITE PARAMETERS"
SET DIR("?")=" file, a division must be selected."
+11 SET DIR(0)="P^133:EM"
SET DIR("A")="Select Division"
SET DIR("S")="I '$P(^SRO(133,+Y,0),U,21)"
DO ^DIR
KILL DIR
IF $DATA(DTOUT)!$DATA(DUOUT)
DO ^SRSKILL
SET XQUIT=""
QUIT
+12 SET SRSITE=+Y
SET ; set site parameters
+1 SET S(0)=^SRO(133,SRSITE,0)
SET SRSITE("AML")=$PIECE(S(0),"^",4)
SET SRSITE("REQ")=$PIECE(S(0),"^",2)
IF SRSITE("REQ")=""
KILL SRSITE("REQ")
+2 SET SRSITE("IV")=$PIECE(S(0),"^",7)
IF SRSITE("IV")=""
KILL SRSITE("IV")
+3 SET SRSITE("DIV")=$PIECE(S(0),"^")
SET SRSITE("SITE")=$$GET1^DIQ(4,SRSITE("DIV"),.01)
+4 SET SRSITE("NRPT")=$PIECE(S(0),"^",6)
IF SRSITE("NRPT")=""
SET SRSITE("NRPT")=1
+5 IF '$DATA(SRSITE("OPTION"))
IF $DATA(XQY)
SET SRSITE("OPTION")=XQY
+6 KILL S
+7 QUIT
CPT ; display CPT copyright notice
+1 NEW SRCPT,SRDIV
SET (SRCPT,SRDIV)=0
FOR
SET SRDIV=$ORDER(^SRO(133,SRDIV))
IF 'SRDIV
QUIT
IF $DATA(^SRO(133,SRDIV,6,DT,1,DUZ))
SET SRCPT=1
QUIT
+2 IF SRCPT
QUIT
DO COPY^ICPTAPIU
IF $GET(IOST)'["P-"
WRITE !
KILL DIR
SET DIR("A")="Press the 'Return' key to continue"
SET DIR(0)="FOA"
DO ^DIR
KILL DIR
+3 KILL DD,DO,DA,DIC
SET SRDIV=$ORDER(^SRO(133,0))
+4 IF '$DATA(^SRO(133,SRDIV,6,DT,0))
SET X=DT
SET DA(1)=SRDIV
SET DIC="^SRO(133,SRDIV,6,"
SET DIC("P")=$PIECE(^DD(133,36,0),"^",2)
SET DIC(0)="L"
SET DINUM=X
DO FILE^DICN
KILL DD,DO,DA,DIC
IF Y=-1
QUIT
+5 SET X=DUZ
SET DA(2)=SRDIV
SET DA(1)=DT
SET DIC="^SRO(133,SRDIV,6,DT,1,"
SET DIC("P")=$PIECE(^DD(133.036,1,0),"^",2)
SET DIC(0)="L"
SET DINUM=X
DO FILE^DICN
KILL DA,DD,DIC,DO
+6 QUIT
EN2 ; set view only and titles for screens
+1 IF '$DATA(^XUSEC("SROEDIT",DUZ))
SET Q3("VIEW")=""
+2 IF '$DATA(SRTN)
QUIT
IF SRTN<1
QUIT
IF '$DATA(ST)
SET ST="SCHEDULING"
SET DFN=$PIECE(^SRF(SRTN,0),"^")
DO DEM^VADPT
SET SRN=$EXTRACT(VADM(1),1,20)
SET Q3(1)="** "_ST_" ** CASE #"_SRTN_" "_SRN_" "
+3 QUIT
DEV SET SRION=$SELECT($DATA(ION):ION,1:"HOME")
KILL %ZIS
SET %ZIS="QN"
SET IOP=X
DO ^%ZIS
IF POP
SET IOP=SRION
DO ^%ZIS
KILL %ZIS,IOP,SRION,X
QUIT
+1 WRITE $SELECT(X=$EXTRACT(ION,1,$LENGTH(X)):$EXTRACT(ION,$LENGTH(X)+1,$LENGTH(ION)),1:" "_ION)
SET X=ION
DO ^%ZISC
KILL %ZIS,SRION,IOP
QUIT
+2 QUIT
TIME ; transform time to date of operation at that time
+1 IF $DATA(SRSMED)
SET DA=SRTN
+2 IF $DATA(SRTN)
SET SRTDA=DA
SET DA=SRTN
SET X=$SELECT(X?1.4N.A!(X?1.2N1":"2N.A):Z_"@"_X,1:X)
+3 SET %DT="EPTXR"
DO ^%DT
SET X=Y
IF '$DATA(^SRF(DA,.2))
GOTO RESET
IF X>0
SET SRSTART=$PIECE(^SRF($SELECT($DATA(SRTN):SRTN,1:DA),.2),"^",15)
IF SRSTART'=""
DO BEFORE
+4 IF $DATA(SRTDA)
SET DA=SRTDA
QUIT
BEFORE IF X<SRSTART
WRITE !!,"The time entered is before the 'TIME PAT IN HOLD AREA'. Please check the",!,"DATE/TIME entered for this field."
HANG 2
+1 QUIT
RESET IF $DATA(SRTDA)
SET DA=SRTDA
QUIT
INPUT ; input transfor for ASA CLASS
+1 IF '$DATA(DA)
SET DA=SRTN
SET SRFLD=1.13
IF $DATA(^SRF(DA,"CON"))
IF $PIECE(^("CON"),"^")
DO ^SROCON
QUIT
+2 QUIT
PARAM ; enter/edit site parameters
+1 WRITE @IOF
KILL DIC,DINUM
SET DIC=133
SET DIC(0)="QEAMZL"
SET DLAYGO=133
SET DIC("A")="Edit Parameters for which Surgery Site: "
DO ^DIC
KILL DIC
IF Y<0
WRITE @IOF
QUIT
+2 NEW SRDIV,SRN,SRNAME,SRNUM
SET SRDIV=+Y
SET SRN=+Y(0)
SET SRNAME=Y(0,0)
SET SRNUM=$$GET1^DIQ(4,SRN,99)
SET Q3(1)=" "_SRNAME_" ("_SRNUM_") "
+3 KILL DIE,DR,DA,Y
SET DA=SRDIV
SET DR="[SRPARAM]"
SET DIE=133
DO ^SRCUSS
KILL DR,DIE,DA,ST
WRITE @IOF
IF $DATA(SRSITE)
DO SET
+4 QUIT
EXIT ; exit action for all Surgery options
+1 IF $DATA(XQY)
IF $GET(SRSITE("OPTION"))=XQY
KILL SRSITE,SRTN,^TMP("SRCUSS",$JOB)
+2 DO CLEAR
+3 QUIT
SITE() ; extrinsic call to output Institution file pointer (from Default Institution field in file 4.3)^Institution name^Station number
+1 NEW SITE,SRI,SRX,SRY
+2 SET SITE=$$KSP^XUPARAM("INST")
IF 'SITE
QUIT SITE
+3 SET SRX=SITE
FOR SRI=.01,99
SET SRY=$$GET1^DIQ(4,SRX,SRI)
SET SITE=SITE_"^"_SRY
+4 QUIT SITE
OFF1 ; compare time off with time on
+1 SET Z=$EXTRACT($PIECE(^SRF($SELECT($DATA(SRTN):SRTN,1:DA(1)),0),"^",9),1,7)
SET X=$SELECT(X?1.4N.A!(X?1.2N1":"2N.A):Z_"@"_X,1:X)
KILL %DT,Z
SET %DT="PTXR"
DO ^%DT
SET X=Y
IF Y<1
DO OUT
QUIT
+2 SET SRSTART=$PIECE(^SRF(DA(1),SRSUB,DA,0),"^",SRP)
DO COMP
+3 QUIT
OFF2 ; compare time off with time on
+1 SET Z=$EXTRACT($PIECE(^SRF($SELECT($DATA(SRTN):SRTN,1:DA(2)),0),"^",9),1,7)
SET X=$SELECT(X?1.4N.A!(X?1.2N1":"2N.A):Z_"@"_X,1:X)
KILL %DT,Z
SET %DT="PTXR"
DO ^%DT
SET X=Y
IF Y<1
DO OUT
QUIT
+2 SET SRSTART=$PIECE(^SRF(DA(2),SRSUB,DA(1),1,DA,0),"^",SRP)
COMP IF X<SRSTART
WRITE !!,"Time Off should be later than Time On.",!
SET X=-1
OUT KILL %DT,SR130,SRN,SRP,SRSTART,SRSUB
+1 QUIT
TERM ; compare stop time with start time
+1 NEW SRINOR,SRSTART,SRV,SRY,T,Z
+2 IF $DATA(DA)
SET SRINOR=$SELECT($PIECE($GET(^SRF(DA,"NON")),"^")="Y":$PIECE($GET(^SRF(DA,"NON")),"^",4),1:$PIECE($GET(^SRF(DA,.2)),"^",10))
IF 'SRINOR
Begin DoDot:1
+3 DO EN^DDIOL(">>> Please enter 'TIME "_$SELECT($PIECE($GET(^SRF(DA,"NON")),"^")="Y":"PROCEDURE BEGAN",1:"PAT IN OR")_"' first !! <<<","","!!?5")
+4 DO EN^DDIOL("","","!")
End DoDot:1
KILL X
DO OUT
QUIT
+5 SET Z=$EXTRACT(SRINOR,1,7)
SET X=$SELECT(X?1.4N.A!(X?1.2N1":"2N.A):Z_"@"_X,1:X)
+6 KILL %DT,Z
SET %DT="PTXR"
DO ^%DT
SET X=Y
IF Y<1
DO OUT
QUIT
+7 IF $DATA(DA)
SET Z=$PIECE($GET(^SRF(DA,SRN)),"^",SRP)
SET SRSTART=$SELECT(Z:Z,1:SRINOR)
SET SRNULL=$SELECT(Z:0,1:1)
IF X<SRSTART
SET Z=$PIECE(SRINOR,".")
SET T=$PIECE(X,".",2)
SET X1=Z_"."_T
SET X2=1
DO C^%DTC
DO PLUS24
IF '$DATA(X)
DO OUT
QUIT
+8 KILL %DT
SET %DT="EPTXR"
DO ^%DT
SET X=Y
DO OUT
+9 QUIT
PLUS24 IF SRNULL
SET SR130="TIME PAT IN OR"
SET (SRV,Y)=X
XECUTE ^DD("DD")
SET SRY=Y
+1 KILL DIR
SET DIR("A",1)=""
SET DIR("A",2)="The time you have entered is earlier than "_SR130_"."
SET DIR("A")="Do you mean "_SRY_" (Y/N) ? "
SET DIR(0)="YA"
DO ^DIR
KILL DIR
IF 'Y!$DATA(DTOUT)!$DATA(DUOUT)
KILL X
QUIT
+2 SET X=SRV
+3 QUIT
CLEAR ; clean-up case edit/lock flags in ^XTMP
+1 NEW SRC,SRJ,SRL,SRNOW,SRNOW1,SRZ
SET SRNOW=$$NOW^XLFDT
+2 SET SRC="SRLOCK-0"
FOR
SET SRC=$ORDER(^XTMP(SRC))
IF SRC'["SRLOCK-"
QUIT
Begin DoDot:1
+3 SET SRJ=0
FOR
SET SRJ=$ORDER(^XTMP(SRC,DUZ,SRJ))
IF 'SRJ
QUIT
Begin DoDot:2
+4 IF SRJ=$JOB
LOCK -^XTMP(SRC,DUZ,SRJ)
KILL ^XTMP(SRC,DUZ,SRJ)
IF '$ORDER(^XTMP(SRC,0))
LOCK -^XTMP(SRC)
KILL ^XTMP(SRC)
QUIT
+5 SET SRNOW1=$PIECE($GET(^XTMP(SRC,0)),"^")
IF SRNOW>SRNOW1
LOCK -^XTMP(SRC)
KILL ^XTMP(SRC)
End DoDot:2
End DoDot:1
+6 QUIT
EN3 ; the Sterility Expiration Date should be after the Date of Operation
+1 IF $DATA(SRTN)
SET SRTDA=DA
SET DA=SRTN
SET X=$SELECT(X?1.4N.A!(X?1.2N1":"2N.A):Z_"@"_X,1:X)
+2 SET %DT="E"
DO ^%DT
SET X=Y
IF X>0
SET SRSTART=$EXTRACT($PIECE(^SRF($SELECT($DATA(SRTN):SRTN,1:D0),0),U,9),1,7)
IF SRSTART'=""
DO BEF
+3 IF $DATA(SRTDA)
SET DA=SRTDA
QUIT
BEF IF X<SRSTART
WRITE !!,"The date entered is before the 'DATE OF OPERATION'. Please check the",!,"DATE entered for this field."
KILL X
HANG 2
+1 QUIT
