DGENRPD2 ;ALB/CJM/EG -Veteran with Future Appts and no Enrollment App Report - Continue 01/19/2005 ; 1/20/05 1:27pm
;;5.3;Registration;**147,232,568,585,725,767**;Aug 13,1993;Build 2
;
PRINT ;
N CRT,QUIT,PAGE,SUBSCRPT
K ^TMP($J)
S QUIT=0
S PAGE=0
S CRT=$S($E(IOST,1,2)="C-":1,1:0)
;
D GETPAT
U IO
I CRT,PAGE=0 W @IOF
S PAGE=1
D HEADER
F SUBSCRPT="STEP2","NOENREC" D
.D PATIENTS(SUBSCRPT)
I CRT,'QUIT D PAUSE
I $D(ZTQUEUED) S ZTREQ="@"
D ^%ZISC
;
K ^TMP($J)
Q
LINE(LINE) ;
;Description: prints a line. First prints header if at end of page.
;
I CRT,($Y>(IOSL-4)) D
.D PAUSE
.Q:QUIT
.W @IOF
.D HEADER
.W LINE
;
E I ('CRT),($Y>(IOSL-2)) D
.W @IOF
.D HEADER
.W LINE
;
E W !,LINE
Q
;
GETPAT ;
; Description: Gets patients to include in the report
N BEGIN,END,DGARRAY,SDCNT,CATEGORY,DIVISION,NAM
S BEGIN=DGENRP("BEGIN")_".0000",END=DGENRP("END")_".2359",DGARRAY(1)=BEGIN_";"_END
S DGARRAY("FLDS")="3;10",SDCNT=$$SDAPI^SDAMA301(.DGARRAY)
;
;there must be subscripts underneath the 101 level to be a
;valid appointment, else it is an error eg 01/20/2005
; Appointment Database is Unavailable
I SDCNT<0 N X S X=$$FAPCHK I X'="" S NAM=X G ERR
;
; Get All records for report
I DGENRP("ALL") D
.S CLINIC=0 F S CLINIC=$O(^TMP($J,"SDAMA301",CLINIC)) Q:'CLINIC D
..Q:$P($G(^SC(CLINIC,0)),"^",3)'="C"
..S DFN=0 F S DFN=$O(^TMP($J,"SDAMA301",CLINIC,DFN)) Q:'DFN D
...S DIVISION=$P($G(^SC(CLINIC,0)),U,15)
...S:'DIVISION DIVISION=$O(^DG(40.8,0))
...D VALREC(CLINIC,DFN)
;
; Get records for specified Divisions only
I $O(DGENRP("DIVISION",0)) D
.S CLINIC=0 F S CLINIC=$O(^TMP($J,"SDAMA301",CLINIC)) Q:'CLINIC D
..Q:$P($G(^SC(CLINIC,0)),"^",3)'="C"
..S DIVISION=$P($G(^SC(CLINIC,0)),U,15)
..S:'DIVISION DIVISION=$O(^DG(40.8,0))
..Q:'DIVISION!('$D(DGENRP("DIVISION",DIVISION)))
..S DFN=0 F S DFN=$O(^TMP($J,"SDAMA301",CLINIC,DFN)) Q:'DFN D VALREC(CLINIC,DFN)
;
; Get records for specified Clinics only
I $O(DGENRP("CLINIC",0)) D
.S CLINIC=0 F S CLINIC=$O(^TMP($J,"SDAMA301",CLINIC)) Q:'CLINIC D
..Q:'CLINIC!('$D(DGENRP("CLINIC",CLINIC)))
..Q:($P($G(^SC(CLINIC,0)),U,3)'="C")
..S DIVISION=$P($G(^SC(CLINIC,0)),U,15)
..S:'DIVISION DIVISION=$O(^DG(40.8,0))
..S DFN=0 F S DFN=$O(^TMP($J,"SDAMA301",CLINIC,DFN)) Q:'DFN D VALREC(CLINIC,DFN)
;
K DGARRAY,^TMP($J,"SDAMA301"),SDCNT
Q
;
ERR ;
;^TMP($J,TYPE,DIVISION NAME,CLINIC NAME,CATEGORY,APPT DT/TM,DFN)
I NAM["Appointment Database is unavailable. Please try again later." S NAM="**Appointment Database is Unavailable**"
I NAM["Appointment request contains invalid values." S NAM="**Invalid appointment, call Help Desk**"
I NAM["An error has occurred. Check the RSA Error Log." S NAM="**Error, check RSA Error Log **"
S ^TMP($J,"NOENREC"," ",NAM," ",DT," ")=""
K DGARRAY,^TMP($J,"SDAMA301"),SDCNT,NAM
Q
;
VALREC(CLINIC,DFN) ;
;
N APPT,STATUS,JUSTONCE S JUSTONCE=0
S APPT=0 F S APPT=$O(^TMP($J,"SDAMA301",CLINIC,DFN,APPT)) Q:'APPT!(JUSTONCE) D
.S JUSTONCE=+$G(DGENRP("JUSTONCE"))
.; Exclude certain appointment statuses
.S STATUS=$P($P(^TMP($J,"SDAMA301",CLINIC,DFN,APPT),U,3),";")
.Q:"^NS^NSR^CC^CCR^CP^CPR^"[(U_STATUS_U)
.;
.; Don't include enrolled veterans or ones that have pending apps
.S CATEGORY=$$CATEGORY^DGENA4(DFN)
.I (CATEGORY="E")!(CATEGORY="P") Q
.;
.; Exclude if not an eligible veteran (can not enroll)
.Q:'$$VET^DGENPTA(DFN)
.;
.D SETTMP(CLINIC,DFN,APPT)
Q
;
SETTMP(CLINIC,DFN,APPT) ;
; NOENREC is for patients without enrollment records
; SITE2 is for other excluded enrollment records
;^TMP($J,TYPE,DIVISION NAME,CLINIC NAME,CATEGORY,APPT DT/TM,DFN)
;
N DIVNAME,CLNAME
S DIVNAME=$S(DIVISION:$P($$SITE^VASITE(APPT\1,DIVISION),U,2),1:" ")
S CLNAME=$P($G(^SC(CLINIC,0)),"^")
S:CLNAME="" CLNAME=" "
;
I $$FINDCUR^DGENA(DFN)="" S ^TMP($J,"NOENREC",DIVNAME,CLNAME,CATEGORY,APPT,DFN)="" Q
S ^TMP($J,"STEP2",DIVNAME,CLNAME,CATEGORY,APPT,DFN)=$$STATUS^DGENA(DFN)_U_$P($P(^TMP($J,"SDAMA301",CLINIC,DFN,APPT),U,10),";",2)
Q
;
;Description: Prints the report header.
;
N LINE
I $Y>1 W @IOF
W !,"Appointments for Veterans with no Enrollment Application"
W:DGENRP("BEGIN") ?70,"Date Range: "_$$FMTE^XLFDT(DGENRP("BEGIN"))_" to "_$$FMTE^XLFDT($G(DGENRP("END")))
W ?120,"Page ",PAGE
S PAGE=PAGE+1
W !
W ?70," Run Date: "_$$FMTE^XLFDT(DT)
W !
;
W !,"Name",?39,"PatientID",?57,"DOB",?70,"Appt Dt/Tm",?90,"EnrollStatus",?121,"Enroll Cat"
S $P(LINE,"-",132)="-"
W !,LINE,!
Q
;
PAUSE ;
;Description: Screen pause. Sets QUIT=1 if user decides to quit.
;
N DIR,X,Y
F Q:$Y>(IOSL-3) W !
S DIR(0)="E"
D ^DIR
I ('(+Y))!$D(DIRUT) S QUIT=1
Q
;
PATIENTS(SUBSCRPT) ;
;Description: Prints list of patients
;
N NODE,DIVISION,CLINIC,TIME,PATIENT,DGPAT,APPTYPE,ENRSTAT,CATEGORY
;
;
S DIVISION=""
F S DIVISION=$O(^TMP($J,SUBSCRPT,DIVISION)) Q:DIVISION="" D Q:QUIT
.D LINE(" ") Q:QUIT
.D LINE($$LJ(" ",40)_"DIVISION: "_DIVISION) Q:QUIT
.D LINE(" ") Q:QUIT
.S CLINIC=""
.F S CLINIC=$O(^TMP($J,SUBSCRPT,DIVISION,CLINIC)) Q:CLINIC="" D Q:QUIT
..D LINE(" ") Q:QUIT
..D LINE("CLINIC: "_$$LJ(CLINIC,40)_$$LJ(" ",40)_"DIVISION: "_DIVISION)
..Q:QUIT
..S CATEGORY=""
..F S CATEGORY=$O(^TMP($J,SUBSCRPT,DIVISION,CLINIC,CATEGORY)) Q:CATEGORY="" D Q:QUIT
...D LINE(" ") Q:QUIT
...S TIME=0
...F S TIME=$O(^TMP($J,SUBSCRPT,DIVISION,CLINIC,CATEGORY,TIME)) Q:'TIME D Q:QUIT
....S DFN=0
....F S DFN=$O(^TMP($J,SUBSCRPT,DIVISION,CLINIC,CATEGORY,TIME,DFN)) Q:'DFN D Q:QUIT
.....S NODE=$G(^TMP($J,SUBSCRPT,DIVISION,CLINIC,CATEGORY,TIME,DFN))
.....S ENRSTAT=$P(NODE,"^")
.....S APPTYPE=$P(NODE,"^",2)
.....Q:'$$GET^DGENPTA(DFN,.DGPAT)
.....S LINE=$$LJ(DGPAT("NAME"),37)_" "_$$LJ(DGPAT("PID"),15)_" "
.....S LINE=LINE_$$LJ($$DATE(DGPAT("DOB")),12)_" "
.....S LINE=LINE_$$LJ($$DATE(TIME),20)
.....S LINE=LINE_" "_$$LJ($S(ENRSTAT="":"NO ENROLLMENT RECORD",1:$$EXT^DGENU("STATUS",ENRSTAT)),28)
.....S LINE=LINE_$$LJ(" ",2)_$$EXTCAT^DGENA4(CATEGORY)
.....D LINE(LINE)
.....Q:QUIT
Q
;
DATE(DATE) ;
Q $$FMTE^XLFDT(DATE,"1")
;
LJ(STRING,LENGTH) ;
Q $$LJ^XLFSTR($E(STRING,1,LENGTH),LENGTH)
;
FAPCHK() ;
N ERR
S ERR=$O(^TMP($J,"SDAMA301",""))
I $D(^TMP($J,"SDAMA301",ERR))=1 Q ^TMP($J,"SDAMA301",ERR)
Q ""
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGENRPD2 6414 printed Sep 02, 2024@19:28:26 Page 2
DGENRPD2 ;ALB/CJM/EG -Veteran with Future Appts and no Enrollment App Report - Continue 01/19/2005 ; 1/20/05 1:27pm
+1 ;;5.3;Registration;**147,232,568,585,725,767**;Aug 13,1993;Build 2
+2 ;
PRINT ;
+1 NEW CRT,QUIT,PAGE,SUBSCRPT
+2 KILL ^TMP($JOB)
+3 SET QUIT=0
+4 SET PAGE=0
+5 SET CRT=$SELECT($EXTRACT(IOST,1,2)="C-":1,1:0)
+6 ;
+7 DO GETPAT
+8 USE IO
+9 IF CRT
IF PAGE=0
WRITE @IOF
+10 SET PAGE=1
+11 DO HEADER
+12 FOR SUBSCRPT="STEP2","NOENREC"
Begin DoDot:1
+13 DO PATIENTS(SUBSCRPT)
End DoDot:1
+14 IF CRT
IF 'QUIT
DO PAUSE
+15 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+16 DO ^%ZISC
+17 ;
+18 KILL ^TMP($JOB)
+19 QUIT
LINE(LINE) ;
+1 ;Description: prints a line. First prints header if at end of page.
+2 ;
+3 IF CRT
IF ($Y>(IOSL-4))
Begin DoDot:1
+4 DO PAUSE
+5 if QUIT
QUIT
+6 WRITE @IOF
+7 DO HEADER
+8 WRITE LINE
End DoDot:1
+9 ;
+10 IF '$TEST
IF ('CRT)
IF ($Y>(IOSL-2))
Begin DoDot:1
+11 WRITE @IOF
+12 DO HEADER
+13 WRITE LINE
End DoDot:1
+14 ;
+15 IF '$TEST
WRITE !,LINE
+16 QUIT
+17 ;
GETPAT ;
+1 ; Description: Gets patients to include in the report
+2 NEW BEGIN,END,DGARRAY,SDCNT,CATEGORY,DIVISION,NAM
+3 SET BEGIN=DGENRP("BEGIN")_".0000"
SET END=DGENRP("END")_".2359"
SET DGARRAY(1)=BEGIN_";"_END
+4 SET DGARRAY("FLDS")="3;10"
SET SDCNT=$$SDAPI^SDAMA301(.DGARRAY)
+5 ;
+6 ;there must be subscripts underneath the 101 level to be a
+7 ;valid appointment, else it is an error eg 01/20/2005
+8 ; Appointment Database is Unavailable
+9 IF SDCNT<0
NEW X
SET X=$$FAPCHK
IF X'=""
SET NAM=X
GOTO ERR
+10 ;
+11 ; Get All records for report
+12 IF DGENRP("ALL")
Begin DoDot:1
+13 SET CLINIC=0
FOR
SET CLINIC=$ORDER(^TMP($JOB,"SDAMA301",CLINIC))
if 'CLINIC
QUIT
Begin DoDot:2
+14 if $PIECE($GET(^SC(CLINIC,0)),"^",3)'="C"
QUIT
+15 SET DFN=0
FOR
SET DFN=$ORDER(^TMP($JOB,"SDAMA301",CLINIC,DFN))
if 'DFN
QUIT
Begin DoDot:3
+16 SET DIVISION=$PIECE($GET(^SC(CLINIC,0)),U,15)
+17 if 'DIVISION
SET DIVISION=$ORDER(^DG(40.8,0))
+18 DO VALREC(CLINIC,DFN)
End DoDot:3
End DoDot:2
End DoDot:1
+19 ;
+20 ; Get records for specified Divisions only
+21 IF $ORDER(DGENRP("DIVISION",0))
Begin DoDot:1
+22 SET CLINIC=0
FOR
SET CLINIC=$ORDER(^TMP($JOB,"SDAMA301",CLINIC))
if 'CLINIC
QUIT
Begin DoDot:2
+23 if $PIECE($GET(^SC(CLINIC,0)),"^",3)'="C"
QUIT
+24 SET DIVISION=$PIECE($GET(^SC(CLINIC,0)),U,15)
+25 if 'DIVISION
SET DIVISION=$ORDER(^DG(40.8,0))
+26 if 'DIVISION!('$DATA(DGENRP("DIVISION",DIVISION)))
QUIT
+27 SET DFN=0
FOR
SET DFN=$ORDER(^TMP($JOB,"SDAMA301",CLINIC,DFN))
if 'DFN
QUIT
DO VALREC(CLINIC,DFN)
End DoDot:2
End DoDot:1
+28 ;
+29 ; Get records for specified Clinics only
+30 IF $ORDER(DGENRP("CLINIC",0))
Begin DoDot:1
+31 SET CLINIC=0
FOR
SET CLINIC=$ORDER(^TMP($JOB,"SDAMA301",CLINIC))
if 'CLINIC
QUIT
Begin DoDot:2
+32 if 'CLINIC!('$DATA(DGENRP("CLINIC",CLINIC)))
QUIT
+33 if ($PIECE($GET(^SC(CLINIC,0)),U,3)'="C")
QUIT
+34 SET DIVISION=$PIECE($GET(^SC(CLINIC,0)),U,15)
+35 if 'DIVISION
SET DIVISION=$ORDER(^DG(40.8,0))
+36 SET DFN=0
FOR
SET DFN=$ORDER(^TMP($JOB,"SDAMA301",CLINIC,DFN))
if 'DFN
QUIT
DO VALREC(CLINIC,DFN)
End DoDot:2
End DoDot:1
+37 ;
+38 KILL DGARRAY,^TMP($JOB,"SDAMA301"),SDCNT
+39 QUIT
+40 ;
ERR ;
+1 ;^TMP($J,TYPE,DIVISION NAME,CLINIC NAME,CATEGORY,APPT DT/TM,DFN)
+2 IF NAM["Appointment Database is unavailable. Please try again later."
SET NAM="**Appointment Database is Unavailable**"
+3 IF NAM["Appointment request contains invalid values."
SET NAM="**Invalid appointment, call Help Desk**"
+4 IF NAM["An error has occurred. Check the RSA Error Log."
SET NAM="**Error, check RSA Error Log **"
+5 SET ^TMP($JOB,"NOENREC"," ",NAM," ",DT," ")=""
+6 KILL DGARRAY,^TMP($JOB,"SDAMA301"),SDCNT,NAM
+7 QUIT
+8 ;
VALREC(CLINIC,DFN) ;
+1 ;
+2 NEW APPT,STATUS,JUSTONCE
SET JUSTONCE=0
+3 SET APPT=0
FOR
SET APPT=$ORDER(^TMP($JOB,"SDAMA301",CLINIC,DFN,APPT))
if 'APPT!(JUSTONCE)
QUIT
Begin DoDot:1
+4 SET JUSTONCE=+$GET(DGENRP("JUSTONCE"))
+5 ; Exclude certain appointment statuses
+6 SET STATUS=$PIECE($PIECE(^TMP($JOB,"SDAMA301",CLINIC,DFN,APPT),U,3),";")
+7 if "^NS^NSR^CC^CCR^CP^CPR^"[(U_STATUS_U)
QUIT
+8 ;
+9 ; Don't include enrolled veterans or ones that have pending apps
+10 SET CATEGORY=$$CATEGORY^DGENA4(DFN)
+11 IF (CATEGORY="E")!(CATEGORY="P")
QUIT
+12 ;
+13 ; Exclude if not an eligible veteran (can not enroll)
+14 if '$$VET^DGENPTA(DFN)
QUIT
+15 ;
+16 DO SETTMP(CLINIC,DFN,APPT)
End DoDot:1
+17 QUIT
+18 ;
SETTMP(CLINIC,DFN,APPT) ;
+1 ; NOENREC is for patients without enrollment records
+2 ; SITE2 is for other excluded enrollment records
+3 ;^TMP($J,TYPE,DIVISION NAME,CLINIC NAME,CATEGORY,APPT DT/TM,DFN)
+4 ;
+5 NEW DIVNAME,CLNAME
+6 SET DIVNAME=$SELECT(DIVISION:$PIECE($$SITE^VASITE(APPT\1,DIVISION),U,2),1:" ")
+7 SET CLNAME=$PIECE($GET(^SC(CLINIC,0)),"^")
+8 if CLNAME=""
SET CLNAME=" "
+9 ;
+10 IF $$FINDCUR^DGENA(DFN)=""
SET ^TMP($JOB,"NOENREC",DIVNAME,CLNAME,CATEGORY,APPT,DFN)=""
QUIT
+11 SET ^TMP($JOB,"STEP2",DIVNAME,CLNAME,CATEGORY,APPT,DFN)=$$STATUS^DGENA(DFN)_U_$PIECE($PIECE(^TMP($JOB,"SDAMA301",CLINIC,DFN,APPT),U,10),";",2)
+12 QUIT
+13 ;
+1 ;Description: Prints the report header.
+2 ;
+3 NEW LINE
+4 IF $Y>1
WRITE @IOF
+5 WRITE !,"Appointments for Veterans with no Enrollment Application"
+6 if DGENRP("BEGIN")
WRITE ?70,"Date Range: "_$$FMTE^XLFDT(DGENRP("BEGIN"))_" to "_$$FMTE^XLFDT($GET(DGENRP("END")))
+7 WRITE ?120,"Page ",PAGE
+8 SET PAGE=PAGE+1
+9 WRITE !
+10 WRITE ?70," Run Date: "_$$FMTE^XLFDT(DT)
+11 WRITE !
+12 ;
+13 WRITE !,"Name",?39,"PatientID",?57,"DOB",?70,"Appt Dt/Tm",?90,"EnrollStatus",?121,"Enroll Cat"
+14 SET $PIECE(LINE,"-",132)="-"
+15 WRITE !,LINE,!
+16 QUIT
+17 ;
PAUSE ;
+1 ;Description: Screen pause. Sets QUIT=1 if user decides to quit.
+2 ;
+3 NEW DIR,X,Y
+4 FOR
if $Y>(IOSL-3)
QUIT
WRITE !
+5 SET DIR(0)="E"
+6 DO ^DIR
+7 IF ('(+Y))!$DATA(DIRUT)
SET QUIT=1
+8 QUIT
+9 ;
PATIENTS(SUBSCRPT) ;
+1 ;Description: Prints list of patients
+2 ;
+3 NEW NODE,DIVISION,CLINIC,TIME,PATIENT,DGPAT,APPTYPE,ENRSTAT,CATEGORY
+4 ;
+5 ;
+6 SET DIVISION=""
+7 FOR
SET DIVISION=$ORDER(^TMP($JOB,SUBSCRPT,DIVISION))
if DIVISION=""
QUIT
Begin DoDot:1
+8 DO LINE(" ")
if QUIT
QUIT
+9 DO LINE($$LJ(" ",40)_"DIVISION: "_DIVISION)
if QUIT
QUIT
+10 DO LINE(" ")
if QUIT
QUIT
+11 SET CLINIC=""
+12 FOR
SET CLINIC=$ORDER(^TMP($JOB,SUBSCRPT,DIVISION,CLINIC))
if CLINIC=""
QUIT
Begin DoDot:2
+13 DO LINE(" ")
if QUIT
QUIT
+14 DO LINE("CLINIC: "_$$LJ(CLINIC,40)_$$LJ(" ",40)_"DIVISION: "_DIVISION)
+15 if QUIT
QUIT
+16 SET CATEGORY=""
+17 FOR
SET CATEGORY=$ORDER(^TMP($JOB,SUBSCRPT,DIVISION,CLINIC,CATEGORY))
if CATEGORY=""
QUIT
Begin DoDot:3
+18 DO LINE(" ")
if QUIT
QUIT
+19 SET TIME=0
+20 FOR
SET TIME=$ORDER(^TMP($JOB,SUBSCRPT,DIVISION,CLINIC,CATEGORY,TIME))
if 'TIME
QUIT
Begin DoDot:4
+21 SET DFN=0
+22 FOR
SET DFN=$ORDER(^TMP($JOB,SUBSCRPT,DIVISION,CLINIC,CATEGORY,TIME,DFN))
if 'DFN
QUIT
Begin DoDot:5
+23 SET NODE=$GET(^TMP($JOB,SUBSCRPT,DIVISION,CLINIC,CATEGORY,TIME,DFN))
+24 SET ENRSTAT=$PIECE(NODE,"^")
+25 SET APPTYPE=$PIECE(NODE,"^",2)
+26 if '$$GET^DGENPTA(DFN,.DGPAT)
QUIT
+27 SET LINE=$$LJ(DGPAT("NAME"),37)_" "_$$LJ(DGPAT("PID"),15)_" "
+28 SET LINE=LINE_$$LJ($$DATE(DGPAT("DOB")),12)_" "
+29 SET LINE=LINE_$$LJ($$DATE(TIME),20)
+30 SET LINE=LINE_" "_$$LJ($SELECT(ENRSTAT="":"NO ENROLLMENT RECORD",1:$$EXT^DGENU("STATUS",ENRSTAT)),28)
+31 SET LINE=LINE_$$LJ(" ",2)_$$EXTCAT^DGENA4(CATEGORY)
+32 DO LINE(LINE)
+33 if QUIT
QUIT
End DoDot:5
if QUIT
QUIT
End DoDot:4
if QUIT
QUIT
End DoDot:3
if QUIT
QUIT
End DoDot:2
if QUIT
QUIT
End DoDot:1
if QUIT
QUIT
+34 QUIT
+35 ;
DATE(DATE) ;
+1 QUIT $$FMTE^XLFDT(DATE,"1")
+2 ;
LJ(STRING,LENGTH) ;
+1 QUIT $$LJ^XLFSTR($EXTRACT(STRING,1,LENGTH),LENGTH)
+2 ;
FAPCHK() ;
+1 NEW ERR
+2 SET ERR=$ORDER(^TMP($JOB,"SDAMA301",""))
+3 IF $DATA(^TMP($JOB,"SDAMA301",ERR))=1
QUIT ^TMP($JOB,"SDAMA301",ERR)
+4 QUIT ""
