SDM2A.m

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