- SROUTL ;BIR/ADM - UTILITY ROUTINE ;02/14/07
- ;;3.0; Surgery ;**58,62,69,77,50,88,94,100,129,134,141,142,160**;24 Jun 93;Build 7
- ;
- ; 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
- 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**;24 Jun 93;Build 7
- +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