- SROVAR ;BIR/MAM,ADM - SITE PARAMETERS ; 7/21/09 1:37pm
- ;;3.0;Surgery;**17,38,48,67,77,50,87,88,102,107,100,134,144,157,171,187**;24 Jun 93;Build 4
- ;
- ; 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 X=SITE,DIC="^SRO(133,",DIC(0)="UBZ" D ^DIC Q:Y<0 ""
- S SRX=+Y I $P($G(^SRO(133,SRX,0)),U,21) S SITE="" D I 'SITE Q SITE
- .S SRX=0 F S SRX=$O(^SRO(133,SRX)) Q:SRX'>0 I $D(^(SRX,0)),'$P(^(0),U,21) S SITE=$P(^(0),U) Q
- 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
- N 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSROVAR 6372 printed Jan 18, 2025@03:47:42 Page 2
- SROVAR ;BIR/MAM,ADM - SITE PARAMETERS ; 7/21/09 1:37pm
- +1 ;;3.0;Surgery;**17,38,48,67,77,50,87,88,102,107,100,134,144,157,171,187**;24 Jun 93;Build 4
- +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 X=SITE
- SET DIC="^SRO(133,"
- SET DIC(0)="UBZ"
- DO ^DIC
- if Y<0
- QUIT ""
- +4 SET SRX=+Y
- IF $PIECE($GET(^SRO(133,SRX,0)),U,21)
- SET SITE=""
- Begin DoDot:1
- +5 SET SRX=0
- FOR
- SET SRX=$ORDER(^SRO(133,SRX))
- if SRX'>0
- QUIT
- IF $DATA(^(SRX,0))
- IF '$PIECE(^(0),U,21)
- SET SITE=$PIECE(^(0),U)
- QUIT
- End DoDot:1
- IF 'SITE
- QUIT SITE
- +6 SET SRX=SITE
- FOR SRI=.01,99
- SET SRY=$$GET1^DIQ(4,SRX,SRI)
- SET SITE=SITE_"^"_SRY
- +7 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 NEW 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