SDPBP ; BP-IOFO/OWAIN ; Pharmacy Benefits Print. ; ; Compiled November 13, 2003 09:55:19
;;5.3;Scheduling;**318**; SEP 29, 2003
;
EN0 ; Inquire date range.
K %DT
S %DT="AEX",%DT("A")="Appointment start date for report: "
D ^%DT Q:Y=-1
K %DT
S (SDT,%DT(0))=Y K Y
S %DT="AEX",%DT("A")="Appointment end date for report: "
D ^%DT Q:Y=-1
S EDT=Y
S DIR("?",1)="Enter YES to show only summary totals.",DIR("?")="Enter NO to list patient level details as well."
S DIR("A")="Summary?",DIR(0)="Y",DIR("B")="YES" D ^DIR
K DIR
Q:Y="^"
S SDSUMM=Y
D DEV
Q
;
EN ;
N SDCL,SDSS,NAME,DFN,INST,LINE,MAXLEN,PAGE,TODAY,CTR,SDCUTOFF,SDCUTOFD,TDAYS,TRSA
D INIT(.SDSS)
S (SDCL,CTR)=0,(SDCUTOFF,Y)=3031022 D DD^%DT S SDCUTOFD=Y
D SCH^PSOTPCAN ; Pharmacy call to generate ^TMP global of eligible patients.
D NOW^%DTC S TODAY=X
S NAME=""
F S NAME=$O(^TMP($J,"PSODFN",NAME)) Q:NAME="" D
.S DFN=0
.F S DFN=$O(^TMP($J,"PSODFN",NAME,DFN)) Q:+DFN'=DFN D
..N SDAPDTT,SSN,SSNP,SEL,RESCHED
..D DEM^VADPT
..S (SSN,SSNP)="" S SSN=$P($G(VADM(2)),"^") I SSN["P" S SSNP="P",SSN=$E(SSN,1,9) ; Social security number.
..Q:$E(SSN,1,5)="00000" ; Exclude test patients.
..S SDAPDTT=$O(^DPT(DFN,"S",SDT),-1)
..F S SDAPDTT=$O(^DPT(DFN,"S",SDAPDTT)) Q:+SDAPDTT'=SDAPDTT!(SDAPDTT>(EDT+.24)) D
...N SDAP0,SDCL0,SDCP,SDST,SDNAPDT,DAYS
...S SDAP0=^DPT(DFN,"S",SDAPDTT,0),SDCL=+SDAP0
...S SDCL0=$G(^SC(SDCL,0)) Q:'$L(SDCL0) ; Get clinic 0 node.
...S SDCP=$$CPAIR(SDCL0) ; Get DSS credit pair.
...Q:'$D(SDSS(SDCP)) ; Not a primary care appointment.
...S SDST=$P(SDAP0,U,2),SDCDTT=$P(SDAP0,U,14)
...S INST=$$DIV(SDCL0)
...I 'INST S INST(0)="*NO INSTITUTION"
...E S INST(INST)=$$GET1^DIQ(4,INST_",",.01)
...S RESCHED=$$RESCHED(DFN,SDAPDTT,SDCL,SDST,.SDNAPDT)
...I 'RESCHED S SEL(INST,SDAPDTT)=SDCL Q
...S:'$D(RESCHED(INST)) RESCHED(INST)=2
...S X1=SDNAPDT,X2=SDAPDTT D ^%DTC S DAYS=X
...S Y=SDAPDTT\1 D DD^%DT S SDAPDTT0=Y
...I SDNAPDT'="" S Y=SDNAPDT\1 D DD^%DT S SDNAPDT=Y
...S ^TMP($J,"SDOUT",INST(INST),"PT",NAME,DFN,SDAPDTT)=$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,10)_U_$$GET1^DIQ(44,SDCL_",",.01)_U_SDAPDTT0_U_$S($E(SDST)="N":"No-Show",1:"Canc by Patient")_U_SDNAPDT_U_DAYS
...Q:SDAPDTT<SDCUTOFF!(RESCHED=2)
...S RESCHED(INST)=1
...S ^TMP($J,"SDOUT",INST(INST),"CAN")=$G(^TMP($J,"SDOUT",INST(INST),"CAN"))+1
...S ^TMP($J,"SDOUT",INST(INST),"RSA")=$G(^TMP($J,"SDOUT",INST(INST),"RSA"))+1
...S ^TMP($J,"SDOUT",INST(INST),"DAYS")=$G(^TMP($J,"SDOUT",INST(INST),"DAYS"))+DAYS
...Q
..; For episodes that were not no-show or cancelled by patient, show the first
..; future appointment or if there is not a future appointment the nearest
..; previous appointment.
..S INST=""
..S SSN=SSN_SSNP
..F S INST=$O(SEL(INST)) Q:INST="" D:'$D(^TMP($J,"SDOUT",INST(INST),"PT",NAME,DFN))
...S SDAPDTT="" D
....S SDAPDTT1=$O(SEL(INST,TODAY))
....S SDAPDTT0=$O(SEL(INST,TODAY),-1)
....I SDAPDTT0="" S SDAPDTT=SDAPDTT1 Q
....I SDAPDTT1="" S SDAPDTT=SDAPDTT0 Q
....S X1=SDAPDTT0,X2=TODAY D ^%DTC S X0=X
....S X1=TODAY,X2=SDAPDTT1 D ^%DTC
....S SDAPDTT=$S(X0<X:SDAPDTT0,1:SDAPDTT1)
....Q
...I SDAPDTT'="" D
....S Y=SDAPDTT\1 D DD^%DT S SDNEAPT=Y
....S ^TMP($J,"SDOUT",INST(INST),"PT",NAME,DFN,SDAPDTT)=$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,10)_U_$$GET1^DIQ(44,SEL(INST,SDAPDTT)_",",.01)_U_U_U_SDNEAPT
....Q
...Q
..S INST=""
..F S INST=$O(RESCHED(INST)) Q:INST="" I RESCHED(INST)=1 S ^TMP($J,"SDOUT",INST(INST),"RSP")=$G(^TMP($J,"SDOUT",INST(INST),"RSP"))+1
..Q
.Q
;
S PAGE=0,(TDAYS,TRSA)=0
I 'SDSUMM D
.D HEAD10
.I '$D(^TMP($J,"SDOUT")) W !!!?47,"********** NO DATA TO PRINT **********" Q
.D HEAD20
.S INSTX=""
.F S INSTX=$O(^TMP($J,"SDOUT",INSTX)) Q:INSTX="" D Q:CTR
..I LINE+5>IOSL D HEAD10 Q:CTR D HEAD20
..W !!,"Institution : ",INSTX,! S LINE=LINE+3
..S NAME=""
..F S NAME=$O(^TMP($J,"SDOUT",INSTX,"PT",NAME)) Q:NAME="" D Q:CTR
...S DFN=0
...F S DFN=$O(^TMP($J,"SDOUT",INSTX,"PT",NAME,DFN)) Q:+DFN'=DFN D
....S SDAPDT=0
....F S SDAPDT=$O(^TMP($J,"SDOUT",INSTX,"PT",NAME,DFN,SDAPDT)) Q:+SDAPDT'=SDAPDT D
.....N REC
.....S REC=^TMP($J,"SDOUT",INSTX,"PT",NAME,DFN,SDAPDT)
.....I LINE+($P(REC,U,6)'="")+2>IOSL D HEAD10 Q:CTR D HEAD20
.....W !,$E(NAME,1,33),?38,$P(REC,U),?52,$E($P(REC,U,2),1,33),?89,$P(REC,U,3),?103,$P(REC,U,4),?120,$P(REC,U,5)
.....S LINE=LINE+1
.....I $P(REC,U,6)'="" W !?8,"Deferred Number of Days: ",$P(REC,U,6) S LINE=LINE+1
.....Q
....Q
...Q
..I LINE+5>IOSL D HEAD10
..D HEAD21,SUMMARY
..Q
.Q
I SDSUMM D
.N INSTX,X,CAN
.D HEAD10,HEAD21
.S (INSTX,X)=""
.F S INSTX=$O(^TMP($J,"SDOUT",INSTX)) Q:INSTX="" S CAN=+$G(^TMP($J,"SDOUT",INSTX,"CAN")) D SUMMARY Q:CTR
.I X="" W !!!?21,"********** NO DATA TO PRINT **********"
.E W !!,"Overall average time between appointments : ",$S(TRSA=0:$J(TDAYS,2),1:$J(TDAYS/TRSA,2))
.Q
;
K ^TMP($J,"PSODFN"),^TMP($J,"SDOUT")
Q:CTR
I $E(IOST)="C" S DIR(0)="E" D ^DIR
Q
;
SUMMARY ;
; In - INSTX, IOSL
; Out - TRSA, TDAYS
;
N RSA,DAYS
S X=INSTX
S RSA=+$G(^TMP($J,"SDOUT",INSTX,"RSA")),TRSA=TRSA+RSA
S DAYS=+$G(^TMP($J,"SDOUT",INSTX,"DAYS")),TDAYS=TDAYS+DAYS
I LINE+2>IOSL D HEAD10 Q:CTR D HEAD21
W !
W:SDSUMM X,?9,INST
W ?41,+$G(^TMP($J,"SDOUT",INSTX,"CAN"))
W ?52,RSA
W ?62,+$G(^TMP($J,"SDOUT",INSTX,"RSP"))
W ?71,$S(RSA=0:"0.00",1:$J(DAYS/RSA,"",2))
S LINE=LINE+1
Q
;
BUILD(NAME,SSN,SDCL,SDST,SDCAPDTT,SDNEAPT) ;
N DAYS,INST
S DAYS=""
I SDCAPDTT'="" D
.S X1=SDNEAPT,X2=SDAPDTT D ^%DTC S DAYS=X
.S Y=SDCAPDTT\1 D DD^%DT S SDCAPDTT=Y
.Q
I SDNEAPT'="" S Y=SDNEAPT\1 D DD^%DT S SDNEAPT=Y
; Get institution for 3rd node.
; The patient names are already in alphabetical order so a numeric index is sufficient.
S UNQ=$O(^TMP($J,"SDOUT",INST,"PT",NAME,":"),-1)+1
S ^TMP($J,"SDOUT",INST,"PT",NAME,UNQ)=$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,10)_U_$$GET1^DIQ(44,SDCL_",",.01)_U_SDCAPDTT_U_$S(SDST="N":"No-Show",SDST="P":"Canc by Patient",1:"")_U_SDNEAPT_U_DAYS
Q
;
RESCHED(DFN,SDAPDTT,SDCL,SDST,SDNAPDT) ; Search for a subsequent appointment at the same clinic.
; 0 - no rescheduled appointment
; 1 - cancelled by patient and rescheduled
; 2 - no-show and rescheduled
N SDOK
I SDST="NA"!(SDST="PCA") S SDNAPDT=$P(^DPT(DFN,"S",SDAPDTT,0),U,10) Q:SDNAPDT>SDAPDTT SDST="NA"+1
Q:SDST'="N"&(SDST'="PC") 0
S SDOK=0,SDNAPDT=""
F S SDAPDTT=$O(^DPT(DFN,"S",SDAPDTT)) Q:+SDAPDTT'=SDAPDTT S SDOK=$P(^DPT(DFN,"S",SDAPDTT,0),U)=SDCL I SDOK S SDNAPDT=SDAPDTT Q
Q (SDST="NA"+1)*SDOK
;
HEAD10 ;
S PAGE=PAGE+1
I PAGE>1,$E(IOST)="C" S DIR(0)="E" D ^DIR I $D(DIRUT) S CTR=1 Q
S SDTTL="Transitional Pharmacy Benefit Deferred Appointment Report"
I SDSUMM S SDTTL=SDTTL_" (Summary)"
W @IOF,!?IOM-$L(SDTTL)\2,SDTTL
I 'SDSUMM W ?122,"Page : "_PAGE
S Y=SDT D DD^%DT
S SDTTL="Report for the period of "_Y_" and "
S Y=EDT D DD^%DT
S SDTTL=SDTTL_Y
W !?IOM-$L(SDTTL)\2,SDTTL
W !
S LINE=4
Q
;
HEAD20 ;
W !?89,"Cancelled",?103,"Reason for",?120,"New/Closest"
W !,"Patient",?38,"SSN",?52,"Clinic",?89,"Appt. Date",?103,"Cancellation",?120,"Appt. Date"
W !,"=======",?38,"===",?52,"======",?89,"==========",?103,"============",?120,"==========="
S LINE=LINE+3
Q
;
HEAD21 ;
W !!
W:'SDSUMM "Count for appts. after "_SDCUTOFD
W ?41,"Appts",?52,"Appts",?62,"Patients",?71,"Ave time"
W !
W:SDSUMM "Institution"
W ?41,"Cancelled",?52,"Deferred",?62,"Deferred",?71,"/appts"
W !
W:SDSUMM "==========="
W ?41,"=========",?52,"========",?62,"========",?71,"========"
S LINE=LINE+4
Q
;
INIT(SDSS) ;
N SDI,SDII
F SDI=322,323,350 F SDII="000",185,186,187 S SDSS(SDI_SDII)=""
K ^TMP($J,"SDOUT")
Q
;
CPAIR(SDCL0) ; Get credit pair
; Input: SDCL0=hospital location zeroeth node
N SDX
S SDX=$P($G(^DIC(40.7,+$P(SDCL0,U,7),0)),U,2)
S SDX=SDX_$P($G(^DIC(40.7,+$P(SDCL0,U,18),0)),U,2)
S SDX=$E(SDX_"000000",1,6)
Q SDX
;
DIV(SDCL0) ;Get facility division name and number
;Input: SDCL0=hospital location zeroeth node
N SDIVV,SDHOLD S SDIVV=$P(SDCL0,U,15)
S SDHOLD=0
I SDIVV>0 S SDHOLD=$P($$SITE^VASITE(,SDIVV),"^")
I SDHOLD>0 Q SDHOLD
S SDHOLD=$P(SDCL0,"^",4)
I 'SDHOLD Q 0
I SDHOLD,'$D(^DIC(4,SDHOLD,0)) S SDHOLD=0
Q SDHOLD
;
DEV ;
K %ZIS,IOP,POP,ZTSK S SDDIO=ION,%ZIS="QM" D ^%ZIS K %ZIS
S IOM=$S(SDSUMM:80,1:132)
I POP S IOP=SDDIO D ^%ZIS K IOP,SDDIO W !,"Please try later!" G END
K SDDIO I $D(IO("Q")) K IO("Q"),ZTIO,ZTSAVE,ZTDTH,ZTSK D G END
.S ZTRTN="EN^SDPBP",ZTDTH=$H,ZTDESC="TRANSITIONAL PHARMACY BENEFITS ELIGIBILITY PRINT"
.S ZTSAVE("SDT")=""
.S ZTSAVE("EDT")=""
.S ZTSAVE("SDSUMM")=""
.D ^%ZTLOAD W:$D(ZTSK) !,"Report is Queued to print !!" K ZTSK
.Q
D EN
END ;
W ! D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
K ^TMP($J)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDPBP 8864 printed Dec 13, 2024@02:59:27 Page 2
SDPBP ; BP-IOFO/OWAIN ; Pharmacy Benefits Print. ; ; Compiled November 13, 2003 09:55:19
+1 ;;5.3;Scheduling;**318**; SEP 29, 2003
+2 ;
EN0 ; Inquire date range.
+1 KILL %DT
+2 SET %DT="AEX"
SET %DT("A")="Appointment start date for report: "
+3 DO ^%DT
if Y=-1
QUIT
+4 KILL %DT
+5 SET (SDT,%DT(0))=Y
KILL Y
+6 SET %DT="AEX"
SET %DT("A")="Appointment end date for report: "
+7 DO ^%DT
if Y=-1
QUIT
+8 SET EDT=Y
+9 SET DIR("?",1)="Enter YES to show only summary totals."
SET DIR("?")="Enter NO to list patient level details as well."
+10 SET DIR("A")="Summary?"
SET DIR(0)="Y"
SET DIR("B")="YES"
DO ^DIR
+11 KILL DIR
+12 if Y="^"
QUIT
+13 SET SDSUMM=Y
+14 DO DEV
+15 QUIT
+16 ;
EN ;
+1 NEW SDCL,SDSS,NAME,DFN,INST,LINE,MAXLEN,PAGE,TODAY,CTR,SDCUTOFF,SDCUTOFD,TDAYS,TRSA
+2 DO INIT(.SDSS)
+3 SET (SDCL,CTR)=0
SET (SDCUTOFF,Y)=3031022
DO DD^%DT
SET SDCUTOFD=Y
+4 ; Pharmacy call to generate ^TMP global of eligible patients.
DO SCH^PSOTPCAN
+5 DO NOW^%DTC
SET TODAY=X
+6 SET NAME=""
+7 FOR
SET NAME=$ORDER(^TMP($JOB,"PSODFN",NAME))
if NAME=""
QUIT
Begin DoDot:1
+8 SET DFN=0
+9 FOR
SET DFN=$ORDER(^TMP($JOB,"PSODFN",NAME,DFN))
if +DFN'=DFN
QUIT
Begin DoDot:2
+10 NEW SDAPDTT,SSN,SSNP,SEL,RESCHED
+11 DO DEM^VADPT
+12 ; Social security number.
SET (SSN,SSNP)=""
SET SSN=$PIECE($GET(VADM(2)),"^")
IF SSN["P"
SET SSNP="P"
SET SSN=$EXTRACT(SSN,1,9)
+13 ; Exclude test patients.
if $EXTRACT(SSN,1,5)="00000"
QUIT
+14 SET SDAPDTT=$ORDER(^DPT(DFN,"S",SDT),-1)
+15 FOR
SET SDAPDTT=$ORDER(^DPT(DFN,"S",SDAPDTT))
if +SDAPDTT'=SDAPDTT!(SDAPDTT>(EDT+.24))
QUIT
Begin DoDot:3
+16 NEW SDAP0,SDCL0,SDCP,SDST,SDNAPDT,DAYS
+17 SET SDAP0=^DPT(DFN,"S",SDAPDTT,0)
SET SDCL=+SDAP0
+18 ; Get clinic 0 node.
SET SDCL0=$GET(^SC(SDCL,0))
if '$LENGTH(SDCL0)
QUIT
+19 ; Get DSS credit pair.
SET SDCP=$$CPAIR(SDCL0)
+20 ; Not a primary care appointment.
if '$DATA(SDSS(SDCP))
QUIT
+21 SET SDST=$PIECE(SDAP0,U,2)
SET SDCDTT=$PIECE(SDAP0,U,14)
+22 SET INST=$$DIV(SDCL0)
+23 IF 'INST
SET INST(0)="*NO INSTITUTION"
+24 IF '$TEST
SET INST(INST)=$$GET1^DIQ(4,INST_",",.01)
+25 SET RESCHED=$$RESCHED(DFN,SDAPDTT,SDCL,SDST,.SDNAPDT)
+26 IF 'RESCHED
SET SEL(INST,SDAPDTT)=SDCL
QUIT
+27 if '$DATA(RESCHED(INST))
SET RESCHED(INST)=2
+28 SET X1=SDNAPDT
SET X2=SDAPDTT
DO ^%DTC
SET DAYS=X
+29 SET Y=SDAPDTT\1
DO DD^%DT
SET SDAPDTT0=Y
+30 IF SDNAPDT'=""
SET Y=SDNAPDT\1
DO DD^%DT
SET SDNAPDT=Y
+31 SET ^TMP($JOB,"SDOUT",INST(INST),"PT",NAME,DFN,SDAPDTT)=$EXTRACT(SSN,1,3)_"-"_$EXTRACT(SSN,4,5)_"-"_$EXTRACT(SSN,6,10)_U_$$GET1^DIQ(44,SDCL_",",.01)_U_SDAPDTT0_U_$SELECT($EXTRACT(SDST)="N":"No-Show",1:"Canc by Patient")_
U_SDNAPDT_U_DAYS
+32 if SDAPDTT<SDCUTOFF!(RESCHED=2)
QUIT
+33 SET RESCHED(INST)=1
+34 SET ^TMP($JOB,"SDOUT",INST(INST),"CAN")=$GET(^TMP($JOB,"SDOUT",INST(INST),"CAN"))+1
+35 SET ^TMP($JOB,"SDOUT",INST(INST),"RSA")=$GET(^TMP($JOB,"SDOUT",INST(INST),"RSA"))+1
+36 SET ^TMP($JOB,"SDOUT",INST(INST),"DAYS")=$GET(^TMP($JOB,"SDOUT",INST(INST),"DAYS"))+DAYS
+37 QUIT
End DoDot:3
+38 ; For episodes that were not no-show or cancelled by patient, show the first
+39 ; future appointment or if there is not a future appointment the nearest
+40 ; previous appointment.
+41 SET INST=""
+42 SET SSN=SSN_SSNP
+43 FOR
SET INST=$ORDER(SEL(INST))
if INST=""
QUIT
if '$DATA(^TMP($JOB,"SDOUT",INST(INST),"PT",NAME,DFN))
Begin DoDot:3
+44 SET SDAPDTT=""
Begin DoDot:4
+45 SET SDAPDTT1=$ORDER(SEL(INST,TODAY))
+46 SET SDAPDTT0=$ORDER(SEL(INST,TODAY),-1)
+47 IF SDAPDTT0=""
SET SDAPDTT=SDAPDTT1
QUIT
+48 IF SDAPDTT1=""
SET SDAPDTT=SDAPDTT0
QUIT
+49 SET X1=SDAPDTT0
SET X2=TODAY
DO ^%DTC
SET X0=X
+50 SET X1=TODAY
SET X2=SDAPDTT1
DO ^%DTC
+51 SET SDAPDTT=$SELECT(X0<X:SDAPDTT0,1:SDAPDTT1)
+52 QUIT
End DoDot:4
+53 IF SDAPDTT'=""
Begin DoDot:4
+54 SET Y=SDAPDTT\1
DO DD^%DT
SET SDNEAPT=Y
+55 SET ^TMP($JOB,"SDOUT",INST(INST),"PT",NAME,DFN,SDAPDTT)=$EXTRACT(SSN,1,3)_"-"_$EXTRACT(SSN,4,5)_"-"_$EXTRACT(SSN,6,10)_U_$$GET1^DIQ(44,SEL(INST,SDAPDTT)_",",.01)_U_U_U_SDNEAPT
+56 QUIT
End DoDot:4
+57 QUIT
End DoDot:3
+58 SET INST=""
+59 FOR
SET INST=$ORDER(RESCHED(INST))
if INST=""
QUIT
IF RESCHED(INST)=1
SET ^TMP($JOB,"SDOUT",INST(INST),"RSP")=$GET(^TMP($JOB,"SDOUT",INST(INST),"RSP"))+1
+60 QUIT
End DoDot:2
+61 QUIT
End DoDot:1
+62 ;
+63 SET PAGE=0
SET (TDAYS,TRSA)=0
+64 IF 'SDSUMM
Begin DoDot:1
+65 DO HEAD10
+66 IF '$DATA(^TMP($JOB,"SDOUT"))
WRITE !!!?47,"********** NO DATA TO PRINT **********"
QUIT
+67 DO HEAD20
+68 SET INSTX=""
+69 FOR
SET INSTX=$ORDER(^TMP($JOB,"SDOUT",INSTX))
if INSTX=""
QUIT
Begin DoDot:2
+70 IF LINE+5>IOSL
DO HEAD10
if CTR
QUIT
DO HEAD20
+71 WRITE !!,"Institution : ",INSTX,!
SET LINE=LINE+3
+72 SET NAME=""
+73 FOR
SET NAME=$ORDER(^TMP($JOB,"SDOUT",INSTX,"PT",NAME))
if NAME=""
QUIT
Begin DoDot:3
+74 SET DFN=0
+75 FOR
SET DFN=$ORDER(^TMP($JOB,"SDOUT",INSTX,"PT",NAME,DFN))
if +DFN'=DFN
QUIT
Begin DoDot:4
+76 SET SDAPDT=0
+77 FOR
SET SDAPDT=$ORDER(^TMP($JOB,"SDOUT",INSTX,"PT",NAME,DFN,SDAPDT))
if +SDAPDT'=SDAPDT
QUIT
Begin DoDot:5
+78 NEW REC
+79 SET REC=^TMP($JOB,"SDOUT",INSTX,"PT",NAME,DFN,SDAPDT)
+80 IF LINE+($PIECE(REC,U,6)'="")+2>IOSL
DO HEAD10
if CTR
QUIT
DO HEAD20
+81 WRITE !,$EXTRACT(NAME,1,33),?38,$PIECE(REC,U),?52,$EXTRACT($PIECE(REC,U,2),1,33),?89,$PIECE(REC,U,3),?103,$PIECE(REC,U,4),?120,$PIECE(REC,U,5)
+82 SET LINE=LINE+1
+83 IF $PIECE(REC,U,6)'=""
WRITE !?8,"Deferred Number of Days: ",$PIECE(REC,U,6)
SET LINE=LINE+1
+84 QUIT
End DoDot:5
+85 QUIT
End DoDot:4
+86 QUIT
End DoDot:3
if CTR
QUIT
+87 IF LINE+5>IOSL
DO HEAD10
+88 DO HEAD21
DO SUMMARY
+89 QUIT
End DoDot:2
if CTR
QUIT
+90 QUIT
End DoDot:1
+91 IF SDSUMM
Begin DoDot:1
+92 NEW INSTX,X,CAN
+93 DO HEAD10
DO HEAD21
+94 SET (INSTX,X)=""
+95 FOR
SET INSTX=$ORDER(^TMP($JOB,"SDOUT",INSTX))
if INSTX=""
QUIT
SET CAN=+$GET(^TMP($JOB,"SDOUT",INSTX,"CAN"))
DO SUMMARY
if CTR
QUIT
+96 IF X=""
WRITE !!!?21,"********** NO DATA TO PRINT **********"
+97 IF '$TEST
WRITE !!,"Overall average time between appointments : ",$SELECT(TRSA=0:$JUSTIFY(TDAYS,2),1:$JUSTIFY(TDAYS/TRSA,2))
+98 QUIT
End DoDot:1
+99 ;
+100 KILL ^TMP($JOB,"PSODFN"),^TMP($JOB,"SDOUT")
+101 if CTR
QUIT
+102 IF $EXTRACT(IOST)="C"
SET DIR(0)="E"
DO ^DIR
+103 QUIT
+104 ;
SUMMARY ;
+1 ; In - INSTX, IOSL
+2 ; Out - TRSA, TDAYS
+3 ;
+4 NEW RSA,DAYS
+5 SET X=INSTX
+6 SET RSA=+$GET(^TMP($JOB,"SDOUT",INSTX,"RSA"))
SET TRSA=TRSA+RSA
+7 SET DAYS=+$GET(^TMP($JOB,"SDOUT",INSTX,"DAYS"))
SET TDAYS=TDAYS+DAYS
+8 IF LINE+2>IOSL
DO HEAD10
if CTR
QUIT
DO HEAD21
+9 WRITE !
+10 if SDSUMM
WRITE X,?9,INST
+11 WRITE ?41,+$GET(^TMP($JOB,"SDOUT",INSTX,"CAN"))
+12 WRITE ?52,RSA
+13 WRITE ?62,+$GET(^TMP($JOB,"SDOUT",INSTX,"RSP"))
+14 WRITE ?71,$SELECT(RSA=0:"0.00",1:$JUSTIFY(DAYS/RSA,"",2))
+15 SET LINE=LINE+1
+16 QUIT
+17 ;
BUILD(NAME,SSN,SDCL,SDST,SDCAPDTT,SDNEAPT) ;
+1 NEW DAYS,INST
+2 SET DAYS=""
+3 IF SDCAPDTT'=""
Begin DoDot:1
+4 SET X1=SDNEAPT
SET X2=SDAPDTT
DO ^%DTC
SET DAYS=X
+5 SET Y=SDCAPDTT\1
DO DD^%DT
SET SDCAPDTT=Y
+6 QUIT
End DoDot:1
+7 IF SDNEAPT'=""
SET Y=SDNEAPT\1
DO DD^%DT
SET SDNEAPT=Y
+8 ; Get institution for 3rd node.
+9 ; The patient names are already in alphabetical order so a numeric index is sufficient.
+10 SET UNQ=$ORDER(^TMP($JOB,"SDOUT",INST,"PT",NAME,":"),-1)+1
+11 SET ^TMP($JOB,"SDOUT",INST,"PT",NAME,UNQ)=$EXTRACT(SSN,1,3)_"-"_$EXTRACT(SSN,4,5)_"-"_$EXTRACT(SSN,6,10)_U_$$GET1^DIQ(44,SDCL_",",.01)_U_SDCAPDTT_U_$SELECT(SDST="N":"No-Show",SDST="P":"Canc by Patient",1:"")_U_SDNEAPT_U_DAYS
+12 QUIT
+13 ;
RESCHED(DFN,SDAPDTT,SDCL,SDST,SDNAPDT) ; Search for a subsequent appointment at the same clinic.
+1 ; 0 - no rescheduled appointment
+2 ; 1 - cancelled by patient and rescheduled
+3 ; 2 - no-show and rescheduled
+4 NEW SDOK
+5 IF SDST="NA"!(SDST="PCA")
SET SDNAPDT=$PIECE(^DPT(DFN,"S",SDAPDTT,0),U,10)
if SDNAPDT>SDAPDTT
QUIT SDST="NA"+1
+6 if SDST'="N"&(SDST'="PC")
QUIT 0
+7 SET SDOK=0
SET SDNAPDT=""
+8 FOR
SET SDAPDTT=$ORDER(^DPT(DFN,"S",SDAPDTT))
if +SDAPDTT'=SDAPDTT
QUIT
SET SDOK=$PIECE(^DPT(DFN,"S",SDAPDTT,0),U)=SDCL
IF SDOK
SET SDNAPDT=SDAPDTT
QUIT
+9 QUIT (SDST="NA"+1)*SDOK
+10 ;
HEAD10 ;
+1 SET PAGE=PAGE+1
+2 IF PAGE>1
IF $EXTRACT(IOST)="C"
SET DIR(0)="E"
DO ^DIR
IF $DATA(DIRUT)
SET CTR=1
QUIT
+3 SET SDTTL="Transitional Pharmacy Benefit Deferred Appointment Report"
+4 IF SDSUMM
SET SDTTL=SDTTL_" (Summary)"
+5 WRITE @IOF,!?IOM-$LENGTH(SDTTL)\2,SDTTL
+6 IF 'SDSUMM
WRITE ?122,"Page : "_PAGE
+7 SET Y=SDT
DO DD^%DT
+8 SET SDTTL="Report for the period of "_Y_" and "
+9 SET Y=EDT
DO DD^%DT
+10 SET SDTTL=SDTTL_Y
+11 WRITE !?IOM-$LENGTH(SDTTL)\2,SDTTL
+12 WRITE !
+13 SET LINE=4
+14 QUIT
+15 ;
HEAD20 ;
+1 WRITE !?89,"Cancelled",?103,"Reason for",?120,"New/Closest"
+2 WRITE !,"Patient",?38,"SSN",?52,"Clinic",?89,"Appt. Date",?103,"Cancellation",?120,"Appt. Date"
+3 WRITE !,"=======",?38,"===",?52,"======",?89,"==========",?103,"============",?120,"==========="
+4 SET LINE=LINE+3
+5 QUIT
+6 ;
HEAD21 ;
+1 WRITE !!
+2 if 'SDSUMM
WRITE "Count for appts. after "_SDCUTOFD
+3 WRITE ?41,"Appts",?52,"Appts",?62,"Patients",?71,"Ave time"
+4 WRITE !
+5 if SDSUMM
WRITE "Institution"
+6 WRITE ?41,"Cancelled",?52,"Deferred",?62,"Deferred",?71,"/appts"
+7 WRITE !
+8 if SDSUMM
WRITE "==========="
+9 WRITE ?41,"=========",?52,"========",?62,"========",?71,"========"
+10 SET LINE=LINE+4
+11 QUIT
+12 ;
INIT(SDSS) ;
+1 NEW SDI,SDII
+2 FOR SDI=322,323,350
FOR SDII="000",185,186,187
SET SDSS(SDI_SDII)=""
+3 KILL ^TMP($JOB,"SDOUT")
+4 QUIT
+5 ;
CPAIR(SDCL0) ; Get credit pair
+1 ; Input: SDCL0=hospital location zeroeth node
+2 NEW SDX
+3 SET SDX=$PIECE($GET(^DIC(40.7,+$PIECE(SDCL0,U,7),0)),U,2)
+4 SET SDX=SDX_$PIECE($GET(^DIC(40.7,+$PIECE(SDCL0,U,18),0)),U,2)
+5 SET SDX=$EXTRACT(SDX_"000000",1,6)
+6 QUIT SDX
+7 ;
DIV(SDCL0) ;Get facility division name and number
+1 ;Input: SDCL0=hospital location zeroeth node
+2 NEW SDIVV,SDHOLD
SET SDIVV=$PIECE(SDCL0,U,15)
+3 SET SDHOLD=0
+4 IF SDIVV>0
SET SDHOLD=$PIECE($$SITE^VASITE(,SDIVV),"^")
+5 IF SDHOLD>0
QUIT SDHOLD
+6 SET SDHOLD=$PIECE(SDCL0,"^",4)
+7 IF 'SDHOLD
QUIT 0
+8 IF SDHOLD
IF '$DATA(^DIC(4,SDHOLD,0))
SET SDHOLD=0
+9 QUIT SDHOLD
+10 ;
DEV ;
+1 KILL %ZIS,IOP,POP,ZTSK
SET SDDIO=ION
SET %ZIS="QM"
DO ^%ZIS
KILL %ZIS
+2 SET IOM=$SELECT(SDSUMM:80,1:132)
+3 IF POP
SET IOP=SDDIO
DO ^%ZIS
KILL IOP,SDDIO
WRITE !,"Please try later!"
GOTO END
+4 KILL SDDIO
IF $DATA(IO("Q"))
KILL IO("Q"),ZTIO,ZTSAVE,ZTDTH,ZTSK
Begin DoDot:1
+5 SET ZTRTN="EN^SDPBP"
SET ZTDTH=$HOROLOG
SET ZTDESC="TRANSITIONAL PHARMACY BENEFITS ELIGIBILITY PRINT"
+6 SET ZTSAVE("SDT")=""
+7 SET ZTSAVE("EDT")=""
+8 SET ZTSAVE("SDSUMM")=""
+9 DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !,"Report is Queued to print !!"
KILL ZTSK
+10 QUIT
End DoDot:1
GOTO END
+11 DO EN
END ;
+1 WRITE !
DO ^%ZISC
if $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 KILL ^TMP($JOB)
+3 QUIT
