Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: SDPBP

SDPBP.m

Go to the documentation of this file. 
  1. SDPBP ; BP-IOFO/OWAIN ; Pharmacy Benefits Print. ;  ; Compiled November 13, 2003 09:55:19
  1.  ;;5.3;Scheduling;**318**; SEP 29, 2003
  1.  ;
  1. EN0 ; Inquire date range.
  1.  K %DT
  1.  S %DT="AEX",%DT("A")="Appointment start date for report: "
  1.  D ^%DT Q:Y=-1
  1.  K %DT
  1.  S (SDT,%DT(0))=Y K Y
  1.  S %DT="AEX",%DT("A")="Appointment end date for report: "
  1.  D ^%DT Q:Y=-1
  1.  S EDT=Y
  1.  S DIR("?",1)="Enter YES to show only summary totals.",DIR("?")="Enter NO to list patient level details as well."
  1.  S DIR("A")="Summary?",DIR(0)="Y",DIR("B")="YES" D ^DIR
  1.  K DIR
  1.  Q:Y="^"
  1.  S SDSUMM=Y
  1.  D DEV
  1.  Q
  1.  ;
  1. EN ;
  1.  N SDCL,SDSS,NAME,DFN,INST,LINE,MAXLEN,PAGE,TODAY,CTR,SDCUTOFF,SDCUTOFD,TDAYS,TRSA
  1.  D INIT(.SDSS)
  1.  S (SDCL,CTR)=0,(SDCUTOFF,Y)=3031022 D DD^%DT S SDCUTOFD=Y
  1.  D SCH^PSOTPCAN  ; Pharmacy call to generate ^TMP global of eligible patients.
  1.  D NOW^%DTC S TODAY=X
  1.  S NAME=""
  1.  F  S NAME=$O(^TMP($J,"PSODFN",NAME)) Q:NAME=""  D
  1.  .S DFN=0
  1.  .F  S DFN=$O(^TMP($J,"PSODFN",NAME,DFN)) Q:+DFN'=DFN  D
  1.  ..N SDAPDTT,SSN,SSNP,SEL,RESCHED
  1.  ..D DEM^VADPT
  1.  ..S (SSN,SSNP)="" S SSN=$P($G(VADM(2)),"^") I SSN["P" S SSNP="P",SSN=$E(SSN,1,9)  ; Social security number.
  1.  ..Q:$E(SSN,1,5)="00000"  ; Exclude test patients.
  1.  ..S SDAPDTT=$O(^DPT(DFN,"S",SDT),-1)
  1.  ..F  S SDAPDTT=$O(^DPT(DFN,"S",SDAPDTT)) Q:+SDAPDTT'=SDAPDTT!(SDAPDTT>(EDT+.24))  D
  1.  ...N SDAP0,SDCL0,SDCP,SDST,SDNAPDT,DAYS
  1.  ...S SDAP0=^DPT(DFN,"S",SDAPDTT,0),SDCL=+SDAP0
  1.  ...S SDCL0=$G(^SC(SDCL,0)) Q:'$L(SDCL0)  ; Get clinic 0 node.
  1.  ...S SDCP=$$CPAIR(SDCL0)  ; Get DSS credit pair.
  1.  ...Q:'$D(SDSS(SDCP))  ; Not a primary care appointment.
  1.  ...S SDST=$P(SDAP0,U,2),SDCDTT=$P(SDAP0,U,14)
  1.  ...S INST=$$DIV(SDCL0) 
  1.  ...I 'INST S INST(0)="*NO INSTITUTION"
  1.  ...E  S INST(INST)=$$GET1^DIQ(4,INST_",",.01)
  1.  ...S RESCHED=$$RESCHED(DFN,SDAPDTT,SDCL,SDST,.SDNAPDT)
  1.  ...I 'RESCHED S SEL(INST,SDAPDTT)=SDCL Q
  1.  ...S:'$D(RESCHED(INST)) RESCHED(INST)=2
  1.  ...S X1=SDNAPDT,X2=SDAPDTT D ^%DTC S DAYS=X
  1.  ...S Y=SDAPDTT\1 D DD^%DT S SDAPDTT0=Y
  1.  ...I SDNAPDT'="" S Y=SDNAPDT\1 D DD^%DT S SDNAPDT=Y
  1.  ...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
  1.  ...Q:SDAPDTT<SDCUTOFF!(RESCHED=2)
  1.  ...S RESCHED(INST)=1
  1.  ...S ^TMP($J,"SDOUT",INST(INST),"CAN")=$G(^TMP($J,"SDOUT",INST(INST),"CAN"))+1
  1.  ...S ^TMP($J,"SDOUT",INST(INST),"RSA")=$G(^TMP($J,"SDOUT",INST(INST),"RSA"))+1
  1.  ...S ^TMP($J,"SDOUT",INST(INST),"DAYS")=$G(^TMP($J,"SDOUT",INST(INST),"DAYS"))+DAYS
  1.  ...Q
  1.  ..; For episodes that were not no-show or cancelled by patient, show the first 
  1.  ..; future appointment or if there is not a future appointment the nearest 
  1.  ..; previous appointment.
  1.  ..S INST=""
  1.  ..S SSN=SSN_SSNP
  1.  ..F  S INST=$O(SEL(INST)) Q:INST=""  D:'$D(^TMP($J,"SDOUT",INST(INST),"PT",NAME,DFN))
  1.  ...S SDAPDTT="" D
  1.  ....S SDAPDTT1=$O(SEL(INST,TODAY))
  1.  ....S SDAPDTT0=$O(SEL(INST,TODAY),-1)
  1.  ....I SDAPDTT0="" S SDAPDTT=SDAPDTT1 Q
  1.  ....I SDAPDTT1="" S SDAPDTT=SDAPDTT0 Q
  1.  ....S X1=SDAPDTT0,X2=TODAY D ^%DTC S X0=X
  1.  ....S X1=TODAY,X2=SDAPDTT1 D ^%DTC
  1.  ....S SDAPDTT=$S(X0<X:SDAPDTT0,1:SDAPDTT1)
  1.  ....Q
  1.  ...I SDAPDTT'="" D
  1.  ....S Y=SDAPDTT\1 D DD^%DT S SDNEAPT=Y
  1.  ....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
  1.  ....Q
  1.  ...Q
  1.  ..S INST=""
  1.  ..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
  1.  ..Q
  1.  .Q
  1.  ;
  1.  S PAGE=0,(TDAYS,TRSA)=0
  1.  I 'SDSUMM D
  1.  .D HEAD10
  1.  .I '$D(^TMP($J,"SDOUT")) W !!!?47,"********** NO DATA TO PRINT **********" Q
  1.  .D HEAD20
  1.  .S INSTX=""
  1.  .F  S INSTX=$O(^TMP($J,"SDOUT",INSTX)) Q:INSTX=""  D  Q:CTR
  1.  ..I LINE+5>IOSL D HEAD10 Q:CTR  D HEAD20
  1.  ..W !!,"Institution : ",INSTX,! S LINE=LINE+3
  1.  ..S NAME=""
  1.  ..F  S NAME=$O(^TMP($J,"SDOUT",INSTX,"PT",NAME)) Q:NAME=""  D  Q:CTR
  1.  ...S DFN=0
  1.  ...F  S DFN=$O(^TMP($J,"SDOUT",INSTX,"PT",NAME,DFN)) Q:+DFN'=DFN  D
  1.  ....S SDAPDT=0
  1.  ....F  S SDAPDT=$O(^TMP($J,"SDOUT",INSTX,"PT",NAME,DFN,SDAPDT)) Q:+SDAPDT'=SDAPDT  D
  1.  .....N REC
  1.  .....S REC=^TMP($J,"SDOUT",INSTX,"PT",NAME,DFN,SDAPDT)
  1.  .....I LINE+($P(REC,U,6)'="")+2>IOSL D HEAD10 Q:CTR  D HEAD20
  1.  .....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)
  1.  .....S LINE=LINE+1
  1.  .....I $P(REC,U,6)'="" W !?8,"Deferred Number of Days: ",$P(REC,U,6) S LINE=LINE+1
  1.  .....Q
  1.  ....Q
  1.  ...Q
  1.  ..I LINE+5>IOSL D HEAD10
  1.  ..D HEAD21,SUMMARY
  1.  ..Q
  1.  .Q
  1.  I SDSUMM D
  1.  .N INSTX,X,CAN
  1.  .D HEAD10,HEAD21
  1.  .S (INSTX,X)=""
  1.  .F  S INSTX=$O(^TMP($J,"SDOUT",INSTX)) Q:INSTX=""  S CAN=+$G(^TMP($J,"SDOUT",INSTX,"CAN")) D SUMMARY Q:CTR
  1.  .I X="" W !!!?21,"********** NO DATA TO PRINT **********"
  1.  .E  W !!,"Overall average time between appointments : ",$S(TRSA=0:$J(TDAYS,2),1:$J(TDAYS/TRSA,2))
  1.  .Q
  1.  ;
  1.  K ^TMP($J,"PSODFN"),^TMP($J,"SDOUT")
  1.  Q:CTR
  1.  I $E(IOST)="C" S DIR(0)="E" D ^DIR
  1.  Q
  1.  ;
  1. SUMMARY ;
  1.  ; In - INSTX, IOSL
  1.  ; Out - TRSA, TDAYS
  1.  ;
  1.  N RSA,DAYS
  1.  S X=INSTX
  1.  S RSA=+$G(^TMP($J,"SDOUT",INSTX,"RSA")),TRSA=TRSA+RSA
  1.  S DAYS=+$G(^TMP($J,"SDOUT",INSTX,"DAYS")),TDAYS=TDAYS+DAYS
  1.  I LINE+2>IOSL D HEAD10 Q:CTR  D HEAD21
  1.  W !
  1.  W:SDSUMM X,?9,INST
  1.  W ?41,+$G(^TMP($J,"SDOUT",INSTX,"CAN"))
  1.  W ?52,RSA
  1.  W ?62,+$G(^TMP($J,"SDOUT",INSTX,"RSP"))
  1.  W ?71,$S(RSA=0:"0.00",1:$J(DAYS/RSA,"",2))
  1.  S LINE=LINE+1
  1.  Q
  1.  ;
  1. BUILD(NAME,SSN,SDCL,SDST,SDCAPDTT,SDNEAPT) ;
  1.  N DAYS,INST
  1.  S DAYS=""
  1.  I SDCAPDTT'="" D
  1.  .S X1=SDNEAPT,X2=SDAPDTT D ^%DTC S DAYS=X
  1.  .S Y=SDCAPDTT\1 D DD^%DT S SDCAPDTT=Y
  1.  .Q
  1.  I SDNEAPT'="" S Y=SDNEAPT\1 D DD^%DT S SDNEAPT=Y
  1.  ; Get institution for 3rd node. 
  1.  ; The patient names are already in alphabetical order so a numeric index is sufficient.
  1.  S UNQ=$O(^TMP($J,"SDOUT",INST,"PT",NAME,":"),-1)+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
  1.  Q
  1.  ;
  1. RESCHED(DFN,SDAPDTT,SDCL,SDST,SDNAPDT) ; Search for a subsequent appointment at the same clinic.
  1.  ; 0 - no rescheduled appointment
  1.  ; 1 - cancelled by patient and rescheduled
  1.  ; 2 - no-show and rescheduled
  1.  N SDOK
  1.  I SDST="NA"!(SDST="PCA") S SDNAPDT=$P(^DPT(DFN,"S",SDAPDTT,0),U,10) Q:SDNAPDT>SDAPDTT SDST="NA"+1
  1.  Q:SDST'="N"&(SDST'="PC") 0
  1.  S SDOK=0,SDNAPDT=""
  1.  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
  1.  Q (SDST="NA"+1)*SDOK
  1.  ;
  1. HEAD10 ;
  1.  S PAGE=PAGE+1
  1.  I PAGE>1,$E(IOST)="C" S DIR(0)="E" D ^DIR I $D(DIRUT) S CTR=1 Q
  1.  S SDTTL="Transitional Pharmacy Benefit Deferred Appointment Report"
  1.  I SDSUMM S SDTTL=SDTTL_" (Summary)"
  1.  W @IOF,!?IOM-$L(SDTTL)\2,SDTTL
  1.  I 'SDSUMM W ?122,"Page : "_PAGE
  1.  S Y=SDT D DD^%DT
  1.  S SDTTL="Report for the period of "_Y_" and "
  1.  S Y=EDT D DD^%DT
  1.  S SDTTL=SDTTL_Y
  1.  W !?IOM-$L(SDTTL)\2,SDTTL
  1.  W !
  1.  S LINE=4
  1.  Q
  1.  ;
  1. HEAD20 ;
  1.  W !?89,"Cancelled",?103,"Reason for",?120,"New/Closest"
  1.  W !,"Patient",?38,"SSN",?52,"Clinic",?89,"Appt. Date",?103,"Cancellation",?120,"Appt. Date"
  1.  W !,"=======",?38,"===",?52,"======",?89,"==========",?103,"============",?120,"==========="
  1.  S LINE=LINE+3
  1.  Q
  1.  ;
  1. HEAD21 ;
  1.  W !!
  1.  W:'SDSUMM "Count for appts. after "_SDCUTOFD
  1.  W ?41,"Appts",?52,"Appts",?62,"Patients",?71,"Ave time"
  1.  W !
  1.  W:SDSUMM "Institution"
  1.  W ?41,"Cancelled",?52,"Deferred",?62,"Deferred",?71,"/appts"
  1.  W !
  1.  W:SDSUMM "==========="
  1.  W ?41,"=========",?52,"========",?62,"========",?71,"========"
  1.  S LINE=LINE+4
  1.  Q
  1.  ;
  1. INIT(SDSS) ;
  1.  N SDI,SDII
  1.  F SDI=322,323,350 F SDII="000",185,186,187 S SDSS(SDI_SDII)=""
  1.  K ^TMP($J,"SDOUT")
  1.  Q
  1.  ;
  1. CPAIR(SDCL0)   ; Get credit pair
  1.  ; Input: SDCL0=hospital location zeroeth node
  1.  N SDX
  1.  S SDX=$P($G(^DIC(40.7,+$P(SDCL0,U,7),0)),U,2)
  1.  S SDX=SDX_$P($G(^DIC(40.7,+$P(SDCL0,U,18),0)),U,2)
  1.  S SDX=$E(SDX_"000000",1,6)
  1.  Q SDX
  1.  ;
  1. DIV(SDCL0) ;Get facility division name and number
  1.  ;Input: SDCL0=hospital location zeroeth node
  1.  N SDIVV,SDHOLD S SDIVV=$P(SDCL0,U,15)
  1.  S SDHOLD=0
  1.  I SDIVV>0 S SDHOLD=$P($$SITE^VASITE(,SDIVV),"^")
  1.  I SDHOLD>0 Q SDHOLD
  1.  S SDHOLD=$P(SDCL0,"^",4)
  1.  I 'SDHOLD Q 0
  1.  I SDHOLD,'$D(^DIC(4,SDHOLD,0)) S SDHOLD=0
  1.  Q SDHOLD
  1.  ;
  1. DEV ;
  1.  K %ZIS,IOP,POP,ZTSK S SDDIO=ION,%ZIS="QM" D ^%ZIS K %ZIS
  1.  S IOM=$S(SDSUMM:80,1:132)
  1.  I POP S IOP=SDDIO D ^%ZIS K IOP,SDDIO W !,"Please try later!" G END
  1.  K SDDIO I $D(IO("Q")) K IO("Q"),ZTIO,ZTSAVE,ZTDTH,ZTSK D  G END
  1.  .S ZTRTN="EN^SDPBP",ZTDTH=$H,ZTDESC="TRANSITIONAL PHARMACY BENEFITS ELIGIBILITY PRINT"
  1.  .S ZTSAVE("SDT")=""
  1.  .S ZTSAVE("EDT")=""
  1.  .S ZTSAVE("SDSUMM")=""
  1.  .D ^%ZTLOAD W:$D(ZTSK) !,"Report is Queued to print !!" K ZTSK
  1.  .Q
  1.  D EN
  1. END ;
  1.  W ! D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
  1.  K ^TMP($J)
  1.  Q