SDM2A ;ALB/OG - MAKE APPOINTMENT - overflow routine ;24 Jun 2008 11:57 AM
;;5.3;PIMS;**446,528,1015,1016**;JUN 30, 2012;Build 20
WL(SC) ;Wait List Hook/teh patch 263 ;SD/327 passed 'SC'
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
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) ;
N %DT,DIR,X,X1,X2,Y
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
S DIR(0)="Y",DIR("B")="YES"
S DIR("A")="Add to EWL",DIR("A",1)="The date is more than 120 days beyond the Desired Date"
W ! D ^DIR
I Y=1 D WL(SC)
Q 0
;
WLCLASK() ; No appointment availability warning. ; sd/446
N DIR
S DIR(0)="Y"
S DIR("A",1)="No appointments are available within 120 days of the Desired Date."
S DIR("A",2)="Do you want to place this patient on the Electronic Wait List"
S DIR("A",3)="or change the desired 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
SDM2A ;ALB/OG - MAKE APPOINTMENT - overflow routine ;24 Jun 2008 11:57 AM
+1 ;;5.3;PIMS;**446,528,1015,1016**;JUN 30, 2012;Build 20
WL(SC) ;Wait List Hook/teh patch 263 ;SD/327 passed 'SC'
+1 NEW DA,DIE,DR,SBEG,SCSR,SDDIV,SDINST,SDPAR,SDWLDA,SDWLDFN,SDWLSCL
+2 IF $GET(SC)'>0
QUIT
+3 IF '$DATA(^SC(SC))
QUIT
+4 SET SDINST=""
+5 ;S SDINST=$$GET1^DIQ(44,SC_",",3,"I") ; get Inst BEFORE
+6 SET SDDIV=$$GET1^DIQ(44,SC_",",3.5,"I")
IF SDDIV'=""
SET SDINST=$$GET1^DIQ(40.8,SDDIV_",",.07,"I")
+7 ; sd/446
IF SDINST=""
Begin DoDot:1
+8 NEW DIR
+9 DO MESS2^SDWL120(SC)
+10 WRITE !,"No Institution/Division is associated with this Clinic."
+11 WRITE !,"Unable to create a Wait List Entry. Abandoning request."
+12 WRITE !!,"A message is being sent to the administrators mail group"
+13 WRITE !,"alerting them to the situation."
+14 SET DIR(0)="E"
DO ^DIR
+15 QUIT
End DoDot:1
QUIT
+16 SET SDPAR=0
+17 ;create 409.32 entry
+18 IF $DATA(^SDWL(409.32,"B",SC))
SET SDWLSCL=$ORDER(^SDWL(409.32,"B",SC,""))
+19 IF '$TEST
Begin DoDot:1
+20 NEW DA,DIC,X,DIE,DR
+21 SET DIC(0)="LX"
SET X=SC
SET DIC="^SDWL(409.32,"
DO FILE^DICN
+22 SET SDWLSCL=DA
+23 SET DIE="^SDWL(409.32,"
+24 SET DR=".02////^S X=SDINST"
DO ^DIE
+25 SET DR="1////^S X=DT"
+26 SET DR=DR_";2////^S X=DUZ"
+27 ; flag indicating clinic parameter entry
DO ^DIE
SET SDPAR=1
+28 ; CREATE 409.3 with 120 flag
End DoDot:1
+29 SET DIC(0)="LX"
SET (X,SDWLDFN)=DFN
SET DIC="^SDWL(409.3,"
DO FILE^DICN
+30 ; File just created so lock should never fail.
+31 FOR
LOCK +^SDWL(409.3,DA):5
IF $TEST
QUIT
WRITE !,"Unable to acquire a lock on the Wait List file"
QUIT
+32 ; Update EWL variables.
+33 ; get enrollee both SDWLDA and SDWLDFN have to be defined
SET SDWLDA=DA
DO EN^SDWLE11
+34 SET DIE="^SDWL(409.3,"
+35 SET DR="1////^S X=DT"
+36 SET DR=DR_";2////^S X=SDINST"
+37 SET DR=DR_";4////^S X=4"
+38 SET DR=DR_";8////^S X=SDWLSCL"
+39 SET DR=DR_";9////^S X=DUZ"
+40 SET DR=DR_";10////^S X=""A"""
+41 ; by patient for this entry to avoid asking for provider
SET DR=DR_";11////^S X=2"
+42 SET DR=DR_";14////^S X="""_$SELECT($PIECE($GET(^DPT(SDWLDFN,.3)),U,1)="Y":$PIECE(^DPT(SDWLDFN,.3),U,2),1:"")_""""
+43 SET DR=DR_";15////^S X="_$SELECT($PIECE($GET(^DPT(SDWLDFN,.3)),U,1)="Y":1,1:0)
+44 SET DR=DR_";22////^S X=SDDATE"
+45 SET DR=DR_";23////^S X=""O"""
+46 SET DR=DR_";25////^S X="" > 120 days"""
+47 SET DR=DR_";36////^S X=1"
+48 DO ^DIE
+49 LOCK -^SDWL(409.3,DA)
+50 SET SDWLFLG=0
DO MESS^SDWL120(SDWLDFN,SDWLDA,SDPAR)
+51 QUIT
+52 ;
WLCL120(SC,DESDT) ; Is there clinic availability within 120 days of desired date ; sd/446
+1 NEW SBEG,SD120
+2 ; Non-count clinic. Allow > 120 days.
IF $$GET1^DIQ(44,SC,2502,"I")="Y"
QUIT 1
+3 ;SD*567 added Go next line
SET SD120=0
SET SBEG=DESDT-1
+4 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
+5 NEW X,DESDTH
+6 SET X=SBEG
DO H^%DTC
SET SBEG=%H
+7 SET X=DESDT
DO H^%DTC
SET DESDTH=%H
+8 SET SD120=(SBEG-DESDTH>120)
+9 QUIT
End DoDot:1
QUIT
+10 QUIT 'SD120
+11 ;
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 NEW %DT,DIR,X,X1,X2,Y
+2 ; Non-count clinic. Allow > 120 days.
IF $$GET1^DIQ(44,SC,2502,"I")="Y"
QUIT 1
+3 SET X=SDWLAPDT
SET %DT="TXF"
DO ^%DT
+4 IF Y=-1
QUIT 1
+5 SET X1=Y
SET X2=SDDATE1
DO ^%DTC
+6 IF X'>120
QUIT 1
+7 SET DIR(0)="Y"
SET DIR("B")="YES"
+8 SET DIR("A")="Add to EWL"
SET DIR("A",1)="The date is more than 120 days beyond the Desired Date"
+9 WRITE !
DO ^DIR
+10 IF Y=1
DO WL(SC)
+11 QUIT 0
+12 ;
WLCLASK() ; No appointment availability warning. ; sd/446
+1 NEW DIR
+2 SET DIR(0)="Y"
+3 SET DIR("A",1)="No appointments are available within 120 days of the Desired Date."
+4 SET DIR("A",2)="Do you want to place this patient on the Electronic Wait List"
+5 SET DIR("A",3)="or change the desired date?"
+6 SET DIR("A",4)=""
+7 SET DIR("A",5)="Enter ""Y"" to place on EWL, ""N"" to go back"
+8 SET DIR("A")="or ""^"" to return to the CLINIC: prompt. "
+9 WRITE !
DO ^DIR
+10 QUIT Y
+11 ;
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
