SDM2A ;ALB/OG - MAKE APPOINTMENT - overflow routine ;1/11/16 10:34am
;;5.3;Scheduling;**446,528,567,594,611,645,769**;Aug 13 1993;Build 22
;
;
WL(SC) ;Wait List Hook/teh patch 263 ;SD/327 passed 'SC'
Q ;SD*5.3*769 - EWL decommission
N DA,DIE,DR,SBEG,SCSR,SDDIV,SDINST,SDPAR,SDWLDA,SDWLDFN,SDWLSCL
Q:$G(SC)'>0
I '$D(^SC(SC)) Q
S SDINST=""
;S SDINST=$$GET1^DIQ(44,SC_",",3,"I") ; get Inst BEFORE
S SDDIV=$$GET1^DIQ(44,SC_",",3.5,"I") S:SDDIV'="" SDINST=$$GET1^DIQ(40.8,SDDIV_",",.07,"I")
I SDINST="" D Q ; sd/446
.N DIR
.D MESS2^SDWL120(SC)
.W !,"No Institution/Division is associated with this Clinic."
.W !,"Unable to create a Wait List Entry. Abandoning request."
.W !!,"A message is being sent to the administrators mail group"
.W !,"alerting them to the situation."
.S DIR(0)="E" D ^DIR
.Q
S SDPAR=0
;create 409.32 entry
I $D(^SDWL(409.32,"B",SC)) S SDWLSCL=$O(^SDWL(409.32,"B",SC,""))
E D
.N DA,DIC,X,DIE,DR
.S DIC(0)="LX",X=SC,DIC="^SDWL(409.32," D FILE^DICN
.S SDWLSCL=DA
.S DIE="^SDWL(409.32,"
.S DR=".02////^S X=SDINST" D ^DIE
.S DR="1////^S X=DT"
.S DR=DR_";2////^S X=DUZ"
.D ^DIE S SDPAR=1 ; flag indicating clinic parameter entry
.; CREATE 409.3 with 120 flag
S DIC(0)="LX",(X,SDWLDFN)=DFN,DIC="^SDWL(409.3," D FILE^DICN
; File just created so lock should never fail.
F L +^SDWL(409.3,DA):5 Q:$T W !,"Unable to acquire a lock on the Wait List file" Q
; Update EWL variables.
S SDWLDA=DA D EN^SDWLE11 ; get enrollee both SDWLDA and SDWLDFN have to be defined
S DIE="^SDWL(409.3,"
S DR="1////^S X=DT"
S DR=DR_";2////^S X=SDINST"
S DR=DR_";4////^S X=4"
S DR=DR_";8////^S X=SDWLSCL"
S DR=DR_";9////^S X=DUZ"
S DR=DR_";10////^S X=""A"""
S DR=DR_";11////^S X=2" ; by patient for this entry to avoid asking for provider
S DR=DR_";14////^S X="""_$S($P($G(^DPT(SDWLDFN,.3)),U,1)="Y":$P(^DPT(SDWLDFN,.3),U,2),1:"")_""""
S DR=DR_";15////^S X="_$S($P($G(^DPT(SDWLDFN,.3)),U,1)="Y":1,1:0)
S DR=DR_";22////^S X=SDDATE"
S DR=DR_";23////^S X=""O"""
S DR=DR_";25////^S X="" > 120 days"""
S DR=DR_";36////^S X=1"
D ^DIE
L -^SDWL(409.3,DA)
S SDWLFLG=0 D MESS^SDWL120(SDWLDFN,SDWLDA,SDPAR)
Q
;
WLCL120(SC,DESDT) ; Is there clinic availability within 120 days of desired date ; sd/446
Q ;SD*5.3*769 - EWL decommission
N SBEG,SD120
Q:$$GET1^DIQ(44,SC,2502,"I")="Y" 1 ; Non-count clinic. Allow > 120 days.
S SD120=0,SBEG=DESDT-1 ;SD*567 added Go next line
F S SBEG=$O(^SC(SC,"ST",SBEG)) Q:SBEG="" G:'$D(^(1)) WL1 I $$HASAVSL(^SC(SC,"ST",SBEG,1)) D Q
.N X,DESDTH
.S X=SBEG D H^%DTC S SBEG=%H
.S X=DESDT D H^%DTC S DESDTH=%H
.S SD120=(SBEG-DESDTH>120)
.Q
Q 'SD120
;
WL1 ; SD*567 check for bad record and delete if applicable
I '$D(^SC(SC,"ST",SBEG,1)) I $D(^(9)) D DELETE
Q 'SD120
;
DELETE ; SD*567 delete bad record
S DA=SBEG,DA(1)=SC
S DIK="^SC("_DA(1)_",""ST"","
D ^DIK
K DA,DIK
Q
;
WLCL120A(SDWLAPDT,SDDATE1,SC) ;
Q 1 ;SD*5.3*769 - EWL decommission
N %DT,DIR,X,X1,X2,Y,SDRET,SDWLDFN
Q:$$GET1^DIQ(44,SC,2502,"I")="Y" 1 ; Non-count clinic. Allow > 120 days.
S X=SDWLAPDT,%DT="TXF" D ^%DT
Q:Y=-1 1
S X1=Y,X2=SDDATE1 D ^%DTC
I X'>120 Q 1
;SD*5.3*611 will not allow a prompt to create a wait list entry when clinic has an inactive date
;in the SD WAIT LIST LOCATION (#409.3) file.
S SDWLDFN=$O(^SDWL(409.32,"B",+SC,0))
I SDWLDFN'="",$P($G(^SDWL(409.32,SDWLDFN,0)),U,4)'="" Q 1
S DIR(0)="Y",DIR("B")="YES"
; SD*5.3*645 - replaced Desired Date with CID/Preferred Date when presented to the user
;S DIR("A")="Add to EWL",DIR("A",1)="The date is more than 120 days beyond the Desired Date"
S DIR("A")="Add to EWL",DIR("A",1)="The date is more than 120 days beyond the CID/Preferred Date"
W ! D ^DIR
;SD*5.3*594 allow appointment creation for appointments that have an appointment date
;that is greater than 120 days from the desired date.
S SDRET=Y
I SDRET=1 D WL(SC)
I SDRET=0 Q 1
Q 0
;
WLCLASK() ; No appointment availability warning. ; sd/446
Q 0 ;SD*5.3*769 - EWL decommission
N DIR
S DIR(0)="Y"
; SD*5.3*645 - replaced Desired Date with CID/Preferred Date when presented to the user
;S DIR("A",1)="No appointments are available within 120 days of the Desired Date."
S DIR("A",1)="No appointments are available within 120 days of the CID/Preferred Date."
S DIR("A",2)="Do you want to place this patient on the Electronic Wait List"
; SD*5.3*645 - replaced Desired Date with CID/Preferred Date when presented to the user
;S DIR("A",3)="or change the desired date?"
S DIR("A",3)="or change the CID/Preferred Date?"
S DIR("A",4)=""
S DIR("A",5)="Enter ""Y"" to place on EWL, ""N"" to go back"
S DIR("A")="or ""^"" to return to the CLINIC: prompt. "
W ! D ^DIR
Q Y
;
HASAVSL(SCSR) ; Has available slots ; sd/446
; Look at CLINIC PATTERN CURRENT AVAILABILITY string (44.005/1)
; If there is 1-9,j-z within the [ ... ], there is availability for that day.
N DIC,F,SDOK,X,Y
; Allow whatever if user has a key to overbook.
S DIC="^VA(200,"_DUZ_",51,",X="SDOB" D ^DIC Q:Y'=-1 1
S X="SDMOB" D ^DIC Q:Y'=-1 1
Q:SCSR'["[" 0 ; No slots.
S SCSR=$TR($E(SCSR,$F(SCSR,"[")-1,$L(SCSR))," |"),(SDOK,F)=0
F S F=$F(SCSR,"[",F) Q:'F D Q:SDOK
.N I,SCSR0,SL
.S SCSR0=$E(SCSR,F,$F(SCSR,"]",F)-2)
.F I=1:1:$L(SCSR0) S SL=$E(SCSR0,I) I $A(SL)>105&($A(SL)<123)!SL S SDOK=1 Q ; If SL=1-9,j-z slots are available
.Q
Q SDOK
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDM2A 5466 printed Apr 09, 2024@21:45:40 Page 2
SDM2A ;ALB/OG - MAKE APPOINTMENT - overflow routine ;1/11/16 10:34am
+1 ;;5.3;Scheduling;**446,528,567,594,611,645,769**;Aug 13 1993;Build 22
+2 ;
+3 ;
WL(SC) ;Wait List Hook/teh patch 263 ;SD/327 passed 'SC'
+1 ;SD*5.3*769 - EWL decommission
QUIT
+2 NEW DA,DIE,DR,SBEG,SCSR,SDDIV,SDINST,SDPAR,SDWLDA,SDWLDFN,SDWLSCL
+3 if $GET(SC)'>0
QUIT
+4 IF '$DATA(^SC(SC))
QUIT
+5 SET SDINST=""
+6 ;S SDINST=$$GET1^DIQ(44,SC_",",3,"I") ; get Inst BEFORE
+7 SET SDDIV=$$GET1^DIQ(44,SC_",",3.5,"I")
if SDDIV'=""
SET SDINST=$$GET1^DIQ(40.8,SDDIV_",",.07,"I")
+8 ; sd/446
IF SDINST=""
Begin DoDot:1
+9 NEW DIR
+10 DO MESS2^SDWL120(SC)
+11 WRITE !,"No Institution/Division is associated with this Clinic."
+12 WRITE !,"Unable to create a Wait List Entry. Abandoning request."
+13 WRITE !!,"A message is being sent to the administrators mail group"
+14 WRITE !,"alerting them to the situation."
+15 SET DIR(0)="E"
DO ^DIR
+16 QUIT
End DoDot:1
QUIT
+17 SET SDPAR=0
+18 ;create 409.32 entry
+19 IF $DATA(^SDWL(409.32,"B",SC))
SET SDWLSCL=$ORDER(^SDWL(409.32,"B",SC,""))
+20 IF '$TEST
Begin DoDot:1
+21 NEW DA,DIC,X,DIE,DR
+22 SET DIC(0)="LX"
SET X=SC
SET DIC="^SDWL(409.32,"
DO FILE^DICN
+23 SET SDWLSCL=DA
+24 SET DIE="^SDWL(409.32,"
+25 SET DR=".02////^S X=SDINST"
DO ^DIE
+26 SET DR="1////^S X=DT"
+27 SET DR=DR_";2////^S X=DUZ"
+28 ; flag indicating clinic parameter entry
DO ^DIE
SET SDPAR=1
+29 ; CREATE 409.3 with 120 flag
End DoDot:1
+30 SET DIC(0)="LX"
SET (X,SDWLDFN)=DFN
SET DIC="^SDWL(409.3,"
DO FILE^DICN
+31 ; File just created so lock should never fail.
+32 FOR
LOCK +^SDWL(409.3,DA):5
if $TEST
QUIT
WRITE !,"Unable to acquire a lock on the Wait List file"
QUIT
+33 ; Update EWL variables.
+34 ; get enrollee both SDWLDA and SDWLDFN have to be defined
SET SDWLDA=DA
DO EN^SDWLE11
+35 SET DIE="^SDWL(409.3,"
+36 SET DR="1////^S X=DT"
+37 SET DR=DR_";2////^S X=SDINST"
+38 SET DR=DR_";4////^S X=4"
+39 SET DR=DR_";8////^S X=SDWLSCL"
+40 SET DR=DR_";9////^S X=DUZ"
+41 SET DR=DR_";10////^S X=""A"""
+42 ; by patient for this entry to avoid asking for provider
SET DR=DR_";11////^S X=2"
+43 SET DR=DR_";14////^S X="""_$SELECT($PIECE($GET(^DPT(SDWLDFN,.3)),U,1)="Y":$PIECE(^DPT(SDWLDFN,.3),U,2),1:"")_""""
+44 SET DR=DR_";15////^S X="_$SELECT($PIECE($GET(^DPT(SDWLDFN,.3)),U,1)="Y":1,1:0)
+45 SET DR=DR_";22////^S X=SDDATE"
+46 SET DR=DR_";23////^S X=""O"""
+47 SET DR=DR_";25////^S X="" > 120 days"""
+48 SET DR=DR_";36////^S X=1"
+49 DO ^DIE
+50 LOCK -^SDWL(409.3,DA)
+51 SET SDWLFLG=0
DO MESS^SDWL120(SDWLDFN,SDWLDA,SDPAR)
+52 QUIT
+53 ;
WLCL120(SC,DESDT) ; Is there clinic availability within 120 days of desired date ; sd/446
+1 ;SD*5.3*769 - EWL decommission
QUIT
+2 NEW SBEG,SD120
+3 ; Non-count clinic. Allow > 120 days.
if $$GET1^DIQ(44,SC,2502,"I")="Y"
QUIT 1
+4 ;SD*567 added Go next line
SET SD120=0
SET SBEG=DESDT-1
+5 FOR
SET SBEG=$ORDER(^SC(SC,"ST",SBEG))
if SBEG=""
QUIT
if '$DATA(^(1))
GOTO WL1
IF $$HASAVSL(^SC(SC,"ST",SBEG,1))
Begin DoDot:1
+6 NEW X,DESDTH
+7 SET X=SBEG
DO H^%DTC
SET SBEG=%H
+8 SET X=DESDT
DO H^%DTC
SET DESDTH=%H
+9 SET SD120=(SBEG-DESDTH>120)
+10 QUIT
End DoDot:1
QUIT
+11 QUIT 'SD120
+12 ;
WL1 ; SD*567 check for bad record and delete if applicable
+1 IF '$DATA(^SC(SC,"ST",SBEG,1))
IF $DATA(^(9))
DO DELETE
+2 QUIT 'SD120
+3 ;
DELETE ; SD*567 delete bad record
+1 SET DA=SBEG
SET DA(1)=SC
+2 SET DIK="^SC("_DA(1)_",""ST"","
+3 DO ^DIK
+4 KILL DA,DIK
+5 QUIT
+6 ;
WLCL120A(SDWLAPDT,SDDATE1,SC) ;
+1 ;SD*5.3*769 - EWL decommission
QUIT 1
+2 NEW %DT,DIR,X,X1,X2,Y,SDRET,SDWLDFN
+3 ; Non-count clinic. Allow > 120 days.
if $$GET1^DIQ(44,SC,2502,"I")="Y"
QUIT 1
+4 SET X=SDWLAPDT
SET %DT="TXF"
DO ^%DT
+5 if Y=-1
QUIT 1
+6 SET X1=Y
SET X2=SDDATE1
DO ^%DTC
+7 IF X'>120
QUIT 1
+8 ;SD*5.3*611 will not allow a prompt to create a wait list entry when clinic has an inactive date
+9 ;in the SD WAIT LIST LOCATION (#409.3) file.
+10 SET SDWLDFN=$ORDER(^SDWL(409.32,"B",+SC,0))
+11 IF SDWLDFN'=""
IF $PIECE($GET(^SDWL(409.32,SDWLDFN,0)),U,4)'=""
QUIT 1
+12 SET DIR(0)="Y"
SET DIR("B")="YES"
+13 ; SD*5.3*645 - replaced Desired Date with CID/Preferred Date when presented to the user
+14 ;S DIR("A")="Add to EWL",DIR("A",1)="The date is more than 120 days beyond the Desired Date"
+15 SET DIR("A")="Add to EWL"
SET DIR("A",1)="The date is more than 120 days beyond the CID/Preferred Date"
+16 WRITE !
DO ^DIR
+17 ;SD*5.3*594 allow appointment creation for appointments that have an appointment date
+18 ;that is greater than 120 days from the desired date.
+19 SET SDRET=Y
+20 IF SDRET=1
DO WL(SC)
+21 IF SDRET=0
QUIT 1
+22 QUIT 0
+23 ;
WLCLASK() ; No appointment availability warning. ; sd/446
+1 ;SD*5.3*769 - EWL decommission
QUIT 0
+2 NEW DIR
+3 SET DIR(0)="Y"
+4 ; SD*5.3*645 - replaced Desired Date with CID/Preferred Date when presented to the user
+5 ;S DIR("A",1)="No appointments are available within 120 days of the Desired Date."
+6 SET DIR("A",1)="No appointments are available within 120 days of the CID/Preferred Date."
+7 SET DIR("A",2)="Do you want to place this patient on the Electronic Wait List"
+8 ; SD*5.3*645 - replaced Desired Date with CID/Preferred Date when presented to the user
+9 ;S DIR("A",3)="or change the desired date?"
+10 SET DIR("A",3)="or change the CID/Preferred Date?"
+11 SET DIR("A",4)=""
+12 SET DIR("A",5)="Enter ""Y"" to place on EWL, ""N"" to go back"
+13 SET DIR("A")="or ""^"" to return to the CLINIC: prompt. "
+14 WRITE !
DO ^DIR
+15 QUIT Y
+16 ;
HASAVSL(SCSR) ; Has available slots ; sd/446
+1 ; Look at CLINIC PATTERN CURRENT AVAILABILITY string (44.005/1)
+2 ; If there is 1-9,j-z within the [ ... ], there is availability for that day.
+3 NEW DIC,F,SDOK,X,Y
+4 ; Allow whatever if user has a key to overbook.
+5 SET DIC="^VA(200,"_DUZ_",51,"
SET X="SDOB"
DO ^DIC
if Y'=-1
QUIT 1
+6 SET X="SDMOB"
DO ^DIC
if Y'=-1
QUIT 1
+7 ; No slots.
if SCSR'["["
QUIT 0
+8 SET SCSR=$TRANSLATE($EXTRACT(SCSR,$FIND(SCSR,"[")-1,$LENGTH(SCSR))," |")
SET (SDOK,F)=0
+9 FOR
SET F=$FIND(SCSR,"[",F)
if 'F
QUIT
Begin DoDot:1
+10 NEW I,SCSR0,SL
+11 SET SCSR0=$EXTRACT(SCSR,F,$FIND(SCSR,"]",F)-2)
+12 ; If SL=1-9,j-z slots are available
FOR I=1:1:$LENGTH(SCSR0)
SET SL=$EXTRACT(SCSR0,I)
IF $ASCII(SL)>105&($ASCII(SL)<123)!SL
SET SDOK=1
QUIT
+13 QUIT
End DoDot:1
if SDOK
QUIT
+14 QUIT SDOK
