SCRPW63 ;BP-CIOFO/KEITH - SC veterans awaiting appointments (cont.) ; 23 August 2002@20:23
;;5.3;Scheduling;**267,269,357,491**;AUG 13, 1993;Build 53
;
E ;Gather data for patients entered report
N DFN,SDX,SDATE,SD0,SDSCEL,SDEL,SDYR,SDREL,SDTOT,SDSDT,SDLVDT,SDEDT
N SDNAME
D SCEL^SCRPW62(.SDSCEL,SDSCVT) ;Get eligibility code pointers
S (SDSDT,SDATE)=DT-(10000*SDATES),SDSTOP=0
;Find the patients entered after date specified
S DFN=0 F Q:SDSTOP S DFN=$O(^DPT(DFN)) Q:'DFN D
.Q:$D(^DPT(DFN,-9)) ;Skip merged records
.I DFN#1000=0 D STOP Q:SDSTOP ;Check for stop task request
.S SDLVDT=""
.S SD0=$G(^DPT(DFN,0)) Q:'$L(SD0)
.S SDEDT=$P(SD0,U,16) S:SDEDT SDLVDT=SDEDT
.I SDEDT,SDEDT<SDATE Q ;Date entered < start date
.I 'SDEDT,SDLVDT<SDATE Q ;No date entered, last valid date < start
.S SDEL=+$G(^DPT(DFN,.36)) Q:'$D(SDSCEL(SDEL)) ;Only SC vets
.Q:+$G(^DPT(DFN,.35)) ;No deceased patients
.Q:$$SCHAPP(DFN) ;Appointments not cancelled by clinic?
.S SDYR=$$FMDIFF^XLFDT(DT,$S(SDEDT:SDEDT,1:SDLVDT))\365.25 ;Year entered
.S SDEL=SDSCEL(SDEL) D Q:SDFMT="S"
..;Record statistics
..S ^TMP("SCRPW",$J,"STATS",SDYR,SDEL)=$G(^TMP("SCRPW",$J,"STATS",SDYR,SDEL))+1
..Q
.S SDNAME=$P(SD0,U) Q:'$L(SDNAME)
.S ^TMP("SCRPW",$J,SDEL,SDNAME,DFN)=SD0
.Q
Q:SDSTOP
D:$E(IOST,1,2)="C-" DISP0^SCRPW23
I '$D(^TMP("SCRPW",$J)) D Q ;Negative report
.D HDR^SCRPW62 S SDX="No patients found within report parameters!"
.W !!?(132-$L(SDX)\2),SDX
.I $E(IOST)="C",'SDOUT N DIR S DIR(0)="E" D ^DIR
.Q
;Detailed report
I SDFMT="D" D HDR^SCRPW62 S SDEL=0 F S SDEL=$O(^TMP("SCRPW",$J,SDEL)) Q:'SDEL!SDOUT D
.S SDNAME="" F S SDNAME=$O(^TMP("SCRPW",$J,SDEL,SDNAME)) Q:SDNAME=""!SDOUT S DFN=0 D
..F S DFN=$O(^TMP("SCRPW",$J,SDEL,SDNAME,DFN)) Q:'DFN!SDOUT D
...S SDREL=$S(SDEL=1:0,1:+$P($G(^DPT(DFN,.372,0)),U,4))
...D:$Y>(IOSL-(4+SDREL)) HDR^SCRPW62 Q:SDOUT
...S SDX=^TMP("SCRPW",$J,SDEL,SDNAME,DFN) D PLINE(DFN,SDX,SDEL)
...Q
.Q
Q:SDOUT
ESUM ;Print summary
G:SDELIM EQ
S SDT(3)="STATISTICAL SUMMARY" D HDR^SCRPW62 Q:SDOUT
W !! S SDYR="",SDTOT=0
F S SDYR=$O(^TMP("SCRPW",$J,"STATS",SDYR)) Q:SDYR="" D
.S SDEL=0 F S SDEL=$O(^TMP("SCRPW",$J,"STATS",SDYR,SDEL)) Q:'SDEL D
..S SDX=$$CSCEL(SDEL)_" veterans entered "_$S(SDYR=0:"in the past year",SDYR=1:"two years ago",SDYR=2:"three years ago",1:"")_":"
..W !?36,$J(SDX,45),?83,$J(^TMP("SCRPW",$J,"STATS",SDYR,SDEL),6,0)
..S SDTOT=SDTOT+^TMP("SCRPW",$J,"STATS",SDYR,SDEL)
..Q
.Q
W !?36,$E(SDLINE,1,53),!?75,"TOTAL:",?83,$J(SDTOT,6,0)
EQ I $E(IOST,1,2)="C-" N DIR S DIR(0)="E" W !! D ^DIR
Q
;
SCHAPP(DFN) ;Look for scheduled appointments not cancelled by clinic
; Input: DFN=patient ifn
;Output: '1' if appointments exist, '0' otherwise
N SDI,SDX,SDY
S (SDI,SDY)=0
F S SDI=$O(^DPT(DFN,"S",SDI)) Q:'SDI!SDY D
.S SDX=$G(^DPT(DFN,"S",SDI,0)) Q:'$L(SDX)
.S SDX=$P(SDX,U,2) I $L(SDX),"CA"[SDX Q
.S SDY=1
.Q
Q SDY
;
A ;Gather data for future appointments report
N DFN,SDA0,SDX,SDI,SDSCEL,SDEL,SDDATE,SDIFF,SDAPT,SDIVL,SDIVN
N SDREL,SDTOT,SDIV,SD0,SDNAME
D SCEL^SCRPW62(.SDSCEL,SDSCVT) ;Get eligibility code pointers
S DFN=0 F S DFN=$O(^DPT(DFN)) Q:'DFN!SDSTOP D
.I DFN#1000=0 D STOP Q:SDSTOP ;Check for stop task request
.S SDEL=+$G(^DPT(DFN,.36)) Q:'$D(SDSCEL(SDEL)) ;Only SC vets
.S SDEL=SDSCEL(SDEL)
.Q:+$G(^DPT(DFN,.35)) ;No deceased patients
.S SDI=DT F S SDI=$O(^DPT(DFN,"S",SDI)) Q:'SDI D
..S SDDATE=+$G(^DPT(DFN,"S",SDI,1)) Q:'SDDATE Q:SDDATE>SDI
..S SDA0=$G(^DPT(DFN,"S",SDI,0)) Q:'$L(SDA0)
..S SDIV=$P($G(^SC(+SDA0,0)),U,15) Q:'$$DIV(.SDIV) ;Division check
..;Exclude cancelled appointments
..S SDX=$P(SDA0,U,2) I $L(SDX),"PCA"[SDX Q
..S SDIFF=$$FMDIFF^XLFDT(SDI,SDDATE) Q:SDIFF'>SDATES
..S SDNAME=$P($G(^DPT(DFN,0)),U) Q:'$L(SDNAME)
..;Record detailed information
..S ^TMP("SCRPW",$J,SDIV,SDEL,SDNAME,DFN,SDI)=SDDATE_U_SDA0
..S ^TMP("SCRPW",$J,SDIV,SDEL,SDNAME,DFN)=$G(^TMP("SCRPW",$J,SDIV,SDEL,SDNAME,DFN))+1
..Q
.Q
Q:SDSTOP
;Tally up statistics
S SDIV=0 F S SDIV=$O(^TMP("SCRPW",$J,SDIV)) Q:'SDIV D
.S SDEL=0 F S SDEL=$O(^TMP("SCRPW",$J,SDIV,SDEL)) Q:'SDEL D
..S SDNAME="" F S SDNAME=$O(^TMP("SCRPW",$J,SDIV,SDEL,SDNAME)) Q:SDNAME=""!SDOUT D
...S DFN=0 F S DFN=$O(^TMP("SCRPW",$J,SDIV,SDEL,SDNAME,DFN)) Q:'DFN D
....S ^TMP("SCRPW",$J,"STATS",SDIV,SDEL,"PTS")=$G(^TMP("SCRPW",$J,"STATS",SDIV,SDEL,"PTS"))+1
....S SDI=0 F S SDI=$O(^TMP("SCRPW",$J,SDIV,SDEL,SDNAME,DFN,SDI)) Q:'SDI D
.....S ^TMP("SCRPW",$J,"STATS",SDIV,SDEL,"APPTS")=$G(^TMP("SCRPW",$J,"STATS",SDIV,SDEL,"APPTS"))+1
.....Q
....Q
...Q
..Q
.Q
Q:SDSTOP
;Print report
S SDIV="" F S SDIV=$O(SDDIV(SDIV)) Q:'SDIV S SDIV(SDDIV(SDIV))=SDIV
I 'SDDIV,$P(SDDIV,U,2)'="ALL DIVISIONS" D
.S SDIV($P(SDDIV,U,2))=$$PRIM^VASITE()
.Q
I $P(SDDIV,U,2)="ALL DIVISIONS" S SDI=0 D
.F S SDI=$O(^TMP("SCRPW",$J,SDI)) Q:'SDI D
..S SDX=$P($G(^DG(40.8,SDI,0)),U) S:$L(SDX) SDIV(SDX)=SDI
..Q
.Q
D:$E(IOST)="C" DISP0^SCRPW23
I '$D(^TMP("SCRPW",$J)) D Q ;Negative report
.S SDIV=0 D DHDR^SCRPW40(3,.SDT),HDR^SCRPW62
.S SDX="No appointments found that meet report criteria."
.I SDELIM W !,SDX Q
.W !!?(IOM-$L(SDX)\2),SDX
.I $E(IOST)="C",'SDOUT N DIR S DIR(0)="E" D ^DIR
.Q
G:SDFMT="S" ASUM
;Print detailed report by division
S SDIVN="" F S SDIVN=$O(SDIV(SDIVN)) Q:SDIVN=""!SDOUT D
.S SDIV=SDIV(SDIVN) D ADPRT(.SDIV)
.Q
Q:SDOUT
;Print summary
ASUM G:SDELIM AQ
S SDT(3)="STATISTICAL SUMMARY" D HDR^SCRPW62 Q:SDOUT
W !! S (SDTOT,SDIV,SDIVL)=0,SDIVN=""
F S SDIVN=$O(SDIV(SDIVN)) Q:SDIVN="" D
.S SDIVN(SDIV(SDIVN))=SDIVN S:$L(SDIVN)>SDIVL SDIVL=$L(SDIVN)
F S SDIV=$O(^TMP("SCRPW",$J,"STATS",SDIV)) Q:'SDIV D
.S SDEL=0 F S SDEL=$O(^TMP("SCRPW",$J,"STATS",SDIV,SDEL)) Q:'SDEL D
..S SDAPT=^TMP("SCRPW",$J,"STATS",SDIV,SDEL,"APPTS"),SDTOT=SDTOT+SDAPT
..S SDX=$$CSCEL(SDEL)_" appointments at "_SDIVN(SDIV)_":"
..W !?(50-SDIVL),$J(SDX,(28+SDIVL)),?80,$J(SDAPT,6,0)
..Q
.Q
W !?(50-SDIVL),$E(SDLINE,1,(36+SDIVL)),!?72,"TOTAL:",?80,$J(SDTOT,6,0)
AQ I $E(IOST)="C",'SDOUT N DIR S DIR(0)="E" D ^DIR
Q
;
DIV(SDIV) ;Check division
S:'$L(SDIV) SDIV=$$PRIM^VASITE()
Q:'SDDIV 1 Q $D(SDDIV(+SDIV))
;
;
STOP ;Check for stop task request
S:$G(ZTQUEUED) (SDOUT,ZTSTOP)=$S($$S^%ZTLOAD:1,1:0) Q
;
ADPRT(SDIV) ;Print report for a division
D DHDR^SCRPW40(3,.SDT) S:SDELIM SDPAGE=1
I '$D(^TMP("SCRPW",$J,SDIV)) D HDR^SCRPW62 Q:SDOUT D Q
.S SDX="No appointments found for this division within report parameters!"
.I SDELIM W !,SDX Q
.W !!?(132-$L(SDX)\2),SDX Q
D HDR^SCRPW62 Q:SDOUT
S SDEL="" F S SDEL=$O(^TMP("SCRPW",$J,SDIV,SDEL)) Q:'SDEL!SDOUT D
.S SDNAME="" F S SDNAME=$O(^TMP("SCRPW",$J,SDIV,SDEL,SDNAME)) Q:SDNAME=""!SDOUT D
..S DFN=0 F S DFN=$O(^TMP("SCRPW",$J,SDIV,SDEL,SDNAME,DFN)) Q:'DFN!SDOUT D
...S SD0=$G(^DPT(DFN,0)) Q:'$L(SD0)
...S SDREL=$S(SDEL=1:0,1:+$P($G(^DPT(DFN,.372,0)),U,4))
...S SDREL=SDREL+^TMP("SCRPW",$J,SDIV,SDEL,SDNAME,DFN)
...D:$Y>(IOSL-(4+SDREL)) HDR^SCRPW62 Q:SDOUT
...D PLINE(DFN,SD0,SDEL)
...Q
..Q
.Q
Q
;
PLINE(DFN,SD0,SDEL) ;Print patient detail line
;Input: DFN=patient ifn
; SD0=zeroeth node of patient record
; SDEL=1 or 3 to denote SC > or < 50%
;
N SDSSN,SDNAME,SDDTE,SDADD,SDST,SDX,SDI,SDY,SDELN,SDZIP,SDZ,SDZA,SDII
S SDNAME=$P(SD0,U),SDSSN=$P(SD0,U,9),SDDTE=$$FMTE^XLFDT($P(SD0,U,16))
S SDSSN=$E(SDSSN,1,3)_"-"_$E(SDSSN,4,5)_"-"_$E(SDSSN,6,10)
S SDEL=$G(SDEL),SDELN=$$CSCEL(SDEL),SDADD=$G(^DPT(DFN,.11))
S SDST=$P($G(^DIC(5,+$P(SDADD,U,5),0)),U,2),SDZIP=$P(SDADD,U,12)
S:$L(SDZIP)=9 SDZIP=$E(SDZIP,1,5)_"-"_$E(SDZIP,6,9)
I SDELIM D ;Set up delimited output
.S SDZ=SDNAME_U_SDSSN_U_SDELN_U_SDDTE_U_$P(SDADD,U)_U_$P(SDADD,U,4)
.S SDZ=SDZ_U_SDST_U_SDZIP_U_$P($G(^DPT(DFN,.13)),U)
.Q
I 'SDELIM D
.;Print name, SSN, eligibility, date entered, address and phone number
.W !,"Name: ",SDNAME,?39,"SSN: ",SDSSN,?58,"Prim. Elig.: ",SDELN
.W ?84,"Date entered: ",SDDTE,!?10,"Address: ",$P(SDADD,U)
.W ?55,$P(SDADD,U,4),$S($L($P(SDADD,U,4)):", ",1:""),SDST," ",SDZIP
.W ?88,"Phone number: ",$P($G(^DPT(DFN,.13)),U)
.;Print SC disabilities for 0-50% SC veterans
.I SDEL=3 S SDI=0 F S SDI=$O(^DPT(DFN,.372,SDI)) Q:'SDI D
..S SDX=$G(^DPT(DFN,.372,SDI,0)) Q:'$P(SDX,U,3)
..S SDY=$G(^DIC(31,+SDX,0)) Q:'$L(SDY)
..W !?20,"SC disability: ",$P(SDY,U,3)," ",$P(SDY,U)
..W ?89,"%SC: ",$P(SDX,U,2)
..Q
.Q
I SDRPT="E" D Q
.I SDELIM S SDZ(1)=SDZ D DELIM^SCRPW62(.SDZ) Q ;W !,SDZ Q
.W !
.Q
;Print appointment details for future appointment report
S SDI=0 D
.F S SDI=$O(^TMP("SCRPW",$J,SDIV,SDEL,SDNAME,DFN,SDI)) Q:'SDI D
..S SDA0=^TMP("SCRPW",$J,SDIV,SDEL,SDNAME,DFN,SDI)
..I 'SDELIM D
...W !?30,"Appointment: ",$$FMTE^XLFDT(SDI)
...W ?63,$P($G(^SC(+$P(SDA0,U,2),0)),U),?96,"Desired date: "
...W $$FMTE^XLFDT(+SDA0),?124,"(",$$FMDIFF^XLFDT(SDI,+SDA0),")"
...Q
..I SDELIM D ;Delimited output
...N SDC0,SDCP,SDCZ,SDADM,SDADME
...S SDC0=$G(^SC(+$P(SDA0,U,2),0)),SDCZ=$$CPAIR^SCRPW71(SDC0,.SDCP)
...S SDII=0,(SDZA,SDADM,SDADME)=""
...F S SDII=$O(^SC(+$P(SDA0,U,2),"S",SDI,1,SDII)) D Q:'SDII
....Q:+$G(^SC(+$P(SDA0,U,2),"S",SDI,1,+SDII,0))'=DFN
....S SDADM=$P(^SC(+$P(SDA0,U,2),"S",SDI,1,+SDII,0),U,7)
....S SDADME=$$FMTE^XLFDT(SDADM),SDII=0
....Q
...S SDCZ=SDCP_U_$P($$SITE^VASITE(,$P(SDC0,U,15)),U,2)_U_SDADME
...S SDZA=SDZA_U_$$FMTE^XLFDT(SDI)_U_$P(SDC0,U)_U_SDCZ
...S SDZA=SDZA_U_$$FMTE^XLFDT(+SDA0)_U_$$FMDIFF^XLFDT(SDI,+SDA0)
...S SDZA=SDZA_U_$S(SDADM:$$FMDIFF^XLFDT(+SDA0,SDADM),1:"")
...S SDZ(1)=SDZ_SDZA
...D DELIM^SCRPW62(.SDZ) ;W !,SDZ,SDZA
...Q
..Q
.Q
W:'SDELIM ! Q
;
CSCEL(SDEL) ;Convert SC elig. to external
Q $S(SDEL=1:"SC 50-100%",SDEL=3:"SC < 50%",1:"")
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCRPW63 9865 printed Sep 23, 2025@20:20:23 Page 2
SCRPW63 ;BP-CIOFO/KEITH - SC veterans awaiting appointments (cont.) ; 23 August 2002@20:23
+1 ;;5.3;Scheduling;**267,269,357,491**;AUG 13, 1993;Build 53
+2 ;
E ;Gather data for patients entered report
+1 NEW DFN,SDX,SDATE,SD0,SDSCEL,SDEL,SDYR,SDREL,SDTOT,SDSDT,SDLVDT,SDEDT
+2 NEW SDNAME
+3 ;Get eligibility code pointers
DO SCEL^SCRPW62(.SDSCEL,SDSCVT)
+4 SET (SDSDT,SDATE)=DT-(10000*SDATES)
SET SDSTOP=0
+5 ;Find the patients entered after date specified
+6 SET DFN=0
FOR
if SDSTOP
QUIT
SET DFN=$ORDER(^DPT(DFN))
if 'DFN
QUIT
Begin DoDot:1
+7 ;Skip merged records
if $DATA(^DPT(DFN,-9))
QUIT
+8 ;Check for stop task request
IF DFN#1000=0
DO STOP
if SDSTOP
QUIT
+9 SET SDLVDT=""
+10 SET SD0=$GET(^DPT(DFN,0))
if '$LENGTH(SD0)
QUIT
+11 SET SDEDT=$PIECE(SD0,U,16)
if SDEDT
SET SDLVDT=SDEDT
+12 ;Date entered < start date
IF SDEDT
IF SDEDT<SDATE
QUIT
+13 ;No date entered, last valid date < start
IF 'SDEDT
IF SDLVDT<SDATE
QUIT
+14 ;Only SC vets
SET SDEL=+$GET(^DPT(DFN,.36))
if '$DATA(SDSCEL(SDEL))
QUIT
+15 ;No deceased patients
if +$GET(^DPT(DFN,.35))
QUIT
+16 ;Appointments not cancelled by clinic?
if $$SCHAPP(DFN)
QUIT
+17 ;Year entered
SET SDYR=$$FMDIFF^XLFDT(DT,$SELECT(SDEDT:SDEDT,1:SDLVDT))\365.25
+18 SET SDEL=SDSCEL(SDEL)
Begin DoDot:2
+19 ;Record statistics
+20 SET ^TMP("SCRPW",$JOB,"STATS",SDYR,SDEL)=$GET(^TMP("SCRPW",$JOB,"STATS",SDYR,SDEL))+1
+21 QUIT
End DoDot:2
if SDFMT="S"
QUIT
+22 SET SDNAME=$PIECE(SD0,U)
if '$LENGTH(SDNAME)
QUIT
+23 SET ^TMP("SCRPW",$JOB,SDEL,SDNAME,DFN)=SD0
+24 QUIT
End DoDot:1
+25 if SDSTOP
QUIT
+26 if $EXTRACT(IOST,1,2)="C-"
DO DISP0^SCRPW23
+27 ;Negative report
IF '$DATA(^TMP("SCRPW",$JOB))
Begin DoDot:1
+28 DO HDR^SCRPW62
SET SDX="No patients found within report parameters!"
+29 WRITE !!?(132-$LENGTH(SDX)\2),SDX
+30 IF $EXTRACT(IOST)="C"
IF 'SDOUT
NEW DIR
SET DIR(0)="E"
DO ^DIR
+31 QUIT
End DoDot:1
QUIT
+32 ;Detailed report
+33 IF SDFMT="D"
DO HDR^SCRPW62
SET SDEL=0
FOR
SET SDEL=$ORDER(^TMP("SCRPW",$JOB,SDEL))
if 'SDEL!SDOUT
QUIT
Begin DoDot:1
+34 SET SDNAME=""
FOR
SET SDNAME=$ORDER(^TMP("SCRPW",$JOB,SDEL,SDNAME))
if SDNAME=""!SDOUT
QUIT
SET DFN=0
Begin DoDot:2
+35 FOR
SET DFN=$ORDER(^TMP("SCRPW",$JOB,SDEL,SDNAME,DFN))
if 'DFN!SDOUT
QUIT
Begin DoDot:3
+36 SET SDREL=$SELECT(SDEL=1:0,1:+$PIECE($GET(^DPT(DFN,.372,0)),U,4))
+37 if $Y>(IOSL-(4+SDREL))
DO HDR^SCRPW62
if SDOUT
QUIT
+38 SET SDX=^TMP("SCRPW",$JOB,SDEL,SDNAME,DFN)
DO PLINE(DFN,SDX,SDEL)
+39 QUIT
End DoDot:3
End DoDot:2
+40 QUIT
End DoDot:1
+41 if SDOUT
QUIT
ESUM ;Print summary
+1 if SDELIM
GOTO EQ
+2 SET SDT(3)="STATISTICAL SUMMARY"
DO HDR^SCRPW62
if SDOUT
QUIT
+3 WRITE !!
SET SDYR=""
SET SDTOT=0
+4 FOR
SET SDYR=$ORDER(^TMP("SCRPW",$JOB,"STATS",SDYR))
if SDYR=""
QUIT
Begin DoDot:1
+5 SET SDEL=0
FOR
SET SDEL=$ORDER(^TMP("SCRPW",$JOB,"STATS",SDYR,SDEL))
if 'SDEL
QUIT
Begin DoDot:2
+6 SET SDX=$$CSCEL(SDEL)_" veterans entered "_$SELECT(SDYR=0:"in the past year",SDYR=1:"two years ago",SDYR=2:"three years ago",1:"")_":"
+7 WRITE !?36,$JUSTIFY(SDX,45),?83,$JUSTIFY(^TMP("SCRPW",$JOB,"STATS",SDYR,SDEL),6,0)
+8 SET SDTOT=SDTOT+^TMP("SCRPW",$JOB,"STATS",SDYR,SDEL)
+9 QUIT
End DoDot:2
+10 QUIT
End DoDot:1
+11 WRITE !?36,$EXTRACT(SDLINE,1,53),!?75,"TOTAL:",?83,$JUSTIFY(SDTOT,6,0)
EQ IF $EXTRACT(IOST,1,2)="C-"
NEW DIR
SET DIR(0)="E"
WRITE !!
DO ^DIR
+1 QUIT
+2 ;
SCHAPP(DFN) ;Look for scheduled appointments not cancelled by clinic
+1 ; Input: DFN=patient ifn
+2 ;Output: '1' if appointments exist, '0' otherwise
+3 NEW SDI,SDX,SDY
+4 SET (SDI,SDY)=0
+5 FOR
SET SDI=$ORDER(^DPT(DFN,"S",SDI))
if 'SDI!SDY
QUIT
Begin DoDot:1
+6 SET SDX=$GET(^DPT(DFN,"S",SDI,0))
if '$LENGTH(SDX)
QUIT
+7 SET SDX=$PIECE(SDX,U,2)
IF $LENGTH(SDX)
IF "CA"[SDX
QUIT
+8 SET SDY=1
+9 QUIT
End DoDot:1
+10 QUIT SDY
+11 ;
A ;Gather data for future appointments report
+1 NEW DFN,SDA0,SDX,SDI,SDSCEL,SDEL,SDDATE,SDIFF,SDAPT,SDIVL,SDIVN
+2 NEW SDREL,SDTOT,SDIV,SD0,SDNAME
+3 ;Get eligibility code pointers
DO SCEL^SCRPW62(.SDSCEL,SDSCVT)
+4 SET DFN=0
FOR
SET DFN=$ORDER(^DPT(DFN))
if 'DFN!SDSTOP
QUIT
Begin DoDot:1
+5 ;Check for stop task request
IF DFN#1000=0
DO STOP
if SDSTOP
QUIT
+6 ;Only SC vets
SET SDEL=+$GET(^DPT(DFN,.36))
if '$DATA(SDSCEL(SDEL))
QUIT
+7 SET SDEL=SDSCEL(SDEL)
+8 ;No deceased patients
if +$GET(^DPT(DFN,.35))
QUIT
+9 SET SDI=DT
FOR
SET SDI=$ORDER(^DPT(DFN,"S",SDI))
if 'SDI
QUIT
Begin DoDot:2
+10 SET SDDATE=+$GET(^DPT(DFN,"S",SDI,1))
if 'SDDATE
QUIT
if SDDATE>SDI
QUIT
+11 SET SDA0=$GET(^DPT(DFN,"S",SDI,0))
if '$LENGTH(SDA0)
QUIT
+12 ;Division check
SET SDIV=$PIECE($GET(^SC(+SDA0,0)),U,15)
if '$$DIV(.SDIV)
QUIT
+13 ;Exclude cancelled appointments
+14 SET SDX=$PIECE(SDA0,U,2)
IF $LENGTH(SDX)
IF "PCA"[SDX
QUIT
+15 SET SDIFF=$$FMDIFF^XLFDT(SDI,SDDATE)
if SDIFF'>SDATES
QUIT
+16 SET SDNAME=$PIECE($GET(^DPT(DFN,0)),U)
if '$LENGTH(SDNAME)
QUIT
+17 ;Record detailed information
+18 SET ^TMP("SCRPW",$JOB,SDIV,SDEL,SDNAME,DFN,SDI)=SDDATE_U_SDA0
+19 SET ^TMP("SCRPW",$JOB,SDIV,SDEL,SDNAME,DFN)=$GET(^TMP("SCRPW",$JOB,SDIV,SDEL,SDNAME,DFN))+1
+20 QUIT
End DoDot:2
+21 QUIT
End DoDot:1
+22 if SDSTOP
QUIT
+23 ;Tally up statistics
+24 SET SDIV=0
FOR
SET SDIV=$ORDER(^TMP("SCRPW",$JOB,SDIV))
if 'SDIV
QUIT
Begin DoDot:1
+25 SET SDEL=0
FOR
SET SDEL=$ORDER(^TMP("SCRPW",$JOB,SDIV,SDEL))
if 'SDEL
QUIT
Begin DoDot:2
+26 SET SDNAME=""
FOR
SET SDNAME=$ORDER(^TMP("SCRPW",$JOB,SDIV,SDEL,SDNAME))
if SDNAME=""!SDOUT
QUIT
Begin DoDot:3
+27 SET DFN=0
FOR
SET DFN=$ORDER(^TMP("SCRPW",$JOB,SDIV,SDEL,SDNAME,DFN))
if 'DFN
QUIT
Begin DoDot:4
+28 SET ^TMP("SCRPW",$JOB,"STATS",SDIV,SDEL,"PTS")=$GET(^TMP("SCRPW",$JOB,"STATS",SDIV,SDEL,"PTS"))+1
+29 SET SDI=0
FOR
SET SDI=$ORDER(^TMP("SCRPW",$JOB,SDIV,SDEL,SDNAME,DFN,SDI))
if 'SDI
QUIT
Begin DoDot:5
+30 SET ^TMP("SCRPW",$JOB,"STATS",SDIV,SDEL,"APPTS")=$GET(^TMP("SCRPW",$JOB,"STATS",SDIV,SDEL,"APPTS"))+1
+31 QUIT
End DoDot:5
+32 QUIT
End DoDot:4
+33 QUIT
End DoDot:3
+34 QUIT
End DoDot:2
+35 QUIT
End DoDot:1
+36 if SDSTOP
QUIT
+37 ;Print report
+38 SET SDIV=""
FOR
SET SDIV=$ORDER(SDDIV(SDIV))
if 'SDIV
QUIT
SET SDIV(SDDIV(SDIV))=SDIV
+39 IF 'SDDIV
IF $PIECE(SDDIV,U,2)'="ALL DIVISIONS"
Begin DoDot:1
+40 SET SDIV($PIECE(SDDIV,U,2))=$$PRIM^VASITE()
+41 QUIT
End DoDot:1
+42 IF $PIECE(SDDIV,U,2)="ALL DIVISIONS"
SET SDI=0
Begin DoDot:1
+43 FOR
SET SDI=$ORDER(^TMP("SCRPW",$JOB,SDI))
if 'SDI
QUIT
Begin DoDot:2
+44 SET SDX=$PIECE($GET(^DG(40.8,SDI,0)),U)
if $LENGTH(SDX)
SET SDIV(SDX)=SDI
+45 QUIT
End DoDot:2
+46 QUIT
End DoDot:1
+47 if $EXTRACT(IOST)="C"
DO DISP0^SCRPW23
+48 ;Negative report
IF '$DATA(^TMP("SCRPW",$JOB))
Begin DoDot:1
+49 SET SDIV=0
DO DHDR^SCRPW40(3,.SDT)
DO HDR^SCRPW62
+50 SET SDX="No appointments found that meet report criteria."
+51 IF SDELIM
WRITE !,SDX
QUIT
+52 WRITE !!?(IOM-$LENGTH(SDX)\2),SDX
+53 IF $EXTRACT(IOST)="C"
IF 'SDOUT
NEW DIR
SET DIR(0)="E"
DO ^DIR
+54 QUIT
End DoDot:1
QUIT
+55 if SDFMT="S"
GOTO ASUM
+56 ;Print detailed report by division
+57 SET SDIVN=""
FOR
SET SDIVN=$ORDER(SDIV(SDIVN))
if SDIVN=""!SDOUT
QUIT
Begin DoDot:1
+58 SET SDIV=SDIV(SDIVN)
DO ADPRT(.SDIV)
+59 QUIT
End DoDot:1
+60 if SDOUT
QUIT
+61 ;Print summary
ASUM if SDELIM
GOTO AQ
+1 SET SDT(3)="STATISTICAL SUMMARY"
DO HDR^SCRPW62
if SDOUT
QUIT
+2 WRITE !!
SET (SDTOT,SDIV,SDIVL)=0
SET SDIVN=""
+3 FOR
SET SDIVN=$ORDER(SDIV(SDIVN))
if SDIVN=""
QUIT
Begin DoDot:1
+4 SET SDIVN(SDIV(SDIVN))=SDIVN
if $LENGTH(SDIVN)>SDIVL
SET SDIVL=$LENGTH(SDIVN)
End DoDot:1
+5 FOR
SET SDIV=$ORDER(^TMP("SCRPW",$JOB,"STATS",SDIV))
if 'SDIV
QUIT
Begin DoDot:1
+6 SET SDEL=0
FOR
SET SDEL=$ORDER(^TMP("SCRPW",$JOB,"STATS",SDIV,SDEL))
if 'SDEL
QUIT
Begin DoDot:2
+7 SET SDAPT=^TMP("SCRPW",$JOB,"STATS",SDIV,SDEL,"APPTS")
SET SDTOT=SDTOT+SDAPT
+8 SET SDX=$$CSCEL(SDEL)_" appointments at "_SDIVN(SDIV)_":"
+9 WRITE !?(50-SDIVL),$JUSTIFY(SDX,(28+SDIVL)),?80,$JUSTIFY(SDAPT,6,0)
+10 QUIT
End DoDot:2
+11 QUIT
End DoDot:1
+12 WRITE !?(50-SDIVL),$EXTRACT(SDLINE,1,(36+SDIVL)),!?72,"TOTAL:",?80,$JUSTIFY(SDTOT,6,0)
AQ IF $EXTRACT(IOST)="C"
IF 'SDOUT
NEW DIR
SET DIR(0)="E"
DO ^DIR
+1 QUIT
+2 ;
DIV(SDIV) ;Check division
+1 if '$LENGTH(SDIV)
SET SDIV=$$PRIM^VASITE()
+2 if 'SDDIV
QUIT 1
QUIT $DATA(SDDIV(+SDIV))
+3 ;
+4 ;
STOP ;Check for stop task request
+1 if $GET(ZTQUEUED)
SET (SDOUT,ZTSTOP)=$SELECT($$S^%ZTLOAD:1,1:0)
QUIT
+2 ;
ADPRT(SDIV) ;Print report for a division
+1 DO DHDR^SCRPW40(3,.SDT)
if SDELIM
SET SDPAGE=1
+2 IF '$DATA(^TMP("SCRPW",$JOB,SDIV))
DO HDR^SCRPW62
if SDOUT
QUIT
Begin DoDot:1
+3 SET SDX="No appointments found for this division within report parameters!"
+4 IF SDELIM
WRITE !,SDX
QUIT
+5 WRITE !!?(132-$LENGTH(SDX)\2),SDX
QUIT
End DoDot:1
QUIT
+6 DO HDR^SCRPW62
if SDOUT
QUIT
+7 SET SDEL=""
FOR
SET SDEL=$ORDER(^TMP("SCRPW",$JOB,SDIV,SDEL))
if 'SDEL!SDOUT
QUIT
Begin DoDot:1
+8 SET SDNAME=""
FOR
SET SDNAME=$ORDER(^TMP("SCRPW",$JOB,SDIV,SDEL,SDNAME))
if SDNAME=""!SDOUT
QUIT
Begin DoDot:2
+9 SET DFN=0
FOR
SET DFN=$ORDER(^TMP("SCRPW",$JOB,SDIV,SDEL,SDNAME,DFN))
if 'DFN!SDOUT
QUIT
Begin DoDot:3
+10 SET SD0=$GET(^DPT(DFN,0))
if '$LENGTH(SD0)
QUIT
+11 SET SDREL=$SELECT(SDEL=1:0,1:+$PIECE($GET(^DPT(DFN,.372,0)),U,4))
+12 SET SDREL=SDREL+^TMP("SCRPW",$JOB,SDIV,SDEL,SDNAME,DFN)
+13 if $Y>(IOSL-(4+SDREL))
DO HDR^SCRPW62
if SDOUT
QUIT
+14 DO PLINE(DFN,SD0,SDEL)
+15 QUIT
End DoDot:3
+16 QUIT
End DoDot:2
+17 QUIT
End DoDot:1
+18 QUIT
+19 ;
PLINE(DFN,SD0,SDEL) ;Print patient detail line
+1 ;Input: DFN=patient ifn
+2 ; SD0=zeroeth node of patient record
+3 ; SDEL=1 or 3 to denote SC > or < 50%
+4 ;
+5 NEW SDSSN,SDNAME,SDDTE,SDADD,SDST,SDX,SDI,SDY,SDELN,SDZIP,SDZ,SDZA,SDII
+6 SET SDNAME=$PIECE(SD0,U)
SET SDSSN=$PIECE(SD0,U,9)
SET SDDTE=$$FMTE^XLFDT($PIECE(SD0,U,16))
+7 SET SDSSN=$EXTRACT(SDSSN,1,3)_"-"_$EXTRACT(SDSSN,4,5)_"-"_$EXTRACT(SDSSN,6,10)
+8 SET SDEL=$GET(SDEL)
SET SDELN=$$CSCEL(SDEL)
SET SDADD=$GET(^DPT(DFN,.11))
+9 SET SDST=$PIECE($GET(^DIC(5,+$PIECE(SDADD,U,5),0)),U,2)
SET SDZIP=$PIECE(SDADD,U,12)
+10 if $LENGTH(SDZIP)=9
SET SDZIP=$EXTRACT(SDZIP,1,5)_"-"_$EXTRACT(SDZIP,6,9)
+11 ;Set up delimited output
IF SDELIM
Begin DoDot:1
+12 SET SDZ=SDNAME_U_SDSSN_U_SDELN_U_SDDTE_U_$PIECE(SDADD,U)_U_$PIECE(SDADD,U,4)
+13 SET SDZ=SDZ_U_SDST_U_SDZIP_U_$PIECE($GET(^DPT(DFN,.13)),U)
+14 QUIT
End DoDot:1
+15 IF 'SDELIM
Begin DoDot:1
+16 ;Print name, SSN, eligibility, date entered, address and phone number
+17 WRITE !,"Name: ",SDNAME,?39,"SSN: ",SDSSN,?58,"Prim. Elig.: ",SDELN
+18 WRITE ?84,"Date entered: ",SDDTE,!?10,"Address: ",$PIECE(SDADD,U)
+19 WRITE ?55,$PIECE(SDADD,U,4),$SELECT($LENGTH($PIECE(SDADD,U,4)):", ",1:""),SDST," ",SDZIP
+20 WRITE ?88,"Phone number: ",$PIECE($GET(^DPT(DFN,.13)),U)
+21 ;Print SC disabilities for 0-50% SC veterans
+22 IF SDEL=3
SET SDI=0
FOR
SET SDI=$ORDER(^DPT(DFN,.372,SDI))
if 'SDI
QUIT
Begin DoDot:2
+23 SET SDX=$GET(^DPT(DFN,.372,SDI,0))
if '$PIECE(SDX,U,3)
QUIT
+24 SET SDY=$GET(^DIC(31,+SDX,0))
if '$LENGTH(SDY)
QUIT
+25 WRITE !?20,"SC disability: ",$PIECE(SDY,U,3)," ",$PIECE(SDY,U)
+26 WRITE ?89,"%SC: ",$PIECE(SDX,U,2)
+27 QUIT
End DoDot:2
+28 QUIT
End DoDot:1
+29 IF SDRPT="E"
Begin DoDot:1
+30 ;W !,SDZ Q
IF SDELIM
SET SDZ(1)=SDZ
DO DELIM^SCRPW62(.SDZ)
QUIT
+31 WRITE !
+32 QUIT
End DoDot:1
QUIT
+33 ;Print appointment details for future appointment report
+34 SET SDI=0
Begin DoDot:1
+35 FOR
SET SDI=$ORDER(^TMP("SCRPW",$JOB,SDIV,SDEL,SDNAME,DFN,SDI))
if 'SDI
QUIT
Begin DoDot:2
+36 SET SDA0=^TMP("SCRPW",$JOB,SDIV,SDEL,SDNAME,DFN,SDI)
+37 IF 'SDELIM
Begin DoDot:3
+38 WRITE !?30,"Appointment: ",$$FMTE^XLFDT(SDI)
+39 WRITE ?63,$PIECE($GET(^SC(+$PIECE(SDA0,U,2),0)),U),?96,"Desired date: "
+40 WRITE $$FMTE^XLFDT(+SDA0),?124,"(",$$FMDIFF^XLFDT(SDI,+SDA0),")"
+41 QUIT
End DoDot:3
+42 ;Delimited output
IF SDELIM
Begin DoDot:3
+43 NEW SDC0,SDCP,SDCZ,SDADM,SDADME
+44 SET SDC0=$GET(^SC(+$PIECE(SDA0,U,2),0))
SET SDCZ=$$CPAIR^SCRPW71(SDC0,.SDCP)
+45 SET SDII=0
SET (SDZA,SDADM,SDADME)=""
+46 FOR
SET SDII=$ORDER(^SC(+$PIECE(SDA0,U,2),"S",SDI,1,SDII))
Begin DoDot:4
+47 if +$GET(^SC(+$PIECE(SDA0,U,2),"S",SDI,1,+SDII,0))'=DFN
QUIT
+48 SET SDADM=$PIECE(^SC(+$PIECE(SDA0,U,2),"S",SDI,1,+SDII,0),U,7)
+49 SET SDADME=$$FMTE^XLFDT(SDADM)
SET SDII=0
+50 QUIT
End DoDot:4
if 'SDII
QUIT
+51 SET SDCZ=SDCP_U_$PIECE($$SITE^VASITE(,$PIECE(SDC0,U,15)),U,2)_U_SDADME
+52 SET SDZA=SDZA_U_$$FMTE^XLFDT(SDI)_U_$PIECE(SDC0,U)_U_SDCZ
+53 SET SDZA=SDZA_U_$$FMTE^XLFDT(+SDA0)_U_$$FMDIFF^XLFDT(SDI,+SDA0)
+54 SET SDZA=SDZA_U_$SELECT(SDADM:$$FMDIFF^XLFDT(+SDA0,SDADM),1:"")
+55 SET SDZ(1)=SDZ_SDZA
+56 ;W !,SDZ,SDZA
DO DELIM^SCRPW62(.SDZ)
+57 QUIT
End DoDot:3
+58 QUIT
End DoDot:2
+59 QUIT
End DoDot:1
+60 if 'SDELIM
WRITE !
QUIT
+61 ;
CSCEL(SDEL) ;Convert SC elig. to external
+1 QUIT $SELECT(SDEL=1:"SC 50-100%",SDEL=3:"SC < 50%",1:"")
