SDWLQSC ;IOFO BAY PINES/TEH,DMR - WAITING LIST-SC PRIORITY BACKGROUND ; Apr 26, 2021@12:47
;;5.3;scheduling;**327,394,467,446,786**;AUG 13, 1993;Build 3
;
;SD*5.3*327 EWL Updates Phase II - Addition of EWL notification messages.
;SD*5.3*394 New Routine for background update of SDWL(409.3) SC priorities.
;SD*5.3*467 Match canceled appts in 409.3
;This routine will run as a background job to determine changes in SC disabilities and update
;the priority of the wait list visit. A mailman message will then be sent to the EWL mail group.
;Vars: SDWLDFN=EWL IEN
; SDWLSC1=EWL RECORDED SC %
; SDWLSC2=PATIENT FILE (2) CURRENT SC %
;DBIAs: 1476 reference to PRIMARY ELIG. ^DPT(IEN,.372)
; 427 reference to ^DIC(8)
Q
EN ;Use SDWL(409.3) to determine SC changes and priority.
Q ;Inactive - SD*5.3*786
S SDWLDFN=0 F S SDWLDFN=$O(^SDWL(409.3,"B",SDWLDFN)) Q:SDWLDFN<1 D
.S SDWLDA=0,SDWLME=0 F S SDWLDA=$O(^SDWL(409.3,"B",SDWLDFN,SDWLDA)) Q:SDWLDA="" D
..L +^SDWL(409.3,SDWLDA):$G(DILOCKTM,5) I '$T Q
..I $P($G(^SDWL(409.3,SDWLDA,0)),U,17)["C" Q ;I EWL entry has been 'CLOSED' don't process.
..S SDWLME=SDWLME+1
..S SDWLSC1=+$P($G(^SDWL(409.3,SDWLDA,"SC")),U,1)
..S SDWLSC2=+$$GET1^DIQ(2,SDWLDFN_",",.302,,"SDWLX","")
..I SDWLSC1=SDWLSC2 S SDWLSC4=1 Q
..S SDWLSCX=0,SDWLSC3=0,SDWLSC4=0
..I SDWLSC2<50,SDWLSC1>49 D
...S SDWLSC3=1,SDWLSC4=1,DA=SDWLDA,DR="14////^S X=SDWLSC2",DIE=409.3 D ^DIE,SET1
..I SDWLSC2>49,SDWLSC1>49 S SDWLSCX=SDWLSC2 D SET0 Q
..I SDWLSC2>49,SDWLSC1<50 S SDWLSCX=SDWLSC2 D SET0,SET1 Q
..I SDWLSC2<50,SDWLSC1<50 S SDWLSC3=1,SDWLSC4=1,SDWLSCX=SDWLSC2 D SET0,SET1 Q
..I '$D(^SDWL(409.3,SDWLDA,"SC")) D
...I SDWLSC2>49 S SDWLSCX=SDWLSC2 D SET0,SET1 Q ;Set "SC" node if not defined.
...I SDWLSC2<50 S SDWLSC3=1,SDWLSC4=1,DA=SDWLDA,DR="14////^S X=SDWLSC2",DIE=409.3 D ^DIE,SET1
..K SDWLSSN,SDWLSC2,SDWLSC1,SDWLSC3,SDWLSCP,SDWLX,SDWLI,SDWLSCX
..L -^SDWL(409.3,SDWLDA) Q
I $D(SDWLSC4),SDWLSC4 D
.I $D(^TMP("SDWLQSC2",$J)) D MESS1^SDWLMSG
I $D(^TMP("SDWLQSC1",$J)) D MESS^SDWLMSG
K SDWLDA,SDWLDFN,SDWLSC1,SDWLSC2,SDWLSC3,SDWLSC4,DA,DR,DIC,DIE,X,SDWLX,SDWLNAM,SDWLSSN,SDWLSCX,SDWLWRT,SDWLME
D EN2^SDWLQSC1 D EN3
K IEN,DFN,APPT,WLAPPT,STOP,WLSTAT,STATUS,NN,SDREC,SDARRAY,SDAPPT,CL,CLINIC,SDC,SDDFN,SDNAME,SDAPPST,CIEN,SDWL
K SDCL,SDIEN,CC,SDREACT,SDINACT,CLINICS,TEAM,TEAMN,WLOPEN,PIEN,POS,POSN,SDWLPOS,EDATE,DOD,DIS,NAME,MAX,AVAL,SDFORM
Q
SET0 ;Set EWL file with current SC percentage.
S DA=SDWLDA,DR="14////^S X=SDWLSCX",DIE=409.3 D ^DIE
I SDWLSC2=50!(SDWLSC2>50) S DR="15////^S X=1" D ^DIE
K DA,DR,X,DIE
Q
SET1 ;Set temporary file for message.
F SDWLI=.01,.09 S SDWLX(SDWLI)=$$GET1^DIQ(2,SDWLDFN_",",SDWLI,,"SDWLX","")
S SDWLNAM=$E($G(SDWLX(.01)),1,27),SDWLSSN=$E($G(SDWLX(.09)),6,99)
S SDWLSCP=$$GET1^DIQ(409.3,SDWLDA_",",15,,"SDWLSCP","")
S SDWLWRT=SDWLNAM,SDWLWRT=SDWLWRT_$J(SDWLSSN,(35-$L(SDWLNAM)))
S SDWLWRT=SDWLWRT_$J(SDWLSC1,8),SDWLWRT=SDWLWRT_$J(SDWLSC2,16-$L(SDWLSC1))
I 'SDWLSC3 S SDWLWRT=SDWLWRT_$J(SDWLSCP,15)
I SDWLSC3 S SDWLWRT=SDWLWRT_$J($S(SDWLME>1:"YES",1:"NO"),15)
I SDWLSC3 S ^TMP("SDWLQSC2",$J,SDWLDFN)=SDWLWRT Q
S ^TMP("SDWLQSC1",$J,SDWLDFN)=SDWLWRT
Q
APPT(CLINIC,IEN) ;
S (SDREC,SDARRAY)=""
S SDARRAY(1)=WLAPPT_";"_WLAPPT
S SDARRAY(4)=DFN
S SDARRAY("FLDS")="3;2;4;1"
S SDREC=$$SDAPI^SDAMA301(.SDARRAY)
IF SDREC>0 D
.S (CL,SDC,SDDFN,SDNAM,SDAPPT,SDAPPST,NN)=""
.S CL=$O(^TMP($J,"SDAMA301",DFN,"")) Q:CL="" ;Current Clinic
.S SDAPPST=$P($G(^TMP($J,"SDAMA301",DFN,CL,WLAPPT)),"^",3),SDAPPST=$P(SDAPPST,";") ;Appt Status
.I CL'=CLINIC!(SDAPPST="CC") D
..S SDDFN=$P($G(^TMP($J,"SDAMA301",DFN,CL,WLAPPT)),"^",4) IF SDDFN'="" S SDNAM=$P($G(SDDFN),";",2),SDNAM=$E(SDNAM,1,30)
..S SDC=$P($G(^TMP($J,"SDAMA301",DFN,CL,WLAPPT)),"^",2)
..S SDC=$$GET1^DIQ(44,CL_",",.01),SDC=$E(SDC,1,25)
..S Y=WLAPPT D DD^%DT S SDAPPT=Y
..IF CL'=CLINIC S SDC=SDC_"(new)" ;to distinguish another clinic"
..S SDFORM=$$FORM^SDFORM(SDNAM,32,SDC,27,SDAPPT,21)
..S NN=NN+1,^TMP("SDWLQSC3",$J,NN)=SDFORM
..S DIE="^SDWL(409.3,",DA=IEN,DR="23////^S X=""O""" D ^DIE
..S DR="13.8////^S X=""CC""" D ^DIE
..S DR="29////^S X=""CA""" D ^DIE
..S DR="19///@;20///@;21///@" D ^DIE
..S DR="13///@;13.1////@;13.2///@;13.3///@;13.4///@;13.5///@;13.6///@;13.8///@;13.7///@" D ^DIE ;SD/467
Q
EN3 ;Inactive clinics
S (CIEN,IEN,APPT,DFN,WLSTAT,SDCL,SDIEN,CC,SDREACT,SDINACT,CLINICS,SDFORM)=""
F S CIEN=$O(^SDWL(409.3,"SC",CIEN)) Q:CIEN<1 S CC=0 D
.S SDINACT=$$GET1^DIQ(44,CIEN_",",2505,"I"),SDREACT=$$GET1^DIQ(44,CIEN_",",2506,"I")
.Q:SDINACT=""&(SDREACT="") D
..S IEN="" F S IEN=$O(^SDWL(409.3,"SC",CIEN,IEN)) Q:IEN<1 S WLSTAT=$$GET1^DIQ(409.3,IEN_",",23,"I") D
...Q:WLSTAT'="O"
...Q:SDINACT<SDREACT&((SDREACT+.01)>DT)
...Q:SDINACT<DT&(SDREACT>SDINACT)
...Q:SDINACT>(DT+.01)
...S CC=CC+1
.IF CC>0 D
..S CLINIC=$$GET1^DIQ(44,CIEN_",",.01),CLINIC=$E(CLINIC,1,30)
..S SDFORM=$$FORM^SDFORM(CLINIC,40,CC,20),^TMP("SDWLQSC4",$J,CIEN)=SDFORM
..S REC="",REC=$O(^SDWL(409.32,"B",CIEN,REC),-1)
..IF REC'="" D
...S SDINACT=$$GET1^DIQ(44,CIEN_",",2505,"I")
...S DIE="^SDWL(409.32,",DA=REC,DR="3////^S X=SDINACT" D ^DIE
...S DR="4////^S X=.5" D ^DIE
IF $D(^TMP("SDWLQSC4",$J)) D MESS3^SDWLMSG
D EN4
Q
EN4 ;PCMM Team inactivated
S (IEN,TIEN,TEAM,TEAMN,DFN,CC,STATUS,WLOPEN,SDFORM)="" S CC="0"
F S TEAM=$O(^SDWL(409.3,"D",TEAM)) Q:TEAM<1 S CC=0 D
.S IEN="" F S IEN=$O(^SDWL(409.3,"D",TEAM,IEN)) Q:IEN<1 S WLOPEN=$$GET1^DIQ(409.3,IEN_",",23,"I") D
..Q:WLOPEN="C" S TIEN="",TIEN=$O(^SCTM(404.58,"B",TEAM,TIEN),-1) IF TIEN'="" D
...S STATUS=$$GET1^DIQ(404.58,TIEN_",",.03,"I")
...Q:STATUS="1"
...IF STATUS="0" S CC=CC+1
.IF CC>0 D
..S TEAMN=$$GET1^DIQ(404.51,TEAM_",",.01) S TEAMN=$E(TEAMN,1,30)
..S SDFORM=$$FORM^SDFORM(TEAMN,40,CC,20),^TMP("SDWLQSC5",$J,TEAM)=SDFORM
IF $D(^TMP("SDWLQSC5",$J)) D MESS4^SDWLMSG
D EN5
Q
EN5 ;PCMM Position inactivated
S (IEN,PIEN,POS,POSN,STATUS,WLOPEN,SDWLPOS,SDFORM,TEAM)=""
S SDWLPOS="" F S IEN=$O(^SDWL(409.3,"SP",IEN)) Q:IEN<1 D
.S POS="" F S POS=$O(^SDWL(409.3,"SP",IEN,POS)) Q:POS<1 D
..S WLOPEN=$$GET1^DIQ(409.3,IEN_",",23,"I")
..Q:WLOPEN="C"
..S PIEN="",PIEN=$O(^SCTM(404.59,"B",POS,PIEN),-1) IF PIEN'="" D
... S POSN=$$GET1^DIQ(404.57,POS_",",.01)
...IF PIEN'="" S STATUS=$$GET1^DIQ(404.59,PIEN_",",.03,"I")
...Q:STATUS="1"
...IF STATUS="0" D
....S:'$D(SDWLPOS(POS)) SDWLPOS(POS)=0 S SDWLPOS(POS)=SDWLPOS(POS)+1,POSN=$E(POSN,1,30)
....S TEAM=$$GET1^DIQ(404.57,POS_",",.02),TEAM=$E(TEAM,1,25)
....S SDFORM=$$FORM^SDFORM(POSN,32,TEAM,27,SDWLPOS(POS),21)
....S ^TMP("SDWLQSC6",$J,POS)=SDFORM
IF $D(^TMP("SDWLQSC6",$J)) D MESS5^SDWLMSG
D EN6
Q
EN6 ;Date of Death
S (IEN,SDDFN,DIS,DOD,NAME)=""
F S SDDFN=$O(^SDWL(409.3,"B",SDDFN)) Q:SDDFN<1 D
.S IEN="" F S IEN=$O(^SDWL(409.3,"B",SDDFN,IEN)) Q:IEN<1 D
..S DIS=$$GET1^DIQ(409.3,IEN_",",21,"I") IF DIS="D" D
...S DOD=$$GET1^DIQ(2,SDDFN_",",.351) Q:DOD'="" D
....S DIE="^SDWL(409.3,",DA=IEN,DR="23////^S X=""O""" D ^DIE
....S DR="19///@" D ^DIE
....S DR="20///@" D ^DIE
....S DR="21///@" D ^DIE
....S DR="29////^S X=""DE""" D ^DIE
....S NAME=$$GET1^DIQ(2,SDDFN_",",.01) S ^TMP("SDWLQSC7",$J,SDDFN)=NAME
IF $D(^TMP("SDWLQSC7",$J)) D MESS6^SDWLMSG
D EN7
Q
EN7 ;PCMM Team open slots
S (IEN,TIEN,TEAMN,CC,WLOPEN,MAX,AVAL,SDFORM,TEAM,STATUS)=""
F S TEAM=$O(^SDWL(409.3,"D",TEAM)) Q:TEAM<1 S CC=0 D
.S IEN="" F S IEN=$O(^SDWL(409.3,"D",TEAM,IEN)) Q:IEN<1 S WLOPEN=$$GET1^DIQ(409.3,IEN_",",23,"I") D
..Q:WLOPEN="C" S CC=CC+1
.IF CC>0 D
..S TIEN="",TIEN=$O(^SCTM(404.58,"B",TEAM,TIEN),-1) IF TIEN'="" D
...S STATUS=$$GET1^DIQ(404.58,TIEN_",",.03,"I")
...Q:STATUS="0"
...S MAX=$$GET1^DIQ(404.51,TEAM_",",.08)
...S TEAMC=$$TEAMCNT^SCAPMCU1(TEAM,DT)
...Q:(TEAMC+.01)>MAX S AVAL=MAX-TEAMC,TEAMN=$$GET1^DIQ(404.51,TEAM_",",.01)
...S TEAMN=$E(TEAMN,1,30),SDFORM=$$FORM^SDFORM(TEAMN,35,AVAL,22,CC,12)
...S ^TMP("SDWLQSC8",$J,TIEN)=SDFORM
IF $D(^TMP("SDWLQSC8",$J)) D
.S SDFORM=$$FORM^SDFORM("TEAM",35,"SLOTS AVAILIABLE",22,"EWL ENTRIES",12)
.S ^TMP("SDWLQSC8",$J,.06)=SDFORM
.D MESS7^SDWLMSG
D EN8
Q
EN8 ;PCMM Position open slots
S (IEN,PIEN,POS,POSN,STATUS,WLOPEN,EDATE,SDWLPOS,SDWL,SDFORM)="" K SDWLPOS
S SDWLPOS="" F S IEN=$O(^SDWL(409.3,"SP",IEN)) Q:IEN<1 D
.S POS="" F S POS=$O(^SDWL(409.3,"SP",IEN,POS)) Q:POS<1 D
..S PIEN="",PIEN=$O(^SCTM(404.59,"B",POS,PIEN),-1) IF PIEN'="" D
...S STATUS=$$GET1^DIQ(404.59,PIEN_",",.03,"I")
...S WLOPEN=$$GET1^DIQ(409.3,IEN_",",23,"I"),EDATE=$$GET1^DIQ(404.59,PIEN_",",.02,"I")
...Q:WLOPEN="C"
...Q:((EDATE+.01)<DT&(STATUS="0"))
...S:'$D(SDWLPOS(POS)) SDWLPOS(POS)=0 S SDWLPOS(POS)=SDWLPOS(POS)+1
S (IEN,POS,POSN,MAX,AVAL,CC,TEAM)=""
F S POS=$O(SDWLPOS(POS)) Q:POS<1 D
.S MAX=$$GET1^DIQ(404.57,POS_",",.08),SDWL=$$PCPOSCNT^SCAPMCU1(POS,DT)
.Q:(SDWL+.01)>MAX
.S TEAM=$$GET1^DIQ(404.57,POS_",",.02),TEAM=$E(TEAM,1,23)
.S AVAL=MAX-SDWL,POSN=$$GET1^DIQ(404.57,POS_",",.01)
.S POSN=$E(POSN,1,23),SDFORM=$$FORM^SDFORM(POSN,25,TEAM,25,AVAL,14,SDWLPOS(POS),11)
.S ^TMP("SDWLQSC9",$J,POS)=SDFORM
IF $D(^TMP("SDWLQSC9",$J)) D
.S SDFORM=$$FORM^SDFORM("POSITION",25,"TEAM",25,"SLOTS AVAIL",14,"EWL ENTRIES",11)
.S ^TMP("SDWLQSC9",$J,.06)=SDFORM
.D MESS8^SDWLMSG
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDWLQSC 9431 printed Dec 13, 2024@03:03:01 Page 2
SDWLQSC ;IOFO BAY PINES/TEH,DMR - WAITING LIST-SC PRIORITY BACKGROUND ; Apr 26, 2021@12:47
+1 ;;5.3;scheduling;**327,394,467,446,786**;AUG 13, 1993;Build 3
+2 ;
+3 ;SD*5.3*327 EWL Updates Phase II - Addition of EWL notification messages.
+4 ;SD*5.3*394 New Routine for background update of SDWL(409.3) SC priorities.
+5 ;SD*5.3*467 Match canceled appts in 409.3
+6 ;This routine will run as a background job to determine changes in SC disabilities and update
+7 ;the priority of the wait list visit. A mailman message will then be sent to the EWL mail group.
+8 ;Vars: SDWLDFN=EWL IEN
+9 ; SDWLSC1=EWL RECORDED SC %
+10 ; SDWLSC2=PATIENT FILE (2) CURRENT SC %
+11 ;DBIAs: 1476 reference to PRIMARY ELIG. ^DPT(IEN,.372)
+12 ; 427 reference to ^DIC(8)
+13 QUIT
EN ;Use SDWL(409.3) to determine SC changes and priority.
+1 ;Inactive - SD*5.3*786
QUIT
+2 SET SDWLDFN=0
FOR
SET SDWLDFN=$ORDER(^SDWL(409.3,"B",SDWLDFN))
if SDWLDFN<1
QUIT
Begin DoDot:1
+3 SET SDWLDA=0
SET SDWLME=0
FOR
SET SDWLDA=$ORDER(^SDWL(409.3,"B",SDWLDFN,SDWLDA))
if SDWLDA=""
QUIT
Begin DoDot:2
+4 LOCK +^SDWL(409.3,SDWLDA):$GET(DILOCKTM,5)
IF '$TEST
QUIT
+5 ;I EWL entry has been 'CLOSED' don't process.
IF $PIECE($GET(^SDWL(409.3,SDWLDA,0)),U,17)["C"
QUIT
+6 SET SDWLME=SDWLME+1
+7 SET SDWLSC1=+$PIECE($GET(^SDWL(409.3,SDWLDA,"SC")),U,1)
+8 SET SDWLSC2=+$$GET1^DIQ(2,SDWLDFN_",",.302,,"SDWLX","")
+9 IF SDWLSC1=SDWLSC2
SET SDWLSC4=1
QUIT
+10 SET SDWLSCX=0
SET SDWLSC3=0
SET SDWLSC4=0
+11 IF SDWLSC2<50
IF SDWLSC1>49
Begin DoDot:3
+12 SET SDWLSC3=1
SET SDWLSC4=1
SET DA=SDWLDA
SET DR="14////^S X=SDWLSC2"
SET DIE=409.3
DO ^DIE
DO SET1
End DoDot:3
+13 IF SDWLSC2>49
IF SDWLSC1>49
SET SDWLSCX=SDWLSC2
DO SET0
QUIT
+14 IF SDWLSC2>49
IF SDWLSC1<50
SET SDWLSCX=SDWLSC2
DO SET0
DO SET1
QUIT
+15 IF SDWLSC2<50
IF SDWLSC1<50
SET SDWLSC3=1
SET SDWLSC4=1
SET SDWLSCX=SDWLSC2
DO SET0
DO SET1
QUIT
+16 IF '$DATA(^SDWL(409.3,SDWLDA,"SC"))
Begin DoDot:3
+17 ;Set "SC" node if not defined.
IF SDWLSC2>49
SET SDWLSCX=SDWLSC2
DO SET0
DO SET1
QUIT
+18 IF SDWLSC2<50
SET SDWLSC3=1
SET SDWLSC4=1
SET DA=SDWLDA
SET DR="14////^S X=SDWLSC2"
SET DIE=409.3
DO ^DIE
DO SET1
End DoDot:3
+19 KILL SDWLSSN,SDWLSC2,SDWLSC1,SDWLSC3,SDWLSCP,SDWLX,SDWLI,SDWLSCX
+20 LOCK -^SDWL(409.3,SDWLDA)
QUIT
End DoDot:2
End DoDot:1
+21 IF $DATA(SDWLSC4)
IF SDWLSC4
Begin DoDot:1
+22 IF $DATA(^TMP("SDWLQSC2",$JOB))
DO MESS1^SDWLMSG
End DoDot:1
+23 IF $DATA(^TMP("SDWLQSC1",$JOB))
DO MESS^SDWLMSG
+24 KILL SDWLDA,SDWLDFN,SDWLSC1,SDWLSC2,SDWLSC3,SDWLSC4,DA,DR,DIC,DIE,X,SDWLX,SDWLNAM,SDWLSSN,SDWLSCX,SDWLWRT,SDWLME
+25 DO EN2^SDWLQSC1
DO EN3
+26 KILL IEN,DFN,APPT,WLAPPT,STOP,WLSTAT,STATUS,NN,SDREC,SDARRAY,SDAPPT,CL,CLINIC,SDC,SDDFN,SDNAME,SDAPPST,CIEN,SDWL
+27 KILL SDCL,SDIEN,CC,SDREACT,SDINACT,CLINICS,TEAM,TEAMN,WLOPEN,PIEN,POS,POSN,SDWLPOS,EDATE,DOD,DIS,NAME,MAX,AVAL,SDFORM
+28 QUIT
SET0 ;Set EWL file with current SC percentage.
+1 SET DA=SDWLDA
SET DR="14////^S X=SDWLSCX"
SET DIE=409.3
DO ^DIE
+2 IF SDWLSC2=50!(SDWLSC2>50)
SET DR="15////^S X=1"
DO ^DIE
+3 KILL DA,DR,X,DIE
+4 QUIT
SET1 ;Set temporary file for message.
+1 FOR SDWLI=.01,.09
SET SDWLX(SDWLI)=$$GET1^DIQ(2,SDWLDFN_",",SDWLI,,"SDWLX","")
+2 SET SDWLNAM=$EXTRACT($GET(SDWLX(.01)),1,27)
SET SDWLSSN=$EXTRACT($GET(SDWLX(.09)),6,99)
+3 SET SDWLSCP=$$GET1^DIQ(409.3,SDWLDA_",",15,,"SDWLSCP","")
+4 SET SDWLWRT=SDWLNAM
SET SDWLWRT=SDWLWRT_$JUSTIFY(SDWLSSN,(35-$LENGTH(SDWLNAM)))
+5 SET SDWLWRT=SDWLWRT_$JUSTIFY(SDWLSC1,8)
SET SDWLWRT=SDWLWRT_$JUSTIFY(SDWLSC2,16-$LENGTH(SDWLSC1))
+6 IF 'SDWLSC3
SET SDWLWRT=SDWLWRT_$JUSTIFY(SDWLSCP,15)
+7 IF SDWLSC3
SET SDWLWRT=SDWLWRT_$JUSTIFY($SELECT(SDWLME>1:"YES",1:"NO"),15)
+8 IF SDWLSC3
SET ^TMP("SDWLQSC2",$JOB,SDWLDFN)=SDWLWRT
QUIT
+9 SET ^TMP("SDWLQSC1",$JOB,SDWLDFN)=SDWLWRT
+10 QUIT
APPT(CLINIC,IEN) ;
+1 SET (SDREC,SDARRAY)=""
+2 SET SDARRAY(1)=WLAPPT_";"_WLAPPT
+3 SET SDARRAY(4)=DFN
+4 SET SDARRAY("FLDS")="3;2;4;1"
+5 SET SDREC=$$SDAPI^SDAMA301(.SDARRAY)
+6 IF SDREC>0
Begin DoDot:1
+7 SET (CL,SDC,SDDFN,SDNAM,SDAPPT,SDAPPST,NN)=""
+8 ;Current Clinic
SET CL=$ORDER(^TMP($JOB,"SDAMA301",DFN,""))
if CL=""
QUIT
+9 ;Appt Status
SET SDAPPST=$PIECE($GET(^TMP($JOB,"SDAMA301",DFN,CL,WLAPPT)),"^",3)
SET SDAPPST=$PIECE(SDAPPST,";")
+10 IF CL'=CLINIC!(SDAPPST="CC")
Begin DoDot:2
+11 SET SDDFN=$PIECE($GET(^TMP($JOB,"SDAMA301",DFN,CL,WLAPPT)),"^",4)
IF SDDFN'=""
SET SDNAM=$PIECE($GET(SDDFN),";",2)
SET SDNAM=$EXTRACT(SDNAM,1,30)
+12 SET SDC=$PIECE($GET(^TMP($JOB,"SDAMA301",DFN,CL,WLAPPT)),"^",2)
+13 SET SDC=$$GET1^DIQ(44,CL_",",.01)
SET SDC=$EXTRACT(SDC,1,25)
+14 SET Y=WLAPPT
DO DD^%DT
SET SDAPPT=Y
+15 ;to distinguish another clinic"
IF CL'=CLINIC
SET SDC=SDC_"(new)"
+16 SET SDFORM=$$FORM^SDFORM(SDNAM,32,SDC,27,SDAPPT,21)
+17 SET NN=NN+1
SET ^TMP("SDWLQSC3",$JOB,NN)=SDFORM
+18 SET DIE="^SDWL(409.3,"
SET DA=IEN
SET DR="23////^S X=""O"""
DO ^DIE
+19 SET DR="13.8////^S X=""CC"""
DO ^DIE
+20 SET DR="29////^S X=""CA"""
DO ^DIE
+21 SET DR="19///@;20///@;21///@"
DO ^DIE
+22 ;SD/467
SET DR="13///@;13.1////@;13.2///@;13.3///@;13.4///@;13.5///@;13.6///@;13.8///@;13.7///@"
DO ^DIE
End DoDot:2
End DoDot:1
+23 QUIT
EN3 ;Inactive clinics
+1 SET (CIEN,IEN,APPT,DFN,WLSTAT,SDCL,SDIEN,CC,SDREACT,SDINACT,CLINICS,SDFORM)=""
+2 FOR
SET CIEN=$ORDER(^SDWL(409.3,"SC",CIEN))
if CIEN<1
QUIT
SET CC=0
Begin DoDot:1
+3 SET SDINACT=$$GET1^DIQ(44,CIEN_",",2505,"I")
SET SDREACT=$$GET1^DIQ(44,CIEN_",",2506,"I")
+4 if SDINACT=""&(SDREACT="")
QUIT
Begin DoDot:2
+5 SET IEN=""
FOR
SET IEN=$ORDER(^SDWL(409.3,"SC",CIEN,IEN))
if IEN<1
QUIT
SET WLSTAT=$$GET1^DIQ(409.3,IEN_",",23,"I")
Begin DoDot:3
+6 if WLSTAT'="O"
QUIT
+7 if SDINACT<SDREACT&((SDREACT+.01)>DT)
QUIT
+8 if SDINACT<DT&(SDREACT>SDINACT)
QUIT
+9 if SDINACT>(DT+.01)
QUIT
+10 SET CC=CC+1
End DoDot:3
End DoDot:2
+11 IF CC>0
Begin DoDot:2
+12 SET CLINIC=$$GET1^DIQ(44,CIEN_",",.01)
SET CLINIC=$EXTRACT(CLINIC,1,30)
+13 SET SDFORM=$$FORM^SDFORM(CLINIC,40,CC,20)
SET ^TMP("SDWLQSC4",$JOB,CIEN)=SDFORM
+14 SET REC=""
SET REC=$ORDER(^SDWL(409.32,"B",CIEN,REC),-1)
+15 IF REC'=""
Begin DoDot:3
+16 SET SDINACT=$$GET1^DIQ(44,CIEN_",",2505,"I")
+17 SET DIE="^SDWL(409.32,"
SET DA=REC
SET DR="3////^S X=SDINACT"
DO ^DIE
+18 SET DR="4////^S X=.5"
DO ^DIE
End DoDot:3
End DoDot:2
End DoDot:1
+19 IF $DATA(^TMP("SDWLQSC4",$JOB))
DO MESS3^SDWLMSG
+20 DO EN4
+21 QUIT
EN4 ;PCMM Team inactivated
+1 SET (IEN,TIEN,TEAM,TEAMN,DFN,CC,STATUS,WLOPEN,SDFORM)=""
SET CC="0"
+2 FOR
SET TEAM=$ORDER(^SDWL(409.3,"D",TEAM))
if TEAM<1
QUIT
SET CC=0
Begin DoDot:1
+3 SET IEN=""
FOR
SET IEN=$ORDER(^SDWL(409.3,"D",TEAM,IEN))
if IEN<1
QUIT
SET WLOPEN=$$GET1^DIQ(409.3,IEN_",",23,"I")
Begin DoDot:2
+4 if WLOPEN="C"
QUIT
SET TIEN=""
SET TIEN=$ORDER(^SCTM(404.58,"B",TEAM,TIEN),-1)
IF TIEN'=""
Begin DoDot:3
+5 SET STATUS=$$GET1^DIQ(404.58,TIEN_",",.03,"I")
+6 if STATUS="1"
QUIT
+7 IF STATUS="0"
SET CC=CC+1
End DoDot:3
End DoDot:2
+8 IF CC>0
Begin DoDot:2
+9 SET TEAMN=$$GET1^DIQ(404.51,TEAM_",",.01)
SET TEAMN=$EXTRACT(TEAMN,1,30)
+10 SET SDFORM=$$FORM^SDFORM(TEAMN,40,CC,20)
SET ^TMP("SDWLQSC5",$JOB,TEAM)=SDFORM
End DoDot:2
End DoDot:1
+11 IF $DATA(^TMP("SDWLQSC5",$JOB))
DO MESS4^SDWLMSG
+12 DO EN5
+13 QUIT
EN5 ;PCMM Position inactivated
+1 SET (IEN,PIEN,POS,POSN,STATUS,WLOPEN,SDWLPOS,SDFORM,TEAM)=""
+2 SET SDWLPOS=""
FOR
SET IEN=$ORDER(^SDWL(409.3,"SP",IEN))
if IEN<1
QUIT
Begin DoDot:1
+3 SET POS=""
FOR
SET POS=$ORDER(^SDWL(409.3,"SP",IEN,POS))
if POS<1
QUIT
Begin DoDot:2
+4 SET WLOPEN=$$GET1^DIQ(409.3,IEN_",",23,"I")
+5 if WLOPEN="C"
QUIT
+6 SET PIEN=""
SET PIEN=$ORDER(^SCTM(404.59,"B",POS,PIEN),-1)
IF PIEN'=""
Begin DoDot:3
+7 SET POSN=$$GET1^DIQ(404.57,POS_",",.01)
+8 IF PIEN'=""
SET STATUS=$$GET1^DIQ(404.59,PIEN_",",.03,"I")
+9 if STATUS="1"
QUIT
+10 IF STATUS="0"
Begin DoDot:4
+11 if '$DATA(SDWLPOS(POS))
SET SDWLPOS(POS)=0
SET SDWLPOS(POS)=SDWLPOS(POS)+1
SET POSN=$EXTRACT(POSN,1,30)
+12 SET TEAM=$$GET1^DIQ(404.57,POS_",",.02)
SET TEAM=$EXTRACT(TEAM,1,25)
+13 SET SDFORM=$$FORM^SDFORM(POSN,32,TEAM,27,SDWLPOS(POS),21)
+14 SET ^TMP("SDWLQSC6",$JOB,POS)=SDFORM
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+15 IF $DATA(^TMP("SDWLQSC6",$JOB))
DO MESS5^SDWLMSG
+16 DO EN6
+17 QUIT
EN6 ;Date of Death
+1 SET (IEN,SDDFN,DIS,DOD,NAME)=""
+2 FOR
SET SDDFN=$ORDER(^SDWL(409.3,"B",SDDFN))
if SDDFN<1
QUIT
Begin DoDot:1
+3 SET IEN=""
FOR
SET IEN=$ORDER(^SDWL(409.3,"B",SDDFN,IEN))
if IEN<1
QUIT
Begin DoDot:2
+4 SET DIS=$$GET1^DIQ(409.3,IEN_",",21,"I")
IF DIS="D"
Begin DoDot:3
+5 SET DOD=$$GET1^DIQ(2,SDDFN_",",.351)
if DOD'=""
QUIT
Begin DoDot:4
+6 SET DIE="^SDWL(409.3,"
SET DA=IEN
SET DR="23////^S X=""O"""
DO ^DIE
+7 SET DR="19///@"
DO ^DIE
+8 SET DR="20///@"
DO ^DIE
+9 SET DR="21///@"
DO ^DIE
+10 SET DR="29////^S X=""DE"""
DO ^DIE
+11 SET NAME=$$GET1^DIQ(2,SDDFN_",",.01)
SET ^TMP("SDWLQSC7",$JOB,SDDFN)=NAME
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+12 IF $DATA(^TMP("SDWLQSC7",$JOB))
DO MESS6^SDWLMSG
+13 DO EN7
+14 QUIT
EN7 ;PCMM Team open slots
+1 SET (IEN,TIEN,TEAMN,CC,WLOPEN,MAX,AVAL,SDFORM,TEAM,STATUS)=""
+2 FOR
SET TEAM=$ORDER(^SDWL(409.3,"D",TEAM))
if TEAM<1
QUIT
SET CC=0
Begin DoDot:1
+3 SET IEN=""
FOR
SET IEN=$ORDER(^SDWL(409.3,"D",TEAM,IEN))
if IEN<1
QUIT
SET WLOPEN=$$GET1^DIQ(409.3,IEN_",",23,"I")
Begin DoDot:2
+4 if WLOPEN="C"
QUIT
SET CC=CC+1
End DoDot:2
+5 IF CC>0
Begin DoDot:2
+6 SET TIEN=""
SET TIEN=$ORDER(^SCTM(404.58,"B",TEAM,TIEN),-1)
IF TIEN'=""
Begin DoDot:3
+7 SET STATUS=$$GET1^DIQ(404.58,TIEN_",",.03,"I")
+8 if STATUS="0"
QUIT
+9 SET MAX=$$GET1^DIQ(404.51,TEAM_",",.08)
+10 SET TEAMC=$$TEAMCNT^SCAPMCU1(TEAM,DT)
+11 if (TEAMC+.01)>MAX
QUIT
SET AVAL=MAX-TEAMC
SET TEAMN=$$GET1^DIQ(404.51,TEAM_",",.01)
+12 SET TEAMN=$EXTRACT(TEAMN,1,30)
SET SDFORM=$$FORM^SDFORM(TEAMN,35,AVAL,22,CC,12)
+13 SET ^TMP("SDWLQSC8",$JOB,TIEN)=SDFORM
End DoDot:3
End DoDot:2
End DoDot:1
+14 IF $DATA(^TMP("SDWLQSC8",$JOB))
Begin DoDot:1
+15 SET SDFORM=$$FORM^SDFORM("TEAM",35,"SLOTS AVAILIABLE",22,"EWL ENTRIES",12)
+16 SET ^TMP("SDWLQSC8",$JOB,.06)=SDFORM
+17 DO MESS7^SDWLMSG
End DoDot:1
+18 DO EN8
+19 QUIT
EN8 ;PCMM Position open slots
+1 SET (IEN,PIEN,POS,POSN,STATUS,WLOPEN,EDATE,SDWLPOS,SDWL,SDFORM)=""
KILL SDWLPOS
+2 SET SDWLPOS=""
FOR
SET IEN=$ORDER(^SDWL(409.3,"SP",IEN))
if IEN<1
QUIT
Begin DoDot:1
+3 SET POS=""
FOR
SET POS=$ORDER(^SDWL(409.3,"SP",IEN,POS))
if POS<1
QUIT
Begin DoDot:2
+4 SET PIEN=""
SET PIEN=$ORDER(^SCTM(404.59,"B",POS,PIEN),-1)
IF PIEN'=""
Begin DoDot:3
+5 SET STATUS=$$GET1^DIQ(404.59,PIEN_",",.03,"I")
+6 SET WLOPEN=$$GET1^DIQ(409.3,IEN_",",23,"I")
SET EDATE=$$GET1^DIQ(404.59,PIEN_",",.02,"I")
+7 if WLOPEN="C"
QUIT
+8 if ((EDATE+.01)<DT&(STATUS="0"))
QUIT
+9 if '$DATA(SDWLPOS(POS))
SET SDWLPOS(POS)=0
SET SDWLPOS(POS)=SDWLPOS(POS)+1
End DoDot:3
End DoDot:2
End DoDot:1
+10 SET (IEN,POS,POSN,MAX,AVAL,CC,TEAM)=""
+11 FOR
SET POS=$ORDER(SDWLPOS(POS))
if POS<1
QUIT
Begin DoDot:1
+12 SET MAX=$$GET1^DIQ(404.57,POS_",",.08)
SET SDWL=$$PCPOSCNT^SCAPMCU1(POS,DT)
+13 if (SDWL+.01)>MAX
QUIT
+14 SET TEAM=$$GET1^DIQ(404.57,POS_",",.02)
SET TEAM=$EXTRACT(TEAM,1,23)
+15 SET AVAL=MAX-SDWL
SET POSN=$$GET1^DIQ(404.57,POS_",",.01)
+16 SET POSN=$EXTRACT(POSN,1,23)
SET SDFORM=$$FORM^SDFORM(POSN,25,TEAM,25,AVAL,14,SDWLPOS(POS),11)
+17 SET ^TMP("SDWLQSC9",$JOB,POS)=SDFORM
End DoDot:1
+18 IF $DATA(^TMP("SDWLQSC9",$JOB))
Begin DoDot:1
+19 SET SDFORM=$$FORM^SDFORM("POSITION",25,"TEAM",25,"SLOTS AVAIL",14,"EWL ENTRIES",11)
+20 SET ^TMP("SDWLQSC9",$JOB,.06)=SDFORM
+21 DO MESS8^SDWLMSG
End DoDot:1
+22 QUIT
