DVBAVRX2 ;ALB/GAK - CAPRI BACKGROUND JOB1 FOR VOCREHAB ;06/21/2012 12:00pm
;;2.7;AMIE;**181**;Apr 10, 1995;Build 38
;
Q ;NO DIRECT ENTRY
;
JOB1 ;PROCESS NEW REQUESTS AND SEND MAILMAN MESSAGES FOR AGED REQUESTS
;
N %H,X,Y,%Y,DAT
N DVBADAT,DVBAIEN
N DVBAFARY ;FORM ARRAY FOR GETS
N DVBAFERR ;FORM ARRAY ERROR ARRAY
N DVBAPOC,DVBARDAT,DVBAPNAM,DVBAPDFN,DVBAPSSN,DVBAPSDT,DVBASNTL
N DVBAOK ;OKAY TO PASS PII TO MAILMAN MESSAGE
N DVBAGERR ;GET1 ERROR ARRAY
N DVBAXIEN ;WORKING VARIABLE TO ADD "," TO END OF IEN FOR GETS/GET1
N DVBAVRRA ;DVBA VOCREHAB REQUESTOR EMAIL ADDRESS FROM #200,.151 - EXCHANGE EMAIL ADDRESS
N DVBATD ;TODAY
N DVBATAG ;TEST AGE
N DVBASWSD ;SWITCH FOR DATE (0 OR 1)
N DVBAFARY,ERROR ;FORM ARRAY
N DATENG ;DATE IN ENGLISH
N DVBADOW ;DAY OF WEEK
N DVBAAGE,DVBAXAGE
N DVBAEMA ;WORKING VARIABLE FOR EMAIL ADDRESS
N DVBARPTD ;REPORT FORMAT DATE AND TIME
N MAILSUBLN
;
S (%H,DAT)=+$H D YMD^%DTC ; CONVERT $H TO FILEMAN DATE
S DVBATD=X
F DVBAXAGE=5,6,7 D
. K DVBAAGE
. ;BUILD AGE ARRAY
. D WWDA(DVBATD,DVBAXAGE)
. S J="" F S J=$O(DVBAAGE(J)) Q:J="" D
.. S DVBASWSD=0
.. S DVBADAT=$P(DVBAAGE(J),"^",2)_".0000001"
.. F S DVBADAT=$O(^DVB(396.9,"ARSDT","N",DVBADAT)) Q:DVBADAT=""!(DVBASWSD=1) D
... S DVBATAG=$P(DVBADAT,".",1) I DVBATAG'=$P(DVBAAGE(J),"^",2) S DVBASWSD=1 Q
... S DVBAIEN="" F S DVBAIEN=$O(^DVB(396.9,"ARSDT","N",DVBADAT,DVBAIEN)) Q:DVBAIEN="" D
.... K DVBAFARY,DVBAFERR
.... K DVBAPOC,DVBARDAT,DVBAPNAM,DVBAPDFN,DVBAPSSN,DVBAPSDT,DVBAOK
.... S DVBAOK=0
.... D GETS^DIQ(396.9,DVBAIEN_",","*","IE","DVBAFARY","DVBAFERR")
.... ;
.... S DVBASNTL=$G(DVBAFARY(396.9,DVBAIEN_",",1,"E")) ;SEND TO LOCATION
.... S DVBAPOC=$G(DVBAFARY(396.9,DVBAIEN_",",11,"I")) ;POINT OF CONTACT IEN
.... S DVBARDAT=$G(DVBAFARY(396.9,DVBAIEN_",",.01,"E")) ;REQUEST DATE
.... S DVBAPNAM=$G(DVBAFARY(396.9,DVBAIEN_",",4,"E")) ;PATIENT NAME
.... S DVBAPDFN=$G(DVBAFARY(396.9,DVBAIEN_",",4,"I")) ;PATIENT DFN
.... ;ICR# FOR #2;.09 - no IA needed for this file
.... S DVBAPSDT=DVBAFARY(396.9,DVBAIEN_",",9,"E") ;PREFERRED SCHEDULE DATE [2;3] [D]
.... S MAILSUBLN="VOC REHAB REQUEST IS NOW "_DVBAXAGE_" DAYS OLD"
.... I DVBAXAGE=5!(DVBAXAGE=6) D
..... S DVBAOK=1
..... S DVBAEMA="G.DVBA VR VOCREHAB PERSONNEL"
..... D NFYAGE
..... ;
.... I DVBAXAGE=7 D
..... ;ICR# (10060) FOR #200;.151 - no IA needed for this file
..... S DVBAXIEN=DVBAIEN_","
..... S DVBAVRRA=$$GET1^DIQ(200,DVBAFARY(396.9,DVBAXIEN,11,"I"),.151,"","","DVBAGERR")
..... I $D(DVBAGERR) Q
..... Q:DVBAVRRA=""
..... S DVBAEMA=DVBAVRRA
..... D NFYAGE
;
Q
;
NFYAGE ;SETUP MAILMAN MESSAGE BASED ON JOB1 VARIABLES
;
Q:DVBAEMA=""
N XMSUB,XMTEXT,XMY,XMDUZ,XMDUN,XMZ,XMMG
N DVBAMMT ;MAILMAN MESSAGE TEXT ARRAY
N DVBASTT ;START TIME STAMP
N C,D,D0,DA,DI,DIC,DIE,DILOCKTM,DISYS,DQ,DR,X,Y,%
;
S %H=$H D YX^%DTC S X=X_% S DVBASTT=$$FMTE^XLFDT(X,"5FPZ")
S XMDUZ="VOCREHAB POSTMASTER"
S XMSUB="Chapter 31 Referral for Medical Services has aged "_DVBAXAGE_" days"
S XMY(DVBAEMA)=""
S XMTEXT="DVBAMMT("
S DVBAMMT(1)="Sent: "_DVBASTT
S DVBAMMT(2)="To: "_DVBAEMA
S DVBAMMT(3)="Subject: "_XMSUB
S DVBAMMT(4)=""
S DVBAMMT(5)=" REQUEST DATE: "_DVBARDAT
S DVBAMMT(6)=" PATIENT DFN: `"_DVBAPDFN
S DVBAMMT(7)=" PREFERRED SCHEDULE DATE: "_DVBAPSDT
S DVBAMMT(7.5)=""
S DVBAMMT(8)="THE 'NEW' STATUS ON THIS FORM 28-8861 HAS NOW AGED "_DVBAXAGE_" DAYS"
S DVBAMMT(9)="PLEASE MAKE SURE PATIENT HAS CONSULT LINKED TO FORM."
S DVBAMMT(10)=""
S DVBAMMT(11)="**NOTE: To view the patient using the DFN, paste the DFN number into the"
S DVBAMMT(12)="CAPRI Patient Selector 'Patient ID' field to find the patient. Be sure to"
S DVBAMMT(13)="include the ' (backward-apostrophe) character."
;
D XMZ^XMA2
D ^XMD
;
Q
;
WWDA(DVBATD,DVBAXAGE)
;
;WORK WEEK DAY AGING
; RETURNS THE DATES TO WRITE EMAILS FOR
; DVBATD TODAY IS THE DATE THE FUNCTION IS RUNNING FOR
; DVBAAGE AGE IS THE NUMBER OF DAYS TO AGE FOR (5, 6, OR 7) ONLY
; SPECIAL DAYS OF THE WEEK ARE MON, FRIDAY, AND TUESDAY
;
;IS DAT A WEEKEND DAY?
;
;S DVBAAGE(5)="" ; MON=MON, TUE=TUE, ...
; ; FRIDAY LOOKS FOR ALL SAT AND SUN FORM 8861 ENTRIES 5 DAYS OLD
;S DVBAAGE(6)="" ; MON=FRI, TUE=MON, WED=TUE, THR=WED, FRI=THR
; ; MONDAY LOOKS FOR ALL SAT AND SUN FORM 8861 ENTRIES 6 DAYS OLD
;S DVBAAGE(7)="" ; MON=THR, TUE=FRI, WED=MON, THR=TUE, FRI=WED
; ; TUESDAY LOOKS FOR ALL SAT AND SUN FORM 8861 ENTRIES 7 DAYS OLD
;
N %Y,X,X1,X2
N J,DVBADOW
K DVBAAGE
;
S X=DVBATD
;RETURN TODAY'S DAY OF THE WEEK (0-6)/(SUN - SAT)
D DW^%DTC
S DVBADOW=%Y
;
;DO NOT RUN ON DOW 0 OR 6
I DVBADOW=0!(DVBADOW=6) Q ""
;
I DVBADOW=1&(DVBAXAGE=5) S DVBAAGE("MON")=-7
I DVBADOW=1&(DVBAXAGE=6) S DVBAAGE("FRI")=-10
I DVBADOW=1&(DVBAXAGE=6) S DVBAAGE("SAT")=-9
I DVBADOW=1&(DVBAXAGE=6) S DVBAAGE("SUN")=-8
I DVBADOW=1&(DVBAXAGE=7) S DVBAAGE("THR")=-11
;
I DVBADOW=2&(DVBAXAGE=5) S DVBAAGE("TUE")=-7
I DVBADOW=2&(DVBAXAGE=6) S DVBAAGE("MON")=-8
I DVBADOW=2&(DVBAXAGE=7) S DVBAAGE("FRI")=-11
I DVBADOW=2&(DVBAXAGE=7) S DVBAAGE("SAT")=-10
I DVBADOW=2&(DVBAXAGE=7) S DVBAAGE("SUN")=-9
;
I DVBADOW=3&(DVBAXAGE=5) S DVBAAGE("WED")=-7
I DVBADOW=3&(DVBAXAGE=6) S DVBAAGE("TUE")=-8
I DVBADOW=3&(DVBAXAGE=7) S DVBAAGE("MON")=-9
;
I DVBADOW=4&(DVBAXAGE=5) S DVBAAGE("THR")=-7
I DVBADOW=4&(DVBAXAGE=6) S DVBAAGE("WED")=-8
I DVBADOW=4&(DVBAXAGE=7) S DVBAAGE("TUE")=-9
;
I DVBADOW=5&(DVBAXAGE=5) S DVBAAGE("FRI")=-7
I DVBADOW=5&(DVBAXAGE=5) S DVBAAGE("SAT")=-6
I DVBADOW=5&(DVBAXAGE=5) S DVBAAGE("SUN")=-5
I DVBADOW=5&(DVBAXAGE=6) S DVBAAGE("THR")=-8
I DVBADOW=5&(DVBAXAGE=7) S DVBAAGE("WED")=-9
;
S J="" F S J=$O(DVBAAGE(J)) Q:J="" D
. S X1=DVBATD
. S X2=DVBAAGE(J)
. D C^%DTC
. S $P(DVBAAGE(J),"^",2)=X
;
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBAVRX2 6019 printed Oct 16, 2024@17:43:19 Page 2
DVBAVRX2 ;ALB/GAK - CAPRI BACKGROUND JOB1 FOR VOCREHAB ;06/21/2012 12:00pm
+1 ;;2.7;AMIE;**181**;Apr 10, 1995;Build 38
+2 ;
+3 ;NO DIRECT ENTRY
QUIT
+4 ;
JOB1 ;PROCESS NEW REQUESTS AND SEND MAILMAN MESSAGES FOR AGED REQUESTS
+1 ;
+2 NEW %H,X,Y,%Y,DAT
+3 NEW DVBADAT,DVBAIEN
+4 ;FORM ARRAY FOR GETS
NEW DVBAFARY
+5 ;FORM ARRAY ERROR ARRAY
NEW DVBAFERR
+6 NEW DVBAPOC,DVBARDAT,DVBAPNAM,DVBAPDFN,DVBAPSSN,DVBAPSDT,DVBASNTL
+7 ;OKAY TO PASS PII TO MAILMAN MESSAGE
NEW DVBAOK
+8 ;GET1 ERROR ARRAY
NEW DVBAGERR
+9 ;WORKING VARIABLE TO ADD "," TO END OF IEN FOR GETS/GET1
NEW DVBAXIEN
+10 ;DVBA VOCREHAB REQUESTOR EMAIL ADDRESS FROM #200,.151 - EXCHANGE EMAIL ADDRESS
NEW DVBAVRRA
+11 ;TODAY
NEW DVBATD
+12 ;TEST AGE
NEW DVBATAG
+13 ;SWITCH FOR DATE (0 OR 1)
NEW DVBASWSD
+14 ;FORM ARRAY
NEW DVBAFARY,ERROR
+15 ;DATE IN ENGLISH
NEW DATENG
+16 ;DAY OF WEEK
NEW DVBADOW
+17 NEW DVBAAGE,DVBAXAGE
+18 ;WORKING VARIABLE FOR EMAIL ADDRESS
NEW DVBAEMA
+19 ;REPORT FORMAT DATE AND TIME
NEW DVBARPTD
+20 NEW MAILSUBLN
+21 ;
+22 ; CONVERT $H TO FILEMAN DATE
SET (%H,DAT)=+$HOROLOG
DO YMD^%DTC
+23 SET DVBATD=X
+24 FOR DVBAXAGE=5,6,7
Begin DoDot:1
+25 KILL DVBAAGE
+26 ;BUILD AGE ARRAY
+27 DO WWDA(DVBATD,DVBAXAGE)
+28 SET J=""
FOR
SET J=$ORDER(DVBAAGE(J))
if J=""
QUIT
Begin DoDot:2
+29 SET DVBASWSD=0
+30 SET DVBADAT=$PIECE(DVBAAGE(J),"^",2)_".0000001"
+31 FOR
SET DVBADAT=$ORDER(^DVB(396.9,"ARSDT","N",DVBADAT))
if DVBADAT=""!(DVBASWSD=1)
QUIT
Begin DoDot:3
+32 SET DVBATAG=$PIECE(DVBADAT,".",1)
IF DVBATAG'=$PIECE(DVBAAGE(J),"^",2)
SET DVBASWSD=1
QUIT
+33 SET DVBAIEN=""
FOR
SET DVBAIEN=$ORDER(^DVB(396.9,"ARSDT","N",DVBADAT,DVBAIEN))
if DVBAIEN=""
QUIT
Begin DoDot:4
+34 KILL DVBAFARY,DVBAFERR
+35 KILL DVBAPOC,DVBARDAT,DVBAPNAM,DVBAPDFN,DVBAPSSN,DVBAPSDT,DVBAOK
+36 SET DVBAOK=0
+37 DO GETS^DIQ(396.9,DVBAIEN_",","*","IE","DVBAFARY","DVBAFERR")
+38 ;
+39 ;SEND TO LOCATION
SET DVBASNTL=$GET(DVBAFARY(396.9,DVBAIEN_",",1,"E"))
+40 ;POINT OF CONTACT IEN
SET DVBAPOC=$GET(DVBAFARY(396.9,DVBAIEN_",",11,"I"))
+41 ;REQUEST DATE
SET DVBARDAT=$GET(DVBAFARY(396.9,DVBAIEN_",",.01,"E"))
+42 ;PATIENT NAME
SET DVBAPNAM=$GET(DVBAFARY(396.9,DVBAIEN_",",4,"E"))
+43 ;PATIENT DFN
SET DVBAPDFN=$GET(DVBAFARY(396.9,DVBAIEN_",",4,"I"))
+44 ;ICR# FOR #2;.09 - no IA needed for this file
+45 ;PREFERRED SCHEDULE DATE [2;3] [D]
SET DVBAPSDT=DVBAFARY(396.9,DVBAIEN_",",9,"E")
+46 SET MAILSUBLN="VOC REHAB REQUEST IS NOW "_DVBAXAGE_" DAYS OLD"
+47 IF DVBAXAGE=5!(DVBAXAGE=6)
Begin DoDot:5
+48 SET DVBAOK=1
+49 SET DVBAEMA="G.DVBA VR VOCREHAB PERSONNEL"
+50 DO NFYAGE
+51 ;
End DoDot:5
+52 IF DVBAXAGE=7
Begin DoDot:5
+53 ;ICR# (10060) FOR #200;.151 - no IA needed for this file
+54 SET DVBAXIEN=DVBAIEN_","
+55 SET DVBAVRRA=$$GET1^DIQ(200,DVBAFARY(396.9,DVBAXIEN,11,"I"),.151,"","","DVBAGERR")
+56 IF $DATA(DVBAGERR)
QUIT
+57 if DVBAVRRA=""
QUIT
+58 SET DVBAEMA=DVBAVRRA
+59 DO NFYAGE
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+60 ;
+61 QUIT
+62 ;
NFYAGE ;SETUP MAILMAN MESSAGE BASED ON JOB1 VARIABLES
+1 ;
+2 if DVBAEMA=""
QUIT
+3 NEW XMSUB,XMTEXT,XMY,XMDUZ,XMDUN,XMZ,XMMG
+4 ;MAILMAN MESSAGE TEXT ARRAY
NEW DVBAMMT
+5 ;START TIME STAMP
NEW DVBASTT
+6 NEW C,D,D0,DA,DI,DIC,DIE,DILOCKTM,DISYS,DQ,DR,X,Y,%
+7 ;
+8 SET %H=$HOROLOG
DO YX^%DTC
SET X=X_%
SET DVBASTT=$$FMTE^XLFDT(X,"5FPZ")
+9 SET XMDUZ="VOCREHAB POSTMASTER"
+10 SET XMSUB="Chapter 31 Referral for Medical Services has aged "_DVBAXAGE_" days"
+11 SET XMY(DVBAEMA)=""
+12 SET XMTEXT="DVBAMMT("
+13 SET DVBAMMT(1)="Sent: "_DVBASTT
+14 SET DVBAMMT(2)="To: "_DVBAEMA
+15 SET DVBAMMT(3)="Subject: "_XMSUB
+16 SET DVBAMMT(4)=""
+17 SET DVBAMMT(5)=" REQUEST DATE: "_DVBARDAT
+18 SET DVBAMMT(6)=" PATIENT DFN: `"_DVBAPDFN
+19 SET DVBAMMT(7)=" PREFERRED SCHEDULE DATE: "_DVBAPSDT
+20 SET DVBAMMT(7.5)=""
+21 SET DVBAMMT(8)="THE 'NEW' STATUS ON THIS FORM 28-8861 HAS NOW AGED "_DVBAXAGE_" DAYS"
+22 SET DVBAMMT(9)="PLEASE MAKE SURE PATIENT HAS CONSULT LINKED TO FORM."
+23 SET DVBAMMT(10)=""
+24 SET DVBAMMT(11)="**NOTE: To view the patient using the DFN, paste the DFN number into the"
+25 SET DVBAMMT(12)="CAPRI Patient Selector 'Patient ID' field to find the patient. Be sure to"
+26 SET DVBAMMT(13)="include the ' (backward-apostrophe) character."
+27 ;
+28 DO XMZ^XMA2
+29 DO ^XMD
+30 ;
+31 QUIT
+32 ;
WWDA(DVBATD,DVBAXAGE) +1 ;
+2 ;WORK WEEK DAY AGING
+3 ; RETURNS THE DATES TO WRITE EMAILS FOR
+4 ; DVBATD TODAY IS THE DATE THE FUNCTION IS RUNNING FOR
+5 ; DVBAAGE AGE IS THE NUMBER OF DAYS TO AGE FOR (5, 6, OR 7) ONLY
+6 ; SPECIAL DAYS OF THE WEEK ARE MON, FRIDAY, AND TUESDAY
+7 ;
+8 ;IS DAT A WEEKEND DAY?
+9 ;
+10 ;S DVBAAGE(5)="" ; MON=MON, TUE=TUE, ...
+11 ; ; FRIDAY LOOKS FOR ALL SAT AND SUN FORM 8861 ENTRIES 5 DAYS OLD
+12 ;S DVBAAGE(6)="" ; MON=FRI, TUE=MON, WED=TUE, THR=WED, FRI=THR
+13 ; ; MONDAY LOOKS FOR ALL SAT AND SUN FORM 8861 ENTRIES 6 DAYS OLD
+14 ;S DVBAAGE(7)="" ; MON=THR, TUE=FRI, WED=MON, THR=TUE, FRI=WED
+15 ; ; TUESDAY LOOKS FOR ALL SAT AND SUN FORM 8861 ENTRIES 7 DAYS OLD
+16 ;
+17 NEW %Y,X,X1,X2
+18 NEW J,DVBADOW
+19 KILL DVBAAGE
+20 ;
+21 SET X=DVBATD
+22 ;RETURN TODAY'S DAY OF THE WEEK (0-6)/(SUN - SAT)
+23 DO DW^%DTC
+24 SET DVBADOW=%Y
+25 ;
+26 ;DO NOT RUN ON DOW 0 OR 6
+27 IF DVBADOW=0!(DVBADOW=6)
QUIT ""
+28 ;
+29 IF DVBADOW=1&(DVBAXAGE=5)
SET DVBAAGE("MON")=-7
+30 IF DVBADOW=1&(DVBAXAGE=6)
SET DVBAAGE("FRI")=-10
+31 IF DVBADOW=1&(DVBAXAGE=6)
SET DVBAAGE("SAT")=-9
+32 IF DVBADOW=1&(DVBAXAGE=6)
SET DVBAAGE("SUN")=-8
+33 IF DVBADOW=1&(DVBAXAGE=7)
SET DVBAAGE("THR")=-11
+34 ;
+35 IF DVBADOW=2&(DVBAXAGE=5)
SET DVBAAGE("TUE")=-7
+36 IF DVBADOW=2&(DVBAXAGE=6)
SET DVBAAGE("MON")=-8
+37 IF DVBADOW=2&(DVBAXAGE=7)
SET DVBAAGE("FRI")=-11
+38 IF DVBADOW=2&(DVBAXAGE=7)
SET DVBAAGE("SAT")=-10
+39 IF DVBADOW=2&(DVBAXAGE=7)
SET DVBAAGE("SUN")=-9
+40 ;
+41 IF DVBADOW=3&(DVBAXAGE=5)
SET DVBAAGE("WED")=-7
+42 IF DVBADOW=3&(DVBAXAGE=6)
SET DVBAAGE("TUE")=-8
+43 IF DVBADOW=3&(DVBAXAGE=7)
SET DVBAAGE("MON")=-9
+44 ;
+45 IF DVBADOW=4&(DVBAXAGE=5)
SET DVBAAGE("THR")=-7
+46 IF DVBADOW=4&(DVBAXAGE=6)
SET DVBAAGE("WED")=-8
+47 IF DVBADOW=4&(DVBAXAGE=7)
SET DVBAAGE("TUE")=-9
+48 ;
+49 IF DVBADOW=5&(DVBAXAGE=5)
SET DVBAAGE("FRI")=-7
+50 IF DVBADOW=5&(DVBAXAGE=5)
SET DVBAAGE("SAT")=-6
+51 IF DVBADOW=5&(DVBAXAGE=5)
SET DVBAAGE("SUN")=-5
+52 IF DVBADOW=5&(DVBAXAGE=6)
SET DVBAAGE("THR")=-8
+53 IF DVBADOW=5&(DVBAXAGE=7)
SET DVBAAGE("WED")=-9
+54 ;
+55 SET J=""
FOR
SET J=$ORDER(DVBAAGE(J))
if J=""
QUIT
Begin DoDot:1
+56 SET X1=DVBATD
+57 SET X2=DVBAAGE(J)
+58 DO C^%DTC
+59 SET $PIECE(DVBAAGE(J),"^",2)=X
End DoDot:1
+60 ;
+61 QUIT
+62 ;
