DGPREBJ1 ;ALB/SCK/EG/PC - PreRegistration Background job cont. ;Jul 25, 2019@14:53
;;5.3;Registration;**109,568,585,980**;Aug 13, 1993;Build 4
Q
;
EN ; Interactive entry (from option)
; Variables
; DGPTOD - Todays date from DT
; DGPNL - No. of lines in message array
; DGPTXT - Message array from ADDNEW procedure
; DGPP - Default date to look for appointments
; I1,X1-2 - Local variables for counters and date manipulation
;
I '$D(^XUSEC("DGPRE SUPV",DUZ)) D G ENQ
. W !!,"You do not have the DG PREREGISTRATION Key allocated, contact your MAS ADPAC."
;
N DGPDT,DGPTOD,DGPNL,DGPTXT,DGPP,I1,X,X1,X2,Y
S X1=$P($$NOW^XLFDT,"."),X2=$P($G(^DG(43,1,"DGPRE")),U,5) S:X2']"" X2=14
S DGPP=$$FMADD^XLFDT(X1,X2)
S DIR("B")=$$FMTE^XLFDT(DGPP,1)
S DIR(0)="DA^::EX",DIR("A")="Enter Appointment date to search: "
D ^DIR K DIR
G:$D(DIRUT) ENQ
S DGPNL=0,DGPTOD=DT,DGPDT1=Y
D WAIT^DICD
D SDAMAPI(1,DGPDT1)
D ADDNEW(1,DGPDT1)
I $D(DGPTXT) W !!,"Results of updating the Call List with new entries",!
S I1=0 F S I1=$O(DGPTXT(I1)) Q:'I1 W !,DGPTXT(I1)
ENQ K DIRUT,DUOUT,DTOUT,DIROUT,DGARRAY,SCDNT,^TMP($J,"SDAMA301")
Q
;
ADDNEW(DGPREI,DGPDT1) ; Searches for appointments to add to the Call List
; Variables
; Input:
; DGPREI - Flag indicating how the procedure was called.
; 0 - called by background job
; 1 - called by option (interactive)
; DGPDT1 - Date to look for appointments, Required when
; DGPREI = 1
;
; DGPDW - Day of the week
; DGPNDY - Number of days ahead to look for appt.
; DGPDT - Date to look for appt. ( DT + DGPNDY)
; DGPTOT - Counter, total records scanned
; DGPPT - Pointer to patient file, #2
; DGPTDTH - Counter for patient alias's found
; DGPEXCL - Exclude flag
; DGPTCE - Counter of appts. excluded because of clinic
; DGPTPE - Counter of appts. excluded because of eligibility
; DGPINP - counter of appts. excluded because of inpatient
; DGPTNC - Counter of appts. excluded because next appt. is within
; DAYS BETWEEN CALLS entry in the MAS PARAMETER File
; DGPADD - Counter, entries added to call list
; DGPAPT - Date and time off appointment
; DGPPRDT - Date pre-registration audit file last updated for patient
; DGPNDTW - DAYS BETWEEN CALLS value
; DGPSV - Medical Service code
; DGPPN - Patients Name
; DGPPH - Patients Phone number
; DGPSN - Patients last four
; DGPN1-5 - Temporary variables for $O
;
; Check for Appointment Database Availability
;if there is no lower level data from the 101 subscript, then it
;really is a valid error, otherwise, it could be a patient
;or clinic eg 01/20/2005
I $D(^TMP($J,"SDAMA301")) I $D(^TMP($J,"SDAMA301",101))=1 D SETTEXT^DGPREBJ("SDAMAPI - Appointment Database is Unavailable."),SETTEXT^DGPREBJ("Unable to update Call List.") Q
;
N DGPADD,DGPTOT,DGPTCE,DGPTPE,DGPTNC,DGPTDTH,DGPINP,DGPUPD,DGPN1,DGPAPT
N DGPPH,DGPDW,DGPPT,DGPPRDT,DGPNDTW,DGPN5,DGPEXCL,CKAPDT
S (DGPADD,DGPTOT,DGPTCE,DGPTPE,DGPTNC,DGPTDTH,DGPINP,DGPUPD)=0
S DGPN1=0 F S DGPN1=$O(^TMP($J,"SDAMA301",DGPN1)) Q:'DGPN1 D
.S DGPPT=0 F S DGPPT=$O(^TMP($J,"SDAMA301",DGPN1,DGPPT)) Q:'DGPPT D
..S CKAPDT=+$O(^TMP($J,"SDAMA301",DGPN1,DGPPT,DGPDT1))
..Q:('CKAPDT!(CKAPDT>$$FMADD^XLFDT(DGPDT1,1)))
..S DGPTOT=DGPTOT+1
..I $P($G(^DPT(DGPPT,.35)),U)]"" S DGPTDTH=DGPTDTH+1 Q
..; *** Check for clinic exclusions in MAS PARAMETER File
..S (DGPN5,DGPEXCL)=0
..F S DGPN5=$O(^DG(43,1,"DGPREC",DGPN5)) Q:'DGPN5!(DGPEXCL) D
...S:$P(^DG(43,1,"DGPREC",DGPN5,0),U)=DGPN1 DGPEXCL=1
..I DGPEXCL S DGPTCE=DGPTCE+1 Q
..; *** Check for eligibility exclusions inthe MAS PARAMETER File
..N DGPAELG S (DGPN5,DGPEXCL)=0
..F S DGPN5=$O(^DG(43,1,"DGPREE",DGPN5)) Q:'DGPN5!(DGPEXCL) D
...S DGPAELG=$P($G(^DPT(DGPPT,.36)),U)
...S:$P(^DG(43,1,"DGPREE",DGPN5,0),U)=DGPAELG DGPEXCL=1
..I DGPEXCL S DGPTPE=DGPTPE+1 Q
..; *** Check for inpatient status
..K DFN S DFN=DGPPT D INP^VADPT
..I $G(VAIN(1))]"" S DGPINP=DGPINP+1 Q
..; *** Check for last update in Pre-Registration Audit file
..S DGPPRDT=DGPTOD+.9999,DGPPRDT=$O(^DGS(41.41,"ADC",DGPPT,DGPPRDT),-1)
..S DGPNDTW=$P($G(^DG(43,1,"DGPRE")),U,2)
..I DGPPRDT]""&(DGPNDTW]"") I $$FMDIFF^XLFDT(DGPDT,DGPPRDT,1)<DGPNDTW S DGPTNC=DGPTNC+1 Q
..; *** Set up entries for adding to Pre-Registration Call List file
..K DFN S DFN=DGPPT D DEM^VADPT
..S DGPPH=$P($P($G(^DPT(DGPPT,.13)),U),"~")
..I DGPPH=""!(DGPPH["NO") D
...S DGPPH=$P($G(^DPT(DGPPT,.33)),U,9)
...I DGPPH]"" S DGPPH=$P(DGPPH,"~")_"(E)"
... E S DGPPH="NO PHONE"
..;
..I '$D(^DGS(41.42,"B",DFN)) D
...K DD,DO S DIC="^DGS(41.42,",DIC(0)="ML"
...S X=DFN,DGPAPT=$O(^TMP($J,"SDAMA301",DGPN1,X,DGPDT1))
...S DIC("DR")=$P($T(FIELDS),";;",2)
...D FILE^DICN
...S DGPADD=DGPADD+1
..E D
...S DA="",DA=$O(^DGS(41.42,"B",DFN,DA),-1)
...Q:$P($G(^DGS(41.42,DA,0)),U,6)="Y"
...S DIE="^DGS(41.42,"
...S DGPAPT=$O(^TMP($J,"SDAMA301",DGPN1,DGPPT,DGPDT1))
...S DR=$P($T(FIELDS),";;",2)
...D ^DIE
...S DGPUPD=DGPUPD+1
..K DA,DR,DIE,DIC,VADM,VA,DFN,VAERR,VAIN
;
D SETTEXT^DGPREBJ(" Total Entries Scanned: "_DGPTOT)
D SETTEXT^DGPREBJ(" Called within Time Window: "_DGPTNC)
D SETTEXT^DGPREBJ(" Inpatients: "_DGPINP)
D SETTEXT^DGPREBJ(" Exclusions by Clinic: "_DGPTCE)
D SETTEXT^DGPREBJ(" Exclusions by Eligibility: "_DGPTPE)
D SETTEXT^DGPREBJ(" Exclusion for Death: "_DGPTDTH)
D SETTEXT^DGPREBJ(" ")
D SETTEXT^DGPREBJ(" Total Entries Added to Call List: "_DGPADD)
D SETTEXT^DGPREBJ("Total Entries Updated with New Appt.: "_DGPUPD)
D SETTEXT^DGPREBJ(" ")
EXIT ;
Q
SDAMAPI(DGPREI,DGPDT1) ;
; Input: DGPDT1 - Date to look for appointments
;
N DGPNDY S DGPNDY=$P($G(^DG(43,1,"DGPRE")),U,5)
I DGPNDY']"" D G EXIT
. W:DGPREI !!,$P($T(MSG1),";;",2)
. D:'DGPREI SETTEXT^DGPREBJ($P($T(MSG1),";;",2)),SETTEXT^DGPREBJ(" ")
;
I DGPREI S DGPDT=DGPDT1
E S DGPDT=$$FMADD^XLFDT(DT,DGPNDY)
;eg 01/18/2005 if coming from night job tax ('DGPREI)
;and end date (DGPDT) is on a weekend, and the parameter
;says to not run on weekend, it will never go find appointments
S DGPDW=$S(DGPREI:$$DOW^XLFDT(DGPDT),1:$$DOW^XLFDT(DT))
I $P($G(^DG(43,1,"DGPRE")),U,6)'=1&((DGPDW=6)!(DGPDW=0)) D G EXIT
. W:DGPREI !!,$P($T(MSG2),";;",2)
. D:'DGPREI SETTEXT^DGPREBJ($P($T(MSG2),";;",2)),SETTEXT^DGPREBJ(" ")
D SETTEXT^DGPREBJ("Running: Add New Patients to Call List for "_$$FMTE^XLFDT(DGPDT,2)),SETTEXT^DGPREBJ(" ")
;
N DGARRAY,SDCNT
S:DGPREI DGARRAY(1)=DGPDT1_";"_DGPDT1
S:'DGPREI DGARRAY(1)=DT_";"_DGPDT
S DGARRAY("FLDS")=3,SDCNT=$$SDAPI^SDAMA301(.DGARRAY)
Q
; VSR patch DG*5.3.980 change four slashes to three slashes for validation. Changed field 5
FIELDS ;;.1///^S X=$P($G(^SC(DGPN1,0)),U,15);1///^S X=$E(VADM(1))_VA("BID");2///^S X=DGPPH;3///^S X=$G(DGPPRDT);5///^S X=DGPN1;6///^S X=DGPAPT;7///^S X=$P(^SC(DGPN1,0),U,8)
;
MSG1 ;;The 'DAYS TO PULL' is not filled in, unable to determine appointment date.
MSG2 ;;The call list is currently not being generated for weekends.
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPREBJ1 7306 printed Apr 09, 2024@21:43:40 Page 2
DGPREBJ1 ;ALB/SCK/EG/PC - PreRegistration Background job cont. ;Jul 25, 2019@14:53
+1 ;;5.3;Registration;**109,568,585,980**;Aug 13, 1993;Build 4
+2 QUIT
+3 ;
EN ; Interactive entry (from option)
+1 ; Variables
+2 ; DGPTOD - Todays date from DT
+3 ; DGPNL - No. of lines in message array
+4 ; DGPTXT - Message array from ADDNEW procedure
+5 ; DGPP - Default date to look for appointments
+6 ; I1,X1-2 - Local variables for counters and date manipulation
+7 ;
+8 IF '$DATA(^XUSEC("DGPRE SUPV",DUZ))
Begin DoDot:1
+9 WRITE !!,"You do not have the DG PREREGISTRATION Key allocated, contact your MAS ADPAC."
End DoDot:1
GOTO ENQ
+10 ;
+11 NEW DGPDT,DGPTOD,DGPNL,DGPTXT,DGPP,I1,X,X1,X2,Y
+12 SET X1=$PIECE($$NOW^XLFDT,".")
SET X2=$PIECE($GET(^DG(43,1,"DGPRE")),U,5)
if X2']""
SET X2=14
+13 SET DGPP=$$FMADD^XLFDT(X1,X2)
+14 SET DIR("B")=$$FMTE^XLFDT(DGPP,1)
+15 SET DIR(0)="DA^::EX"
SET DIR("A")="Enter Appointment date to search: "
+16 DO ^DIR
KILL DIR
+17 if $DATA(DIRUT)
GOTO ENQ
+18 SET DGPNL=0
SET DGPTOD=DT
SET DGPDT1=Y
+19 DO WAIT^DICD
+20 DO SDAMAPI(1,DGPDT1)
+21 DO ADDNEW(1,DGPDT1)
+22 IF $DATA(DGPTXT)
WRITE !!,"Results of updating the Call List with new entries",!
+23 SET I1=0
FOR
SET I1=$ORDER(DGPTXT(I1))
if 'I1
QUIT
WRITE !,DGPTXT(I1)
ENQ KILL DIRUT,DUOUT,DTOUT,DIROUT,DGARRAY,SCDNT,^TMP($JOB,"SDAMA301")
+1 QUIT
+2 ;
ADDNEW(DGPREI,DGPDT1) ; Searches for appointments to add to the Call List
+1 ; Variables
+2 ; Input:
+3 ; DGPREI - Flag indicating how the procedure was called.
+4 ; 0 - called by background job
+5 ; 1 - called by option (interactive)
+6 ; DGPDT1 - Date to look for appointments, Required when
+7 ; DGPREI = 1
+8 ;
+9 ; DGPDW - Day of the week
+10 ; DGPNDY - Number of days ahead to look for appt.
+11 ; DGPDT - Date to look for appt. ( DT + DGPNDY)
+12 ; DGPTOT - Counter, total records scanned
+13 ; DGPPT - Pointer to patient file, #2
+14 ; DGPTDTH - Counter for patient alias's found
+15 ; DGPEXCL - Exclude flag
+16 ; DGPTCE - Counter of appts. excluded because of clinic
+17 ; DGPTPE - Counter of appts. excluded because of eligibility
+18 ; DGPINP - counter of appts. excluded because of inpatient
+19 ; DGPTNC - Counter of appts. excluded because next appt. is within
+20 ; DAYS BETWEEN CALLS entry in the MAS PARAMETER File
+21 ; DGPADD - Counter, entries added to call list
+22 ; DGPAPT - Date and time off appointment
+23 ; DGPPRDT - Date pre-registration audit file last updated for patient
+24 ; DGPNDTW - DAYS BETWEEN CALLS value
+25 ; DGPSV - Medical Service code
+26 ; DGPPN - Patients Name
+27 ; DGPPH - Patients Phone number
+28 ; DGPSN - Patients last four
+29 ; DGPN1-5 - Temporary variables for $O
+30 ;
+31 ; Check for Appointment Database Availability
+32 ;if there is no lower level data from the 101 subscript, then it
+33 ;really is a valid error, otherwise, it could be a patient
+34 ;or clinic eg 01/20/2005
+35 IF $DATA(^TMP($JOB,"SDAMA301"))
IF $DATA(^TMP($JOB,"SDAMA301",101))=1
DO SETTEXT^DGPREBJ("SDAMAPI - Appointment Database is Unavailable.")
DO SETTEXT^DGPREBJ("Unable to update Call List.")
QUIT
+36 ;
+37 NEW DGPADD,DGPTOT,DGPTCE,DGPTPE,DGPTNC,DGPTDTH,DGPINP,DGPUPD,DGPN1,DGPAPT
+38 NEW DGPPH,DGPDW,DGPPT,DGPPRDT,DGPNDTW,DGPN5,DGPEXCL,CKAPDT
+39 SET (DGPADD,DGPTOT,DGPTCE,DGPTPE,DGPTNC,DGPTDTH,DGPINP,DGPUPD)=0
+40 SET DGPN1=0
FOR
SET DGPN1=$ORDER(^TMP($JOB,"SDAMA301",DGPN1))
if 'DGPN1
QUIT
Begin DoDot:1
+41 SET DGPPT=0
FOR
SET DGPPT=$ORDER(^TMP($JOB,"SDAMA301",DGPN1,DGPPT))
if 'DGPPT
QUIT
Begin DoDot:2
+42 SET CKAPDT=+$ORDER(^TMP($JOB,"SDAMA301",DGPN1,DGPPT,DGPDT1))
+43 if ('CKAPDT!(CKAPDT>$$FMADD^XLFDT(DGPDT1,1)))
QUIT
+44 SET DGPTOT=DGPTOT+1
+45 IF $PIECE($GET(^DPT(DGPPT,.35)),U)]""
SET DGPTDTH=DGPTDTH+1
QUIT
+46 ; *** Check for clinic exclusions in MAS PARAMETER File
+47 SET (DGPN5,DGPEXCL)=0
+48 FOR
SET DGPN5=$ORDER(^DG(43,1,"DGPREC",DGPN5))
if 'DGPN5!(DGPEXCL)
QUIT
Begin DoDot:3
+49 if $PIECE(^DG(43,1,"DGPREC",DGPN5,0),U)=DGPN1
SET DGPEXCL=1
End DoDot:3
+50 IF DGPEXCL
SET DGPTCE=DGPTCE+1
QUIT
+51 ; *** Check for eligibility exclusions inthe MAS PARAMETER File
+52 NEW DGPAELG
SET (DGPN5,DGPEXCL)=0
+53 FOR
SET DGPN5=$ORDER(^DG(43,1,"DGPREE",DGPN5))
if 'DGPN5!(DGPEXCL)
QUIT
Begin DoDot:3
+54 SET DGPAELG=$PIECE($GET(^DPT(DGPPT,.36)),U)
+55 if $PIECE(^DG(43,1,"DGPREE",DGPN5,0),U)=DGPAELG
SET DGPEXCL=1
End DoDot:3
+56 IF DGPEXCL
SET DGPTPE=DGPTPE+1
QUIT
+57 ; *** Check for inpatient status
+58 KILL DFN
SET DFN=DGPPT
DO INP^VADPT
+59 IF $GET(VAIN(1))]""
SET DGPINP=DGPINP+1
QUIT
+60 ; *** Check for last update in Pre-Registration Audit file
+61 SET DGPPRDT=DGPTOD+.9999
SET DGPPRDT=$ORDER(^DGS(41.41,"ADC",DGPPT,DGPPRDT),-1)
+62 SET DGPNDTW=$PIECE($GET(^DG(43,1,"DGPRE")),U,2)
+63 IF DGPPRDT]""&(DGPNDTW]"")
IF $$FMDIFF^XLFDT(DGPDT,DGPPRDT,1)<DGPNDTW
SET DGPTNC=DGPTNC+1
QUIT
+64 ; *** Set up entries for adding to Pre-Registration Call List file
+65 KILL DFN
SET DFN=DGPPT
DO DEM^VADPT
+66 SET DGPPH=$PIECE($PIECE($GET(^DPT(DGPPT,.13)),U),"~")
+67 IF DGPPH=""!(DGPPH["NO")
Begin DoDot:3
+68 SET DGPPH=$PIECE($GET(^DPT(DGPPT,.33)),U,9)
+69 IF DGPPH]""
SET DGPPH=$PIECE(DGPPH,"~")_"(E)"
+70 IF '$TEST
SET DGPPH="NO PHONE"
End DoDot:3
+71 ;
+72 IF '$DATA(^DGS(41.42,"B",DFN))
Begin DoDot:3
+73 KILL DD,DO
SET DIC="^DGS(41.42,"
SET DIC(0)="ML"
+74 SET X=DFN
SET DGPAPT=$ORDER(^TMP($JOB,"SDAMA301",DGPN1,X,DGPDT1))
+75 SET DIC("DR")=$PIECE($TEXT(FIELDS),";;",2)
+76 DO FILE^DICN
+77 SET DGPADD=DGPADD+1
End DoDot:3
+78 IF '$TEST
Begin DoDot:3
+79 SET DA=""
SET DA=$ORDER(^DGS(41.42,"B",DFN,DA),-1)
+80 if $PIECE($GET(^DGS(41.42,DA,0)),U,6)="Y"
QUIT
+81 SET DIE="^DGS(41.42,"
+82 SET DGPAPT=$ORDER(^TMP($JOB,"SDAMA301",DGPN1,DGPPT,DGPDT1))
+83 SET DR=$PIECE($TEXT(FIELDS),";;",2)
+84 DO ^DIE
+85 SET DGPUPD=DGPUPD+1
End DoDot:3
+86 KILL DA,DR,DIE,DIC,VADM,VA,DFN,VAERR,VAIN
End DoDot:2
End DoDot:1
+87 ;
+88 DO SETTEXT^DGPREBJ(" Total Entries Scanned: "_DGPTOT)
+89 DO SETTEXT^DGPREBJ(" Called within Time Window: "_DGPTNC)
+90 DO SETTEXT^DGPREBJ(" Inpatients: "_DGPINP)
+91 DO SETTEXT^DGPREBJ(" Exclusions by Clinic: "_DGPTCE)
+92 DO SETTEXT^DGPREBJ(" Exclusions by Eligibility: "_DGPTPE)
+93 DO SETTEXT^DGPREBJ(" Exclusion for Death: "_DGPTDTH)
+94 DO SETTEXT^DGPREBJ(" ")
+95 DO SETTEXT^DGPREBJ(" Total Entries Added to Call List: "_DGPADD)
+96 DO SETTEXT^DGPREBJ("Total Entries Updated with New Appt.: "_DGPUPD)
+97 DO SETTEXT^DGPREBJ(" ")
EXIT ;
+1 QUIT
SDAMAPI(DGPREI,DGPDT1) ;
+1 ; Input: DGPDT1 - Date to look for appointments
+2 ;
+3 NEW DGPNDY
SET DGPNDY=$PIECE($GET(^DG(43,1,"DGPRE")),U,5)
+4 IF DGPNDY']""
Begin DoDot:1
+5 if DGPREI
WRITE !!,$PIECE($TEXT(MSG1),";;",2)
+6 if 'DGPREI
DO SETTEXT^DGPREBJ($PIECE($TEXT(MSG1),";;",2))
DO SETTEXT^DGPREBJ(" ")
End DoDot:1
GOTO EXIT
+7 ;
+8 IF DGPREI
SET DGPDT=DGPDT1
+9 IF '$TEST
SET DGPDT=$$FMADD^XLFDT(DT,DGPNDY)
+10 ;eg 01/18/2005 if coming from night job tax ('DGPREI)
+11 ;and end date (DGPDT) is on a weekend, and the parameter
+12 ;says to not run on weekend, it will never go find appointments
+13 SET DGPDW=$SELECT(DGPREI:$$DOW^XLFDT(DGPDT),1:$$DOW^XLFDT(DT))
+14 IF $PIECE($GET(^DG(43,1,"DGPRE")),U,6)'=1&((DGPDW=6)!(DGPDW=0))
Begin DoDot:1
+15 if DGPREI
WRITE !!,$PIECE($TEXT(MSG2),";;",2)
+16 if 'DGPREI
DO SETTEXT^DGPREBJ($PIECE($TEXT(MSG2),";;",2))
DO SETTEXT^DGPREBJ(" ")
End DoDot:1
GOTO EXIT
+17 DO SETTEXT^DGPREBJ("Running: Add New Patients to Call List for "_$$FMTE^XLFDT(DGPDT,2))
DO SETTEXT^DGPREBJ(" ")
+18 ;
+19 NEW DGARRAY,SDCNT
+20 if DGPREI
SET DGARRAY(1)=DGPDT1_";"_DGPDT1
+21 if 'DGPREI
SET DGARRAY(1)=DT_";"_DGPDT
+22 SET DGARRAY("FLDS")=3
SET SDCNT=$$SDAPI^SDAMA301(.DGARRAY)
+23 QUIT
+24 ; VSR patch DG*5.3.980 change four slashes to three slashes for validation. Changed field 5
FIELDS ;;.1///^S X=$P($G(^SC(DGPN1,0)),U,15);1///^S X=$E(VADM(1))_VA("BID");2///^S X=DGPPH;3///^S X=$G(DGPPRDT);5///^S X=DGPN1;6///^S X=DGPAPT;7///^S X=$P(^SC(DGPN1,0),U,8)
+1 ;
MSG1 ;;The 'DAYS TO PULL' is not filled in, unable to determine appointment date.
MSG2 ;;The call list is currently not being generated for weekends.
