- SCRPW62 ;BP-CIOFO/KEITH - SC veterans awaiting appointments ; 23 August 2002@20:23 ; Compiled August 20, 2007 14:21:08
- ;;5.3;Scheduling;**267,269,358,491,1015**;AUG 13, 1993;Build 21
- ;
- ;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 ****")
- S DIR(0)="S^E:ENTERED WITH NO APPOINTMENT PROVIDED;A:APPOINTMENTS BEYOND DATE DESIRED",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."
- 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 ****")
- 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("A")="Include SC veterans with future appointments greater than"
- S DIR("?")="Specify the difference between 'desired 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 <*>"
- 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 'DESIRED 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"
- S:SDRPT="A" ARR(1)=ARR(1)_"^APPOINTMENT DATE^CLINIC^CREDIT PAIR^DIVISION^DATE APPT. ENTERED^DESIRED DATE^DIFFERENCE (DESIRED DATE - APPT. DATE)^DIFFERENCE (DATE APPT. ENTERED - DESIRED 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
- SCRPW62 ;BP-CIOFO/KEITH - SC veterans awaiting appointments ; 23 August 2002@20:23 ; Compiled August 20, 2007 14:21:08
- +1 ;;5.3;Scheduling;**267,269,358,491,1015**;AUG 13, 1993;Build 21
- +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 SET DIR(0)="S^E:ENTERED WITH NO APPOINTMENT PROVIDED;A:APPOINTMENTS BEYOND DATE DESIRED"
- SET DIR("A")="Select report type"
- +2 SET DIR("?",1)="Specify 'E' to return SC veterans entered but not yet provided an appointment,"
- +3 SET DIR("?")="'A' to return SC veterans with appointments beyond the date desired."
- +4 WRITE !
- DO ^DIR
- IF $DATA(DTOUT)!$DATA(DUOUT)
- SET SDOUT=1
- GOTO EXIT
- +5 KILL DIR
- SET SDRPT=Y
- IF SDRPT="E"
- DO ENT
- IF SDRPT="A"
- DO APPT
- IF SDOUT
- GOTO EXIT
- +6 DO SUBT^SCRPW50("**** Patient Eligibility Selection ****")
- +7 SET DIR(0)="S^1:50-100% SC Veterans;2:0-50% SC Veterans;3:All SC Veterans"
- +8 SET DIR("A")="Select eligibility type"
- +9 SET DIR("?")="Specify the eligibility of the patients you wish to include."
- +10 WRITE !
- DO ^DIR
- IF $DATA(DTOUT)!$DATA(DUOUT)
- SET SDOUT=1
- GOTO EXIT
- +11 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 SET 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'"
- +7 SET DIR("A")="Include SC veterans with future appointments greater than"
- +8 SET DIR("?")="Specify the difference between 'desired date' and the appointement date."
- +9 WRITE !
- DO ^DIR
- IF $DATA(DTOUT)!$DATA(DUOUT)
- SET SDOUT=1
- QUIT
- +10 SET SDATES=Y
- +11 QUIT
- +12 ;
- 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 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 'DESIRED DATE'")
- +9 DO @(SDRPT_"^SCRPW63")
- WRITE !!
- +10 DO EXIT
- +11 QUIT
- +12 ;
- 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 IF SDRPT="A"
- SET ARR(1)=ARR(1)_"^APPOINTMENT DATE^CLINIC^CREDIT PAIR^DIVISION^DATE APPT. ENTERED^DESIRED DATE^DIFFERENCE (DESIRED DATE - APPT. DATE)^DIFFERENCE (DATE APPT. ENTERED - DESIRED DATE)"
- +6 DO DELIM(.ARR)
- +7 SET SDPAGE=SDPAGE+1
- QUIT
- +8 QUIT
- +9 ;W !,"NAME^SSN^PRIM. ELIG.^DATE ENTERED^STREET ADDRESS^CITY^STATE^ZIP^PHONE NUMBER"
- +10 ;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)"
- +11 ;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
