- 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 Feb 19, 2025@00:29:31 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
