SROUTL ;BIR/ADM - UTILITY ROUTINE ;02/14/07
;;3.0;Surgery;**58,62,69,77,50,88,94,100,129,134,141,142,160,182**;24 Jun 93;Build 49
;
; Reference to $P(^SC(SRLOC,0),"^",17) supported by DBIA #964
;
Q
HDR ; display menu header
Q:'$D(SRSITE)
N DFN,SRCNT,SRNUM,SRSDATE,SRX,Y S (SRCNT,SRX)=0 F S SRX=$O(^SRO(133,SRX)) Q:'SRX I '$P($G(^SRO(133,SRX,0)),"^",21) S SRCNT=SRCNT+1
I SRCNT>1 S SRNUM=$$GET1^DIQ(4,SRSITE("DIV"),99) S Y="Division: "_SRSITE("SITE")_" ("_SRNUM_")" W @IOF,!,?(80-$L(Y)\2),Y
I $G(SRTN) D
.S DFN=$P(^SRF(SRTN,0),"^") D DEM^VADPT S Y=$E($P(^SRF(SRTN,0),"^",9),1,7) X ^DD("DD") S SRSDATE=Y
.W:SRCNT'>1 @IOF W:SRCNT>1 !! W " "_VADM(1)_" ("_VA("PID")_") Case #"_SRTN_" - "_SRSDATE
Q
CLINIC(SRLOC,SRCASE) ; active count clinic screen for cases
N SRCLIN,SRX,SRY,SRZ S SRZ=$S(SRCASE:$P(^SRF(SRCASE,0),U,9),1:DT) D SC I 'SRCLIN Q 0
Q 1
ACTCLIN(SRLOC) ; active count clinic screen
N SRCLIN,SRX,SRY,SRZ S SRZ=DT D SC I 'SRCLIN Q 0
Q 1
SC N SRKL S SRCLIN=1 S SRKL=$$GET1^DIQ(44,SRLOC,2.1) I SRKL'="CLINIC"!($P(^SC(SRLOC,0),"^",17)="Y") S SRCLIN=0 Q
S SRX=$P($G(^SC(SRLOC,"I")),"^") I 'SRX Q
S SRY=$P($G(^SC(SRLOC,"I")),U,2) I SRZ'<SRX,((SRY="")!(SRZ<SRY)) S SRCLIN=0
Q
INOUT ; select in/out-patient status choice for report
K DIR S DIR("A",1)="Print "_$S($D(SRRPT):SRRPT,1:"report")_" for",DIR("A",2)="",DIR("A",5)=" I - Inpatient cases only",DIR("A",4)=" O - Outpatient cases only",DIR("A",3)=" A - All cases"
S DIR("A",6)="",DIR("A")="Select Letter (I, O or A): ",DIR("B")=$S($D(SRB):SRB,1:"A")
S DIR(0)="SAM^A:All Cases;O:Outpatient Cases Only;I:Inpatient Cases Only" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 Q
S SRIO=Y
Q
DATE(SRSD,SRED,SRQ) ; starting and ending date utility (pass by reference)
; The following variables are returned
; SRSD - starting date
; SRED - ending date
; SRQ - user interrupt
S (SRSD,SRED,SRQ)=0 W ! F D Q:SRED'<SRSD!SRQ
.K %DT S %DT="AEPX",%DT("A")="Start with Date: " D ^%DT I Y<1 S SRQ=1 Q
.S SRSD=Y
.K %DT S %DT="AEPX",%DT("A")="End with Date: " D ^%DT I Y<1 S SRQ=1 Q
.I Y<SRSD W !!,"The ending date must be later than the starting date.",!
.S SRED=Y
Q
SPEC ; select surgical specialty
W @IOF,! S DIR("?",1)="Enter YES if you would like the report printed for all Surgical Specialties",DIR("?")="or enter NO to select a specific specialty."
S DIR("A")="Do you want the report for all Surgical Specialties ? ",DIR("B")="YES",DIR(0)="YA" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 Q
I 'Y W ! K DIC S DIC=137.45,DIC(0)="QEAMZ",DIC("A")="Select Surgical Specialty: ",DIC("S")="I '$P(^(0),""^"",3)" D ^DIC K DIC S:Y<0 SRSOUT=1 Q:Y<0 S SRSPEC=+Y,SRSPECN=$P(Y(0),"^")
Q
PROC ; put procedures and CPT code in array for display
N SRDA,X,Y K SRPROC S K=1,Y=$P(^SRF(SRTN,"OP"),"^",2),Y=$S(Y:$P($$CPT^ICPTCOD(Y),"^",2),1:"???") I Y'="???" D SSPRIN^SROCPT
S X=$P(^SRF(SRTN,"OP"),"^")_$S($G(SRSUPCPT)=1:"",1:" (CPT Code: "_Y_")") I $L(X)<(SRL+1) S SRPROC(K)=X,K=K+1 G OTH
D FORMAT
OTH S SRDA=0 F S SRDA=$O(^SRF(SRTN,13,SRDA)) Q:'SRDA D
.S Y=$P($G(^SRF(SRTN,13,SRDA,2)),"^"),Y=$S(Y:$P($$CPT^ICPTCOD(Y),"^",2),1:"???")
.I Y'="???" D SSOTH^SROCPT
.S X=$P(^SRF(SRTN,13,SRDA,0),"^")_$S($G(SRSUPCPT)=1:"",1:" (CPT Code: "_Y_")")
.I $L(X)<(SRL+1) S SRPROC(K)=X,K=K+1 Q
.D FORMAT
Q
FORMAT I $L(X)>SRL F D I $L(X)<(SRL+1) S SRPROC(K)=X,K=K+1 Q
.F I=0:1:(SRL-1) S J=SRL-I,Y=$E(X,J) I Y=" " S SRPROC(K)=$E(X,1,J-1),X=$E(X,J+1,$L(X)) S K=K+1 Q
Q
DIAG ; check diagnosis input for required space in every 31 characters
Q:$L(X)<31 N SRC,SRBL,SRDIAG,SRFLG
S SRDIAG=X,SRFLG=0 F D Q:SRFLG!($L(SRDIAG)'>30)
.S SRBL=$F(SRDIAG," ") I SRBL>32!('SRBL) S SRFLG=1 K X Q
.S SRDIAG=$E(SRDIAG,SRBL,$L(SRDIAG))
I '$D(X) D
.S SRC(1)="Answer must contain at least one space in every 31 characters of length.",SRC(1,"F")="!!?5",SRC(2)="If you are using a comma (,) to separate information, leave a space after",SRC(2,"F")="!?5"
.S SRC(3)="it. Please re-enter the diagnosis.",SRC(3,"F")="!?5" D EN^DDIOL(.SRC)
Q
LOCK(SRCASE) ;
N D0,SRCONCC,SRLCK,SRNOW,SRNOW1,SRTAG,SRUSER,SRX
S SRNOW=$$NOW^XLFDT,SRNOW1=$$FMADD^XLFDT(SRNOW,,2)
S SRLCK=1,SRTAG="",SRCONCC=$P($G(^SRF(SRCASE,"CON")),"^")
I $$SIGNED^SROESUTL(SRCASE)!$G(SRESIG) D SINED Q SRLCK
L +^XTMP("SRLOCK-"_SRCASE,DUZ,$J):$S($G(DILOCKTM)>0:DILOCKTM,1:3)
E D E1 S SRLCK=0 Q SRLCK
I SRCONCC D
.L +^XTMP("SRLOCK-"_SRCONCC,DUZ,$J):$S($G(DILOCKTM)>0:DILOCKTM,1:3)
.E D S SRLCK=0
..D E2 L -^XTMP("SRLOCK-"_SRCASE,DUZ,$J)
D:SRLCK XTMP
Q SRLCK
E1 S SRUSER="Another person",SRX=$O(^XTMP("SRLOCK-"_SRCASE,0))
I SRX S SRUSER=$P($G(^VA(200,SRX,0)),"^")
D EN^DDIOL(SRUSER_" is editing this case. Please try later.","","!,$C(7)") H 2
Q
E2 S SRUSER="Another person",SRX=$O(^XTMP("SRLOCK-"_SRCONCC,0))
I SRX S SRUSER=$P($G(^VA(200,SRX,0)),"^")
D EN^DDIOL(SRUSER_" is editing the concurrent case. Please try later.","","!,$C(7)") H 2
Q
SINED L +^XTMP("SRLOCK-"_SRCASE):$S($G(DILOCKTM)>0:DILOCKTM,1:3)
E D E1 S SRLCK=0 Q
I SRCONCC D Q:'SRLCK
.L +^XTMP("SRLOCK-"_SRCONCC):$S($G(DILOCKTM)>0:DILOCKTM,1:3)
.E D S SRLCK=0
..D E2 L -^XTMP("SRLOCK-"_SRCASE)
S SRTAG="-Master"
XTMP S ^XTMP("SRLOCK-"_SRCASE,0)=SRNOW1_"^"_SRNOW_"^Surgery Case Lock"_SRTAG_"^"_$J,^XTMP("SRLOCK-"_SRCASE,DUZ,$J)=""
I SRCONCC S ^XTMP("SRLOCK-"_SRCONCC,0)=SRNOW1_"^"_SRNOW_"^Surgery Case Lock"_SRTAG_"^"_$J,^XTMP("SRLOCK-"_SRCONCC,DUZ,$J)=""
Q
UNLOCK(SRCASE) ; apply decremental lock
N SRCC,SRCONCC S SRCONCC=$P($G(^SRF(SRCASE,"CON")),"^")
L -^XTMP("SRLOCK-"_SRCASE),-^XTMP("SRLOCK-"_SRCASE,DUZ,$J) K ^XTMP("SRLOCK-"_SRCASE,DUZ,$J)
I '$O(^XTMP("SRLOCK-"_SRCASE,0))!(($G(^XTMP("SRLOCK-"_SRCASE,0))["-Master")&($P($G(^XTMP("SRLOCK-"_SRCASE,0)),"^",4)=$J)) K ^XTMP("SRLOCK-"_SRCASE)
I SRCONCC D
.L -^XTMP("SRLOCK-"_SRCONCC),-^XTMP("SRLOCK-"_SRCONCC,DUZ,$J) K ^XTMP("SRLOCK-"_SRCONCC,DUZ,$J)
.I '$O(^XTMP("SRLOCK-"_SRCONCC,0))!(($G(^XTMP("SRLOCK-"_SRCONCC,0))["-Master")&($P($G(^XTMP("SRLOCK-"_SRCONCC,0)),"^",4)=$J)) K ^XTMP("SRLOCK-"_SRCONCC)
Q
NOCNT(SRDA) ; screen for active, non-count clinic for this division
N SRDIV,SRKL,SRLOC,SRX,SRY,SRZ
S SRDIV=$P($G(^SRO(133,SRDA,0)),"^"),SRLOC=Y,SRZ=DT
I SRDIV'=$P($G(^SC(SRLOC,0)),"^",4) Q 0
S SRKL=$$GET1^DIQ(44,SRLOC,2.1) I SRKL'="CLINIC" Q 0
I $P(^SC(SRLOC,0),"^",17)'="Y" Q 0
S SRX=$P($G(^SC(SRLOC,"I")),"^") I 'SRX Q 1
S SRY=$P($G(^SC(SRLOC,"I")),U,2) I SRZ'<SRX,((SRY="")!(SRZ<SRY)) Q 0
Q 1
DESC ; output attending code description when doing lookup
N SRX,SRY,SRZ
S SRX=0,SRY=Y F S SRX=$O(^SRO(132.9,SRY,1,SRX)) Q:'SRX S SRZ(SRX)=^SRO(132.9,SRY,1,SRX,0),SRZ(SRX,"F")="!?2"
I $O(SRZ(0)) D EN^DDIOL(.SRZ)
D EN^DDIOL(" ","","!")
Q
TIME ; transform time to date and time
S X=$S(X?1.4N.A!(X?1.2N1":"2N.A):"T@"_X,1:X) S %DT="EXR" D ^%DT S X=Y
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSROUTL 6869 printed Sep 23, 2025@20:22:54 Page 2
SROUTL ;BIR/ADM - UTILITY ROUTINE ;02/14/07
+1 ;;3.0;Surgery;**58,62,69,77,50,88,94,100,129,134,141,142,160,182**;24 Jun 93;Build 49
+2 ;
+3 ; Reference to $P(^SC(SRLOC,0),"^",17) supported by DBIA #964
+4 ;
+5 QUIT
HDR ; display menu header
+1 if '$DATA(SRSITE)
QUIT
+2 NEW DFN,SRCNT,SRNUM,SRSDATE,SRX,Y
SET (SRCNT,SRX)=0
FOR
SET SRX=$ORDER(^SRO(133,SRX))
if 'SRX
QUIT
IF '$PIECE($GET(^SRO(133,SRX,0)),"^",21)
SET SRCNT=SRCNT+1
+3 IF SRCNT>1
SET SRNUM=$$GET1^DIQ(4,SRSITE("DIV"),99)
SET Y="Division: "_SRSITE("SITE")_" ("_SRNUM_")"
WRITE @IOF,!,?(80-$LENGTH(Y)\2),Y
+4 IF $GET(SRTN)
Begin DoDot:1
+5 SET DFN=$PIECE(^SRF(SRTN,0),"^")
DO DEM^VADPT
SET Y=$EXTRACT($PIECE(^SRF(SRTN,0),"^",9),1,7)
XECUTE ^DD("DD")
SET SRSDATE=Y
+6 if SRCNT'>1
WRITE @IOF
if SRCNT>1
WRITE !!
WRITE " "_VADM(1)_" ("_VA("PID")_") Case #"_SRTN_" - "_SRSDATE
End DoDot:1
+7 QUIT
CLINIC(SRLOC,SRCASE) ; active count clinic screen for cases
+1 NEW SRCLIN,SRX,SRY,SRZ
SET SRZ=$SELECT(SRCASE:$PIECE(^SRF(SRCASE,0),U,9),1:DT)
DO SC
IF 'SRCLIN
QUIT 0
+2 QUIT 1
ACTCLIN(SRLOC) ; active count clinic screen
+1 NEW SRCLIN,SRX,SRY,SRZ
SET SRZ=DT
DO SC
IF 'SRCLIN
QUIT 0
+2 QUIT 1
SC NEW SRKL
SET SRCLIN=1
SET SRKL=$$GET1^DIQ(44,SRLOC,2.1)
IF SRKL'="CLINIC"!($PIECE(^SC(SRLOC,0),"^",17)="Y")
SET SRCLIN=0
QUIT
+1 SET SRX=$PIECE($GET(^SC(SRLOC,"I")),"^")
IF 'SRX
QUIT
+2 SET SRY=$PIECE($GET(^SC(SRLOC,"I")),U,2)
IF SRZ'<SRX
IF ((SRY="")!(SRZ<SRY))
SET SRCLIN=0
+3 QUIT
INOUT ; select in/out-patient status choice for report
+1 KILL DIR
SET DIR("A",1)="Print "_$SELECT($DATA(SRRPT):SRRPT,1:"report")_" for"
SET DIR("A",2)=""
SET DIR("A",5)=" I - Inpatient cases only"
SET DIR("A",4)=" O - Outpatient cases only"
SET DIR("A",3)=" A - All cases"
+2 SET DIR("A",6)=""
SET DIR("A")="Select Letter (I, O or A): "
SET DIR("B")=$SELECT($DATA(SRB):SRB,1:"A")
+3 SET DIR(0)="SAM^A:All Cases;O:Outpatient Cases Only;I:Inpatient Cases Only"
DO ^DIR
KILL DIR
IF $DATA(DTOUT)!$DATA(DUOUT)
SET SRSOUT=1
QUIT
+4 SET SRIO=Y
+5 QUIT
DATE(SRSD,SRED,SRQ) ; starting and ending date utility (pass by reference)
+1 ; The following variables are returned
+2 ; SRSD - starting date
+3 ; SRED - ending date
+4 ; SRQ - user interrupt
+5 SET (SRSD,SRED,SRQ)=0
WRITE !
FOR
Begin DoDot:1
+6 KILL %DT
SET %DT="AEPX"
SET %DT("A")="Start with Date: "
DO ^%DT
IF Y<1
SET SRQ=1
QUIT
+7 SET SRSD=Y
+8 KILL %DT
SET %DT="AEPX"
SET %DT("A")="End with Date: "
DO ^%DT
IF Y<1
SET SRQ=1
QUIT
+9 IF Y<SRSD
WRITE !!,"The ending date must be later than the starting date.",!
+10 SET SRED=Y
End DoDot:1
if SRED'<SRSD!SRQ
QUIT
+11 QUIT
SPEC ; select surgical specialty
+1 WRITE @IOF,!
SET DIR("?",1)="Enter YES if you would like the report printed for all Surgical Specialties"
SET DIR("?")="or enter NO to select a specific specialty."
+2 SET DIR("A")="Do you want the report for all Surgical Specialties ? "
SET DIR("B")="YES"
SET DIR(0)="YA"
DO ^DIR
KILL DIR
IF $DATA(DTOUT)!$DATA(DUOUT)
SET SRSOUT=1
QUIT
+3 IF 'Y
WRITE !
KILL DIC
SET DIC=137.45
SET DIC(0)="QEAMZ"
SET DIC("A")="Select Surgical Specialty: "
SET DIC("S")="I '$P(^(0),""^"",3)"
DO ^DIC
KILL DIC
if Y<0
SET SRSOUT=1
if Y<0
QUIT
SET SRSPEC=+Y
SET SRSPECN=$PIECE(Y(0),"^")
+4 QUIT
PROC ; put procedures and CPT code in array for display
+1 NEW SRDA,X,Y
KILL SRPROC
SET K=1
SET Y=$PIECE(^SRF(SRTN,"OP"),"^",2)
SET Y=$SELECT(Y:$PIECE($$CPT^ICPTCOD(Y),"^",2),1:"???")
IF Y'="???"
DO SSPRIN^SROCPT
+2 SET X=$PIECE(^SRF(SRTN,"OP"),"^")_$SELECT($GET(SRSUPCPT)=1:"",1:" (CPT Code: "_Y_")")
IF $LENGTH(X)<(SRL+1)
SET SRPROC(K)=X
SET K=K+1
GOTO OTH
+3 DO FORMAT
OTH SET SRDA=0
FOR
SET SRDA=$ORDER(^SRF(SRTN,13,SRDA))
if 'SRDA
QUIT
Begin DoDot:1
+1 SET Y=$PIECE($GET(^SRF(SRTN,13,SRDA,2)),"^")
SET Y=$SELECT(Y:$PIECE($$CPT^ICPTCOD(Y),"^",2),1:"???")
+2 IF Y'="???"
DO SSOTH^SROCPT
+3 SET X=$PIECE(^SRF(SRTN,13,SRDA,0),"^")_$SELECT($GET(SRSUPCPT)=1:"",1:" (CPT Code: "_Y_")")
+4 IF $LENGTH(X)<(SRL+1)
SET SRPROC(K)=X
SET K=K+1
QUIT
+5 DO FORMAT
End DoDot:1
+6 QUIT
FORMAT IF $LENGTH(X)>SRL
FOR
Begin DoDot:1
+1 FOR I=0:1:(SRL-1)
SET J=SRL-I
SET Y=$EXTRACT(X,J)
IF Y=" "
SET SRPROC(K)=$EXTRACT(X,1,J-1)
SET X=$EXTRACT(X,J+1,$LENGTH(X))
SET K=K+1
QUIT
End DoDot:1
IF $LENGTH(X)<(SRL+1)
SET SRPROC(K)=X
SET K=K+1
QUIT
+2 QUIT
DIAG ; check diagnosis input for required space in every 31 characters
+1 if $LENGTH(X)<31
QUIT
NEW SRC,SRBL,SRDIAG,SRFLG
+2 SET SRDIAG=X
SET SRFLG=0
FOR
Begin DoDot:1
+3 SET SRBL=$FIND(SRDIAG," ")
IF SRBL>32!('SRBL)
SET SRFLG=1
KILL X
QUIT
+4 SET SRDIAG=$EXTRACT(SRDIAG,SRBL,$LENGTH(SRDIAG))
End DoDot:1
if SRFLG!($LENGTH(SRDIAG)'>30)
QUIT
+5 IF '$DATA(X)
Begin DoDot:1
+6 SET SRC(1)="Answer must contain at least one space in every 31 characters of length."
SET SRC(1,"F")="!!?5"
SET SRC(2)="If you are using a comma (,) to separate information, leave a space after"
SET SRC(2,"F")="!?5"
+7 SET SRC(3)="it. Please re-enter the diagnosis."
SET SRC(3,"F")="!?5"
DO EN^DDIOL(.SRC)
End DoDot:1
+8 QUIT
LOCK(SRCASE) ;
+1 NEW D0,SRCONCC,SRLCK,SRNOW,SRNOW1,SRTAG,SRUSER,SRX
+2 SET SRNOW=$$NOW^XLFDT
SET SRNOW1=$$FMADD^XLFDT(SRNOW,,2)
+3 SET SRLCK=1
SET SRTAG=""
SET SRCONCC=$PIECE($GET(^SRF(SRCASE,"CON")),"^")
+4 IF $$SIGNED^SROESUTL(SRCASE)!$GET(SRESIG)
DO SINED
QUIT SRLCK
+5 LOCK +^XTMP("SRLOCK-"_SRCASE,DUZ,$JOB):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
+6 IF '$TEST
DO E1
SET SRLCK=0
QUIT SRLCK
+7 IF SRCONCC
Begin DoDot:1
+8 LOCK +^XTMP("SRLOCK-"_SRCONCC,DUZ,$JOB):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
+9 IF '$TEST
Begin DoDot:2
+10 DO E2
LOCK -^XTMP("SRLOCK-"_SRCASE,DUZ,$JOB)
End DoDot:2
SET SRLCK=0
End DoDot:1
+11 if SRLCK
DO XTMP
+12 QUIT SRLCK
E1 SET SRUSER="Another person"
SET SRX=$ORDER(^XTMP("SRLOCK-"_SRCASE,0))
+1 IF SRX
SET SRUSER=$PIECE($GET(^VA(200,SRX,0)),"^")
+2 DO EN^DDIOL(SRUSER_" is editing this case. Please try later.","","!,$C(7)")
HANG 2
+3 QUIT
E2 SET SRUSER="Another person"
SET SRX=$ORDER(^XTMP("SRLOCK-"_SRCONCC,0))
+1 IF SRX
SET SRUSER=$PIECE($GET(^VA(200,SRX,0)),"^")
+2 DO EN^DDIOL(SRUSER_" is editing the concurrent case. Please try later.","","!,$C(7)")
HANG 2
+3 QUIT
SINED LOCK +^XTMP("SRLOCK-"_SRCASE):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
+1 IF '$TEST
DO E1
SET SRLCK=0
QUIT
+2 IF SRCONCC
Begin DoDot:1
+3 LOCK +^XTMP("SRLOCK-"_SRCONCC):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
+4 IF '$TEST
Begin DoDot:2
+5 DO E2
LOCK -^XTMP("SRLOCK-"_SRCASE)
End DoDot:2
SET SRLCK=0
End DoDot:1
if 'SRLCK
QUIT
+6 SET SRTAG="-Master"
XTMP SET ^XTMP("SRLOCK-"_SRCASE,0)=SRNOW1_"^"_SRNOW_"^Surgery Case Lock"_SRTAG_"^"_$JOB
SET ^XTMP("SRLOCK-"_SRCASE,DUZ,$JOB)=""
+1 IF SRCONCC
SET ^XTMP("SRLOCK-"_SRCONCC,0)=SRNOW1_"^"_SRNOW_"^Surgery Case Lock"_SRTAG_"^"_$JOB
SET ^XTMP("SRLOCK-"_SRCONCC,DUZ,$JOB)=""
+2 QUIT
UNLOCK(SRCASE) ; apply decremental lock
+1 NEW SRCC,SRCONCC
SET SRCONCC=$PIECE($GET(^SRF(SRCASE,"CON")),"^")
+2 LOCK -^XTMP("SRLOCK-"_SRCASE),-^XTMP("SRLOCK-"_SRCASE,DUZ,$JOB)
KILL ^XTMP("SRLOCK-"_SRCASE,DUZ,$JOB)
+3 IF '$ORDER(^XTMP("SRLOCK-"_SRCASE,0))!(($GET(^XTMP("SRLOCK-"_SRCASE,0))["-Master")&($PIECE($GET(^XTMP("SRLOCK-"_SRCASE,0)),"^",4)=$JOB))
KILL ^XTMP("SRLOCK-"_SRCASE)
+4 IF SRCONCC
Begin DoDot:1
+5 LOCK -^XTMP("SRLOCK-"_SRCONCC),-^XTMP("SRLOCK-"_SRCONCC,DUZ,$JOB)
KILL ^XTMP("SRLOCK-"_SRCONCC,DUZ,$JOB)
+6 IF '$ORDER(^XTMP("SRLOCK-"_SRCONCC,0))!(($GET(^XTMP("SRLOCK-"_SRCONCC,0))["-Master")&($PIECE($GET(^XTMP("SRLOCK-"_SRCONCC,0)),"^",4)=$JOB))
KILL ^XTMP("SRLOCK-"_SRCONCC)
End DoDot:1
+7 QUIT
NOCNT(SRDA) ; screen for active, non-count clinic for this division
+1 NEW SRDIV,SRKL,SRLOC,SRX,SRY,SRZ
+2 SET SRDIV=$PIECE($GET(^SRO(133,SRDA,0)),"^")
SET SRLOC=Y
SET SRZ=DT
+3 IF SRDIV'=$PIECE($GET(^SC(SRLOC,0)),"^",4)
QUIT 0
+4 SET SRKL=$$GET1^DIQ(44,SRLOC,2.1)
IF SRKL'="CLINIC"
QUIT 0
+5 IF $PIECE(^SC(SRLOC,0),"^",17)'="Y"
QUIT 0
+6 SET SRX=$PIECE($GET(^SC(SRLOC,"I")),"^")
IF 'SRX
QUIT 1
+7 SET SRY=$PIECE($GET(^SC(SRLOC,"I")),U,2)
IF SRZ'<SRX
IF ((SRY="")!(SRZ<SRY))
QUIT 0
+8 QUIT 1
DESC ; output attending code description when doing lookup
+1 NEW SRX,SRY,SRZ
+2 SET SRX=0
SET SRY=Y
FOR
SET SRX=$ORDER(^SRO(132.9,SRY,1,SRX))
if 'SRX
QUIT
SET SRZ(SRX)=^SRO(132.9,SRY,1,SRX,0)
SET SRZ(SRX,"F")="!?2"
+3 IF $ORDER(SRZ(0))
DO EN^DDIOL(.SRZ)
+4 DO EN^DDIOL(" ","","!")
+5 QUIT
TIME ; transform time to date and time
+1 SET X=$SELECT(X?1.4N.A!(X?1.2N1":"2N.A):"T@"_X,1:X)
SET %DT="EXR"
DO ^%DT
SET X=Y
+2 QUIT
