SCRPW62 ;BP-CIOFO/KEITH - SC veterans awaiting appointments ;1/5/16 12:26pm
;;5.3;Scheduling;**267,269,358,491,645**;AUG 13, 1993;Build 7
;
;Prompt for report parameters
;
N SDOUT,DIR,DTOUT,DUOUT,SDFMT,SDATES,SDDIV,SDRPT,SDSCVT
N SDELIM,SDX,ZTSAVE,X,Y
S SDOUT=0
D TITL^SCRPW50("SC Veterans Awaiting Appointments")
W !,"Note: Once the scheduling replacement application has been implemented at your"
W !,"site, this report will no longer be accurate."
RPT D SUBT^SCRPW50("**** Report Type Selection ****")
; SD*5.3*645 - replaced 'DATE DESIRED' with 'CID/PREFERRED DATE'
;S DIR(0)="S^E:ENTERED WITH NO APPOINTMENT PROVIDED;A:APPOINTMENTS BEYOND DATE DESIRED",DIR("A")="Select report type"
S DIR(0)="S^E:ENTERED WITH NO APPOINTMENT PROVIDED;A:APPOINTMENTS BEYOND CID/PREFERRED DATE",DIR("A")="Select report type"
S DIR("?",1)="Specify 'E' to return SC veterans entered but not yet provided an appointment,"
;S DIR("?")="'A' to return SC veterans with appointments beyond the date desired."
S DIR("?")="'A' to return SC veterans with appointments beyond the CID/Preferred date."
W ! D ^DIR I $D(DTOUT)!$D(DUOUT) S SDOUT=1 G EXIT
K DIR S SDRPT=Y D ENT:SDRPT="E",APPT:SDRPT="A" G:SDOUT EXIT
D SUBT^SCRPW50("**** Patient Eligibility Selection ****")
S DIR(0)="S^1:50-100% SC Veterans;2:0-50% SC Veterans;3:All SC Veterans"
S DIR("A")="Select eligibility type"
S DIR("?")="Specify the eligibility of the patients you wish to include."
W ! D ^DIR I $D(DTOUT)!$D(DUOUT) S SDOUT=1 G EXIT
K DIR S SDSCVT=Y
FMT D SUBT^SCRPW50("**** Report Format Selection ****")
S DIR(0)="S^D:DETAILED REPORT;S:STATISTICS ONLY"
S DIR("A")="Select report format"
S DIR("?")="Specify the report format desired."
W ! D ^DIR I $D(DTOUT)!$D(DUOUT) S SDOUT=1 G EXIT
K DIR S SDFMT=Y
I SDFMT="S" S SDELIM=0 G QUE
D SUBT^SCRPW50("**** Output Format Selection ****")
S DIR(0)="Y",DIR("A")="Return report output in delimited format"
S DIR("B")="NO"
S DIR("?",1)="Specify if you would like the report output to be in delimited format for"
S DIR("?",2)="transfer to a spreadsheet. The delimited output will not include rated SC"
S DIR("?")="disabilities for 0-50% SC veterans (as included in the text formatted report)."
W ! D ^DIR I $D(DTOUT)!$D(DUOUT) S SDOUT=1 G EXIT
S SDELIM=Y
;
QUE ;Queue output
;W !!,"This report requires ",$S(SDELIM:"greater than ",1:""),"132 columns for output!"
W !!,"This report requires the following steps to be converted to 'EXCEL':"
W !,"1 - Copy it into WORD and replace '!^p' with null"
W !,"2 - Save this file as *.txt format"
W !,"3 - Open this file in 'EXCEL' with the All Files(*.*) type of file, listing it with one delimiter: '^'."
F SDX="SDELIM","SDRPT","SDSCVT","SDATES","SDDIV","SDDIV(","SDFMT" S ZTSAVE(SDX)=""
W ! D EN^XUTMDEVQ("START^SCRPW62","SC Veterans Awaiting Appointments",.ZTSAVE) D DISP0^SCRPW23
Q
;
ENT ;Date entered parameters
S SDATES=1 Q
;
;Following logic suppressed by request
D SUBT^SCRPW50("**** Report Time Frame ****")
S DIR(0)="S^1:THE PAST YEAR;2:THE PAST TWO YEARS;3:THE PAST 3 YEARS"
S DIR("A")="Include SC veterans entered during"
S DIR("?")="Specify the time frame in which these patients were entered in VistA."
W ! D ^DIR I $D(DTOUT)!$D(DUOUT) S SDOUT=1 Q
S SDATES=Y
Q
;
APPT ;Appointment delay parameters
I '$$DIVA^SCRPW17(.SDDIV) S SDOUT=1 Q
S SDATES=30 Q
;
;Following logic suppressed by request
D SUBT^SCRPW50("**** Report Time Frame ****")
; SD*5.3*645 - replaced 'DESIRED DATE' with 'CID/PREFERRED DATE', 'CID/Preferred date'
;S DIR(0)="S^30:>30 DAYS BEYOND 'DESIRED DATE';60:>60 DAYS BEYOND 'DESIRED DATE;90:>90 DAYS BEYOND 'DESIRED DATE';180:>180 DAYS BEYOND 'DESIRED DATE'"
S DIR(0)="S^30:>30 DAYS BEYOND 'CID/PREFERRED DATE';60:>60 DAYS BEYOND 'CID/PREFERRED DATE;90:>90 DAYS BEYOND 'CID/PREFERRED DATE';180:>180 DAYS BEYOND 'CID/PREFERRED DATE'"
S DIR("A")="Include SC veterans with future appointments greater than"
;S DIR("?")="Specify the difference between 'desired date' and the appointement date."
S DIR("?")="Specify the difference between 'CID/Preferred date' and the appointement date."
W ! D ^DIR I $D(DTOUT)!$D(DUOUT) S SDOUT=1 Q
S SDATES=Y
Q
;
START ;Gather report data
N SDSTOP,SDOUT,SDSTOP,SDPAGE,SDLINE,SDPNOW,SDT,SDX
I '$D(ZTQUEUED),$E(IOST)="C" D WAIT^DICD
K ^TMP("SCRPW",$J) S (SDSTOP,SDOUT)=0,SDPAGE=1,SDLINE=""
S $P(SDLINE,"-",(IOM+1))=""
S SDPNOW=$$FMTE^XLFDT($E($$NOW^XLFDT(),1,12))
S SDX=$S(SDSCVT=1:"SC 50-100% ",SDSCVT=2:"SC < 50% ",1:"")
S SDT(1)="<*> SC VETERANS AWAITING APPOINTMENTS <*>"
; SD*5.3*645 - replaced 'DESIRED DATE' with 'CID/Preferred date'
S SDT(2)=$S(SDRPT="E":SDX_"PATIENTS ENTERED IN THE PAST "_$S(SDATES=1:"YEAR",1:SDATES_" YEARS")_" WITHOUT AN APPOINTMENT",1:SDX_"PATIENTS WAITING > "_SDATES_" DAYS BEYOND APPOINTMENT 'CID/PREFERRED DATE'")
D @(SDRPT_"^SCRPW63") W !!
D EXIT
Q
;
SCEL(SDE,SDSCVT) ;Gather SC eligibility codes
;Input: SDE=array to return list of codes in the format SDE(n) where
; 'n' is the ifn in file #8 (pass by reference)
; SDSCVT=type of SC vets to include
N SDE81,SDX,SDI,SDII
S SDI=0 F S SDI=$O(^DIC(8.1,SDI)) Q:'SDI D
.S SDX=$G(^DIC(8.1,SDI,0))
.Q:$P(SDX,U,5)'="Y" S SDX=$P(SDX,U,4)
.I SDSCVT=1,SDX'=1 Q ;50-100% SC only
.I SDSCVT=2,SDX'=3 Q ;0-50% SC only
.I SDSCVT=3,(SDX'=1&(SDX'=3)) Q ;SC only
.S SDII=0 F S SDII=$O(^DIC(8,"D",SDI,SDII)) Q:'SDII D
..S SDE(SDII)=SDX
..Q
.Q
Q
;
EXIT K ZTQUEUED,ZTSTOP,SDATES,SDDIV,SDFMT,SDRPT,SDELIM
D END^SCRPW50 Q
;
HDR ;Print report header
N X
I SDELIM D HDRD Q
I $E(IOST)="C",SDPAGE>1 N DIR S DIR(0)="E" D ^DIR S SDOUT=Y'=1 Q:SDOUT
D STOP^SCRPW63 Q:SDOUT
W:SDPAGE>1!($E(IOST)="C") $$XY^SCRPW50(IOF,1,0)
W:$X $$XY^SCRPW50("",0,0) W SDLINE
S X=0 F S X=$O(SDT(X)) Q:'X W !?(IOM-$L(SDT(X))\2),SDT(X)
W !,SDLINE,!,"Date printed: ",SDPNOW,?((IOM-6)-$L(SDPAGE)),"Page: "
W SDPAGE,!,SDLINE S SDPAGE=SDPAGE+1 Q
;
HDRD ;Header for delimited report
Q:SDPAGE>1
W !,SDLINE S X=0 F S X=$O(SDT(X)) Q:'X W !,SDT(X)
W !,"Date printed: ",SDPNOW,!,SDLINE
N ARR S ARR(1)="NAME^SSN^PRIM. ELIG.^DATE ENTERED^STREET ADDRESS^CITY^STATE^ZIP^PHONE NUMBER"
; SD*5.3*645 - replaced 'DESIRED DATE' with 'CID/PREFERRED DATE'
S:SDRPT="A" ARR(1)=ARR(1)_"^APPOINTMENT DATE^CLINIC^CREDIT PAIR^DIVISION^DATE APPT. ENTERED^CID/PREFERRED DATE^DIFFERENCE (CID/PREFERRED DATE - APPT. DATE)^DIFFERENCE (DATE APPT. ENTERED - CID/PREFERRED DATE)"
D DELIM(.ARR)
S SDPAGE=SDPAGE+1 Q
Q
;W !,"NAME^SSN^PRIM. ELIG.^DATE ENTERED^STREET ADDRESS^CITY^STATE^ZIP^PHONE NUMBER"
;W:SDRPT="A" "^APPOINTMENT DATE^CLINIC^CREDIT PAIR^DIVISION^DATE APPT. ENTERED^DESIRED DATE^DIFFERENCE (DESIRED DATE - APPT. DATE)^DIFFERENCE (DATE APPT. ENTERED - DESIRED DATE)"
;S SDPAGE=SDPAGE+1 Q
DELIM(ARR) ;enter delimiter in the end of wrapped line
;ARR - array of lines
N DELIM,II,LN,LL,JJ
S DELIM="!"
F II=1:1 S LN=$G(ARR(II)),LL=$L(LN) Q:'LL S LN=$P(LN," ")_DELIM_$P(LN," ",2,$L(LN," ")) F JJ=1:79:LL W !,$E(LN,JJ,JJ+78) W:JJ+79<LL DELIM I JJ+79=LL W $E(LN,LL) Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCRPW62 7157 printed Oct 16, 2024@18:44:35 Page 2
SCRPW62 ;BP-CIOFO/KEITH - SC veterans awaiting appointments ;1/5/16 12:26pm
+1 ;;5.3;Scheduling;**267,269,358,491,645**;AUG 13, 1993;Build 7
+2 ;
+3 ;Prompt for report parameters
+4 ;
+5 NEW SDOUT,DIR,DTOUT,DUOUT,SDFMT,SDATES,SDDIV,SDRPT,SDSCVT
+6 NEW SDELIM,SDX,ZTSAVE,X,Y
+7 SET SDOUT=0
+8 DO TITL^SCRPW50("SC Veterans Awaiting Appointments")
+9 WRITE !,"Note: Once the scheduling replacement application has been implemented at your"
+10 WRITE !,"site, this report will no longer be accurate."
RPT DO SUBT^SCRPW50("**** Report Type Selection ****")
+1 ; SD*5.3*645 - replaced 'DATE DESIRED' with 'CID/PREFERRED DATE'
+2 ;S DIR(0)="S^E:ENTERED WITH NO APPOINTMENT PROVIDED;A:APPOINTMENTS BEYOND DATE DESIRED",DIR("A")="Select report type"
+3 SET DIR(0)="S^E:ENTERED WITH NO APPOINTMENT PROVIDED;A:APPOINTMENTS BEYOND CID/PREFERRED DATE"
SET DIR("A")="Select report type"
+4 SET DIR("?",1)="Specify 'E' to return SC veterans entered but not yet provided an appointment,"
+5 ;S DIR("?")="'A' to return SC veterans with appointments beyond the date desired."
+6 SET DIR("?")="'A' to return SC veterans with appointments beyond the CID/Preferred date."
+7 WRITE !
DO ^DIR
IF $DATA(DTOUT)!$DATA(DUOUT)
SET SDOUT=1
GOTO EXIT
+8 KILL DIR
SET SDRPT=Y
if SDRPT="E"
DO ENT
if SDRPT="A"
DO APPT
if SDOUT
GOTO EXIT
+9 DO SUBT^SCRPW50("**** Patient Eligibility Selection ****")
+10 SET DIR(0)="S^1:50-100% SC Veterans;2:0-50% SC Veterans;3:All SC Veterans"
+11 SET DIR("A")="Select eligibility type"
+12 SET DIR("?")="Specify the eligibility of the patients you wish to include."
+13 WRITE !
DO ^DIR
IF $DATA(DTOUT)!$DATA(DUOUT)
SET SDOUT=1
GOTO EXIT
+14 KILL DIR
SET SDSCVT=Y
FMT DO SUBT^SCRPW50("**** Report Format Selection ****")
+1 SET DIR(0)="S^D:DETAILED REPORT;S:STATISTICS ONLY"
+2 SET DIR("A")="Select report format"
+3 SET DIR("?")="Specify the report format desired."
+4 WRITE !
DO ^DIR
IF $DATA(DTOUT)!$DATA(DUOUT)
SET SDOUT=1
GOTO EXIT
+5 KILL DIR
SET SDFMT=Y
+6 IF SDFMT="S"
SET SDELIM=0
GOTO QUE
+7 DO SUBT^SCRPW50("**** Output Format Selection ****")
+8 SET DIR(0)="Y"
SET DIR("A")="Return report output in delimited format"
+9 SET DIR("B")="NO"
+10 SET DIR("?",1)="Specify if you would like the report output to be in delimited format for"
+11 SET DIR("?",2)="transfer to a spreadsheet. The delimited output will not include rated SC"
+12 SET DIR("?")="disabilities for 0-50% SC veterans (as included in the text formatted report)."
+13 WRITE !
DO ^DIR
IF $DATA(DTOUT)!$DATA(DUOUT)
SET SDOUT=1
GOTO EXIT
+14 SET SDELIM=Y
+15 ;
QUE ;Queue output
+1 ;W !!,"This report requires ",$S(SDELIM:"greater than ",1:""),"132 columns for output!"
+2 WRITE !!,"This report requires the following steps to be converted to 'EXCEL':"
+3 WRITE !,"1 - Copy it into WORD and replace '!^p' with null"
+4 WRITE !,"2 - Save this file as *.txt format"
+5 WRITE !,"3 - Open this file in 'EXCEL' with the All Files(*.*) type of file, listing it with one delimiter: '^'."
+6 FOR SDX="SDELIM","SDRPT","SDSCVT","SDATES","SDDIV","SDDIV(","SDFMT"
SET ZTSAVE(SDX)=""
+7 WRITE !
DO EN^XUTMDEVQ("START^SCRPW62","SC Veterans Awaiting Appointments",.ZTSAVE)
DO DISP0^SCRPW23
+8 QUIT
+9 ;
ENT ;Date entered parameters
+1 SET SDATES=1
QUIT
+2 ;
+3 ;Following logic suppressed by request
+4 DO SUBT^SCRPW50("**** Report Time Frame ****")
+5 SET DIR(0)="S^1:THE PAST YEAR;2:THE PAST TWO YEARS;3:THE PAST 3 YEARS"
+6 SET DIR("A")="Include SC veterans entered during"
+7 SET DIR("?")="Specify the time frame in which these patients were entered in VistA."
+8 WRITE !
DO ^DIR
IF $DATA(DTOUT)!$DATA(DUOUT)
SET SDOUT=1
QUIT
+9 SET SDATES=Y
+10 QUIT
+11 ;
APPT ;Appointment delay parameters
+1 IF '$$DIVA^SCRPW17(.SDDIV)
SET SDOUT=1
QUIT
+2 SET SDATES=30
QUIT
+3 ;
+4 ;Following logic suppressed by request
+5 DO SUBT^SCRPW50("**** Report Time Frame ****")
+6 ; SD*5.3*645 - replaced 'DESIRED DATE' with 'CID/PREFERRED DATE', 'CID/Preferred date'
+7 ;S DIR(0)="S^30:>30 DAYS BEYOND 'DESIRED DATE';60:>60 DAYS BEYOND 'DESIRED DATE;90:>90 DAYS BEYOND 'DESIRED DATE';180:>180 DAYS BEYOND 'DESIRED DATE'"
+8 SET DIR(0)="S^30:>30 DAYS BEYOND 'CID/PREFERRED DATE';60:>60 DAYS BEYOND 'CID/PREFERRED DATE;90:>90 DAYS BEYOND 'CID/PREFERRED DATE';180:>180 DAYS BEYOND 'CID/PREFERRED DATE'"
+9 SET DIR("A")="Include SC veterans with future appointments greater than"
+10 ;S DIR("?")="Specify the difference between 'desired date' and the appointement date."
+11 SET DIR("?")="Specify the difference between 'CID/Preferred date' and the appointement date."
+12 WRITE !
DO ^DIR
IF $DATA(DTOUT)!$DATA(DUOUT)
SET SDOUT=1
QUIT
+13 SET SDATES=Y
+14 QUIT
+15 ;
START ;Gather report data
+1 NEW SDSTOP,SDOUT,SDSTOP,SDPAGE,SDLINE,SDPNOW,SDT,SDX
+2 IF '$DATA(ZTQUEUED)
IF $EXTRACT(IOST)="C"
DO WAIT^DICD
+3 KILL ^TMP("SCRPW",$JOB)
SET (SDSTOP,SDOUT)=0
SET SDPAGE=1
SET SDLINE=""
+4 SET $PIECE(SDLINE,"-",(IOM+1))=""
+5 SET SDPNOW=$$FMTE^XLFDT($EXTRACT($$NOW^XLFDT(),1,12))
+6 SET SDX=$SELECT(SDSCVT=1:"SC 50-100% ",SDSCVT=2:"SC < 50% ",1:"")
+7 SET SDT(1)="<*> SC VETERANS AWAITING APPOINTMENTS <*>"
+8 ; SD*5.3*645 - replaced 'DESIRED DATE' with 'CID/Preferred date'
+9 SET SDT(2)=$SELECT(SDRPT="E":SDX_"PATIENTS ENTERED IN THE PAST "_$SELECT(SDATES=1:"YEAR",1:SDATES_" YEARS")_" WITHOUT AN APPOINTMENT",1:SDX_"PATIENTS WAITING > "_SDATES_" DAYS BEYOND APPOINTMENT 'CID/PREFERRED DATE'")
+10 DO @(SDRPT_"^SCRPW63")
WRITE !!
+11 DO EXIT
+12 QUIT
+13 ;
SCEL(SDE,SDSCVT) ;Gather SC eligibility codes
+1 ;Input: SDE=array to return list of codes in the format SDE(n) where
+2 ; 'n' is the ifn in file #8 (pass by reference)
+3 ; SDSCVT=type of SC vets to include
+4 NEW SDE81,SDX,SDI,SDII
+5 SET SDI=0
FOR
SET SDI=$ORDER(^DIC(8.1,SDI))
if 'SDI
QUIT
Begin DoDot:1
+6 SET SDX=$GET(^DIC(8.1,SDI,0))
+7 if $PIECE(SDX,U,5)'="Y"
QUIT
SET SDX=$PIECE(SDX,U,4)
+8 ;50-100% SC only
IF SDSCVT=1
IF SDX'=1
QUIT
+9 ;0-50% SC only
IF SDSCVT=2
IF SDX'=3
QUIT
+10 ;SC only
IF SDSCVT=3
IF (SDX'=1&(SDX'=3))
QUIT
+11 SET SDII=0
FOR
SET SDII=$ORDER(^DIC(8,"D",SDI,SDII))
if 'SDII
QUIT
Begin DoDot:2
+12 SET SDE(SDII)=SDX
+13 QUIT
End DoDot:2
+14 QUIT
End DoDot:1
+15 QUIT
+16 ;
EXIT KILL ZTQUEUED,ZTSTOP,SDATES,SDDIV,SDFMT,SDRPT,SDELIM
+1 DO END^SCRPW50
QUIT
+2 ;
HDR ;Print report header
+1 NEW X
+2 IF SDELIM
DO HDRD
QUIT
+3 IF $EXTRACT(IOST)="C"
IF SDPAGE>1
NEW DIR
SET DIR(0)="E"
DO ^DIR
SET SDOUT=Y'=1
if SDOUT
QUIT
+4 DO STOP^SCRPW63
if SDOUT
QUIT
+5 if SDPAGE>1!($EXTRACT(IOST)="C")
WRITE $$XY^SCRPW50(IOF,1,0)
+6 if $X
WRITE $$XY^SCRPW50("",0,0)
WRITE SDLINE
+7 SET X=0
FOR
SET X=$ORDER(SDT(X))
if 'X
QUIT
WRITE !?(IOM-$LENGTH(SDT(X))\2),SDT(X)
+8 WRITE !,SDLINE,!,"Date printed: ",SDPNOW,?((IOM-6)-$LENGTH(SDPAGE)),"Page: "
+9 WRITE SDPAGE,!,SDLINE
SET SDPAGE=SDPAGE+1
QUIT
+10 ;
HDRD ;Header for delimited report
+1 if SDPAGE>1
QUIT
+2 WRITE !,SDLINE
SET X=0
FOR
SET X=$ORDER(SDT(X))
if 'X
QUIT
WRITE !,SDT(X)
+3 WRITE !,"Date printed: ",SDPNOW,!,SDLINE
+4 NEW ARR
SET ARR(1)="NAME^SSN^PRIM. ELIG.^DATE ENTERED^STREET ADDRESS^CITY^STATE^ZIP^PHONE NUMBER"
+5 ; SD*5.3*645 - replaced 'DESIRED DATE' with 'CID/PREFERRED DATE'
+6 if SDRPT="A"
SET ARR(1)=ARR(1)_"^APPOINTMENT DATE^CLINIC^CREDIT PAIR^DIVISION^DATE APPT. ENTERED^CID/PREFERRED DATE^DIFFERENCE (CID/PREFERRED DATE - APPT. DATE)^DIFFERENCE (DATE APPT. ENTERED - CID/PREFERRED DATE)"
+7 DO DELIM(.ARR)
+8 SET SDPAGE=SDPAGE+1
QUIT
+9 QUIT
+10 ;W !,"NAME^SSN^PRIM. ELIG.^DATE ENTERED^STREET ADDRESS^CITY^STATE^ZIP^PHONE NUMBER"
+11 ;W:SDRPT="A" "^APPOINTMENT DATE^CLINIC^CREDIT PAIR^DIVISION^DATE APPT. ENTERED^DESIRED DATE^DIFFERENCE (DESIRED DATE - APPT. DATE)^DIFFERENCE (DATE APPT. ENTERED - DESIRED DATE)"
+12 ;S SDPAGE=SDPAGE+1 Q
DELIM(ARR) ;enter delimiter in the end of wrapped line
+1 ;ARR - array of lines
+2 NEW DELIM,II,LN,LL,JJ
+3 SET DELIM="!"
+4 FOR II=1:1
SET LN=$GET(ARR(II))
SET LL=$LENGTH(LN)
if 'LL
QUIT
SET LN=$PIECE(LN," ")_DELIM_$PIECE(LN," ",2,$LENGTH(LN," "))
FOR JJ=1:79:LL
WRITE !,$EXTRACT(LN,JJ,JJ+78)
if JJ+79<LL
WRITE DELIM
IF JJ+79=LL
WRITE $EXTRACT(LN,LL)
QUIT
