EASMTRP1 ;ALB/GAH - MEANS TEST DAILY EXPIRATION REPORT ; 10/10/2006
;;1.0;ENROLLMENT APPLICATION SYSTEM;**3,13,46,77**;MAR 15,2001;Build 11
;
EN ; Interactive report generation, select date range
N EDATE,ERROR,MTREC,PIEN,VARR,RCNT,ACNT,DGARRAY,SDCNT,I
;
D HOME^%ZIS
W @IOF
;
; Get beginning date of date range, default to TODAY
W !,$CHAR(7),"Enter date range for anniversary date search"
S DIR(0)="D^::EX",DIR("?")="^D HELP^%DTC",DIR("B")=$$FMTE^XLFDT(DT)
S DIR("A")=" Start Date"
D ^DIR K DIR
Q:$D(DIRUT)
S EASBEG=Y
;
; Get ending date of date range, default to TODAY
S DIR(0)="D^::EX",DIR("?")="^D HELP^%DTC",DIR("B")=$$FMTE^XLFDT(DT)
S DIR("A")=" End Date"
D ^DIR K DIR
Q:$D(DIRUT)
S EASEND=Y
;
S EAX=$$GET1^DIQ(713,1,5)
S:EAX]"" %ZIS("B")=EAX
S ZTSAVE("EASBEG")="",ZTSAVE("EASEND")=""
D EN^XUTMDEVQ("BLD^EASMTRP1","EAS MT EXPIRATION RPT",.ZTSAVE,.%ZIS)
Q
;
QUE ; Queued report generation
N ZTSAVE,ZTRTN,ZTDESC,EAX,%ZIS
;
S (EASBEG,EASEND)=$$FMADD^XLFDT($$DT^XLFDT,-1)
S ZTSAVE("EASBEG")="",ZTSAVE("EASEND")=""
S IOP=""
D EN^XUTMDEVQ("BLD^EASMTRP1","EAS MT EXPIRATION RPT",.ZTSAVE)
Q
;
BLD ; Build the list of MT expirations to TMP global
N EASIEN,EASANV,EASLST,EASENDT,DFN,EASTMP,EASDT,EASENDT
;
K ^TMP("EASEXP",$J)
;
S EASENDT=$$FMADD^XLFDT(EASEND,-365)
S EASANV=$$FMADD^XLFDT(EASBEG,-365,"",-1) ; Subtract 1 minute to capture the 1st day
F S EASANV=$O(^DGMT(408.31,"B",EASANV)) Q:'EASANV!(EASANV>EASENDT) D
. S EASIEN=0
. F S EASIEN=$O(^DGMT(408.31,"B",EASANV,EASIEN)) Q:'EASIEN D
. . S DFN=$$GET1^DIQ(408.31,EASIEN,.02,"I") Q:+DFN=0
. . S EASLST=$$LST^DGMTU(DFN)
. . Q:+EASLST'=EASIEN ; Quit it this MT is not the last MT on file
. . Q:$$DECEASED^EASMTUTL("",DFN) ; Quit if patient is deceased
. . Q:"N,P"[$P(EASLST,U,4) ; Quit if MT No longer Required or Pending Adjudication
. . ; Quit if Cat C, agrees to deductible and MT later the 10-5-99
. . I $P(EASLST,U,4)="C",$$GET1^DIQ(408.31,+EASLST,.11,"I"),$P(EASLST,U,2)>2991005 Q
. . ;;Q:$$FUTMT^EASMTUTL("","",DFN) ; Quit if future MT on file
. . S ^TMP("EASEXP",$J,EASANV,EASIEN)=DFN_U_EASLST
;
S EASTMP="^TMP(""EASEXP"","_$J_")"
S EASDT("BEG")=EASBEG,EASDT("END")=EASEND
D BLDSD ; Call Scheduling API
D PRT(EASTMP,.EASDT) ; Call print report
K DGARRAY,SDCNT,VARR,I,^TMP($J,"SDAMA")
Q
;
BLDSD ;
N EDATE,ERROR,MTREC,PIEN,VARR,RCNT,ACNT,DGARRAY,SDCNT,I
S ACNT=1,RCNT=0
S EDATE=0 F S EDATE=$O(^TMP("EASEXP",$J,EDATE)) Q:'EDATE D
.S MTREC=0 F S MTREC=$O(^TMP("EASEXP",$J,EDATE,MTREC)) Q:'MTREC D
..S PIEN=+^TMP("EASEXP",$J,EDATE,MTREC)
..Q:'$D(^DPT(PIEN,0))
..S RCNT=RCNT+1,VARR(ACNT)=$G(VARR(ACNT))_PIEN_";"
..; Group DFNs by no more than twenty records
..I RCNT>19 S ACNT=ACNT+1,RCNT=0
;
; Call SD API by array of Patient DFNs
S ERROR=""
K DGARRAY
S DGARRAY(1)=DT,DGARRAY("SORT")="P",DGARRAY("FLDS")="1;2"
F I=1:1 Q:'$D(VARR(I))!(ERROR'="") D
.S DGARRAY(4)=VARR(I)
.S SDCNT=$$SDAPI^SDAMA301(.DGARRAY)
. I SDCNT>0 M ^TMP($J,"SDAMA")=^TMP($J,"SDAMA301")
. I SDCNT<0 D
. . S ERROR=$O(^TMP($J,"SDAMA301",""))
. . S ^TMP($J,"SDAMA","ERROR")=^TMP($J,"SDAMA301",ERROR)
.K ^TMP($J,"SDAMA301")
Q
;
PRT(EASTMP,EASDT) ;
N EASANV,EASIEN,PAGE,DFN,EASP,EASABRT
;
S EASANV=0,PAGE=0
D HDR(.EASDT)
;
I '$D(@EASTMP) D Q
. W !!?3,">> No Means Test expirations for the selected date range."
;
F S EASANV=$O(@EASTMP@(EASANV)) Q:'EASANV D Q:$G(EASABRT)
. S EASIEN=0
. F S EASIEN=$O(@EASTMP@(EASANV,EASIEN)) Q:'EASIEN D Q:$G(EASABRT)
. . S EASDAT=@EASTMP@(EASANV,EASIEN)
. . D PRTLINE(EASANV,EASDAT) ; Get data and format print line
. . I $E(IOST,1,2)="C-",($Y+5)>IOSL D
. . . S DIR(0)="E"
. . . D ^DIR K DIR
. . . I 'Y S EASABRT=1 Q
. . . D HDR(.EASDT)
Q
;
PRTLINE(EASANV,EASDAT) ; Format and print report line
N DFN,EASNAME,EASTAT,EASAPT,EASF,EACL
;
S DFN=$P(EASDAT,U)
S EASNAME=$$GET1^DIQ(2,DFN,.01)
W !,$E(EASNAME,1,20)
;
D PID^VADPT6
W ?22,VA("PID")
;
W ?35,$TR($$FMTE^XLFDT($$FMADD^XLFDT(EASANV,365),"2F")," ","0")
S EASTAT=$P(EASDAT,U,5)
W ?46,$S(EASTAT="C":"MT CPR",EASTAT="A":"MT CPE",EASTAT="R":"REQD",EASTAT="N":"NA",EASTAT="P":"PEND",EASTAT="G":"GMT CPR",1:"")
;
I $D(^TMP($J,"SDAMA","ERROR")) Q
D GETAPT(DFN,.EASAPT)
I $D(EASAPT) D
. S EACL=0 F S EACL=$O(EASAPT(EACL)) Q:'EACL D
. . W:$G(EASF) !
. . W ?55,$E($$GET1^DIQ(44,EACL,.01),1,15)," ",$$FMTE^XLFDT(EASAPT(EACL),"2D")
. . S EASF=1
;
D KVA^VADPT
Q
;
GETAPT(DFN,EASAPT) ; Get future appointments for patient
N EASAP,EASND,EASCL
Q:'$D(^TMP($J,"SDAMA",DFN))
S EASAP=0 F S EASAP=$O(^TMP($J,"SDAMA",DFN,EASAP)) Q:'EASAP D
.S EASND=^TMP($J,"SDAMA",DFN,EASAP)
.S EASCL=+$P(EASND,U,2),EASAPT(EASCL)=+EASND
Q
;
HDR(EASDT) ; Print report header
N ERROR,LINE,SPACE,TXT,HDR,TAB
;
I $E(IOST,1,2)="C-" W @IOF
S TXT="Means Test Expiration Report"
S SPACE=(IOM-$L(TXT))/2
S $P(HDR," ",SPACE)="",HDR=HDR_TXT
W !,HDR K HDR
;
S TXT="Anniversary Date(s): "_$$FMTE^XLFDT(EASDT("BEG"),"5D")_" - "_$$FMTE^XLFDT(EASDT("END"),"5D")
S SPACE=(IOM-$L(TXT))/2
S $P(HDR," ",SPACE)="",HDR=HDR_TXT
W !,HDR K HDR
;
W !!,"Printed: "_$$FMTE^XLFDT($$NOW^XLFDT)
S PAGE=$G(PAGE)+1
S TAB=IOM-8
W ?TAB,"Page "_PAGE
S ERROR=$G(^TMP($J,"SDAMA","ERROR"))
W:ERROR'="" !,"Appointment Error: ",ERROR
;
W !,"Patient",?25,"SSN",?35,"MT Expired",?46,"Status",?57,"Future Appts"
S $P(LINE,"=",IOM)="" W !,LINE
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HEASMTRP1 5536 printed Oct 16, 2024@17:56:18 Page 2
EASMTRP1 ;ALB/GAH - MEANS TEST DAILY EXPIRATION REPORT ; 10/10/2006
+1 ;;1.0;ENROLLMENT APPLICATION SYSTEM;**3,13,46,77**;MAR 15,2001;Build 11
+2 ;
EN ; Interactive report generation, select date range
+1 NEW EDATE,ERROR,MTREC,PIEN,VARR,RCNT,ACNT,DGARRAY,SDCNT,I
+2 ;
+3 DO HOME^%ZIS
+4 WRITE @IOF
+5 ;
+6 ; Get beginning date of date range, default to TODAY
+7 WRITE !,$CHAR(7),"Enter date range for anniversary date search"
+8 SET DIR(0)="D^::EX"
SET DIR("?")="^D HELP^%DTC"
SET DIR("B")=$$FMTE^XLFDT(DT)
+9 SET DIR("A")=" Start Date"
+10 DO ^DIR
KILL DIR
+11 if $DATA(DIRUT)
QUIT
+12 SET EASBEG=Y
+13 ;
+14 ; Get ending date of date range, default to TODAY
+15 SET DIR(0)="D^::EX"
SET DIR("?")="^D HELP^%DTC"
SET DIR("B")=$$FMTE^XLFDT(DT)
+16 SET DIR("A")=" End Date"
+17 DO ^DIR
KILL DIR
+18 if $DATA(DIRUT)
QUIT
+19 SET EASEND=Y
+20 ;
+21 SET EAX=$$GET1^DIQ(713,1,5)
+22 if EAX]""
SET %ZIS("B")=EAX
+23 SET ZTSAVE("EASBEG")=""
SET ZTSAVE("EASEND")=""
+24 DO EN^XUTMDEVQ("BLD^EASMTRP1","EAS MT EXPIRATION RPT",.ZTSAVE,.%ZIS)
+25 QUIT
+26 ;
QUE ; Queued report generation
+1 NEW ZTSAVE,ZTRTN,ZTDESC,EAX,%ZIS
+2 ;
+3 SET (EASBEG,EASEND)=$$FMADD^XLFDT($$DT^XLFDT,-1)
+4 SET ZTSAVE("EASBEG")=""
SET ZTSAVE("EASEND")=""
+5 SET IOP=""
+6 DO EN^XUTMDEVQ("BLD^EASMTRP1","EAS MT EXPIRATION RPT",.ZTSAVE)
+7 QUIT
+8 ;
BLD ; Build the list of MT expirations to TMP global
+1 NEW EASIEN,EASANV,EASLST,EASENDT,DFN,EASTMP,EASDT,EASENDT
+2 ;
+3 KILL ^TMP("EASEXP",$JOB)
+4 ;
+5 SET EASENDT=$$FMADD^XLFDT(EASEND,-365)
+6 ; Subtract 1 minute to capture the 1st day
SET EASANV=$$FMADD^XLFDT(EASBEG,-365,"",-1)
+7 FOR
SET EASANV=$ORDER(^DGMT(408.31,"B",EASANV))
if 'EASANV!(EASANV>EASENDT)
QUIT
Begin DoDot:1
+8 SET EASIEN=0
+9 FOR
SET EASIEN=$ORDER(^DGMT(408.31,"B",EASANV,EASIEN))
if 'EASIEN
QUIT
Begin DoDot:2
+10 SET DFN=$$GET1^DIQ(408.31,EASIEN,.02,"I")
if +DFN=0
QUIT
+11 SET EASLST=$$LST^DGMTU(DFN)
+12 ; Quit it this MT is not the last MT on file
if +EASLST'=EASIEN
QUIT
+13 ; Quit if patient is deceased
if $$DECEASED^EASMTUTL("",DFN)
QUIT
+14 ; Quit if MT No longer Required or Pending Adjudication
if "N,P"[$PIECE(EASLST,U,4)
QUIT
+15 ; Quit if Cat C, agrees to deductible and MT later the 10-5-99
+16 IF $PIECE(EASLST,U,4)="C"
IF $$GET1^DIQ(408.31,+EASLST,.11,"I")
IF $PIECE(EASLST,U,2)>2991005
QUIT
+17 ;;Q:$$FUTMT^EASMTUTL("","",DFN) ; Quit if future MT on file
+18 SET ^TMP("EASEXP",$JOB,EASANV,EASIEN)=DFN_U_EASLST
End DoDot:2
End DoDot:1
+19 ;
+20 SET EASTMP="^TMP(""EASEXP"","_$JOB_")"
+21 SET EASDT("BEG")=EASBEG
SET EASDT("END")=EASEND
+22 ; Call Scheduling API
DO BLDSD
+23 ; Call print report
DO PRT(EASTMP,.EASDT)
+24 KILL DGARRAY,SDCNT,VARR,I,^TMP($JOB,"SDAMA")
+25 QUIT
+26 ;
BLDSD ;
+1 NEW EDATE,ERROR,MTREC,PIEN,VARR,RCNT,ACNT,DGARRAY,SDCNT,I
+2 SET ACNT=1
SET RCNT=0
+3 SET EDATE=0
FOR
SET EDATE=$ORDER(^TMP("EASEXP",$JOB,EDATE))
if 'EDATE
QUIT
Begin DoDot:1
+4 SET MTREC=0
FOR
SET MTREC=$ORDER(^TMP("EASEXP",$JOB,EDATE,MTREC))
if 'MTREC
QUIT
Begin DoDot:2
+5 SET PIEN=+^TMP("EASEXP",$JOB,EDATE,MTREC)
+6 if '$DATA(^DPT(PIEN,0))
QUIT
+7 SET RCNT=RCNT+1
SET VARR(ACNT)=$GET(VARR(ACNT))_PIEN_";"
+8 ; Group DFNs by no more than twenty records
+9 IF RCNT>19
SET ACNT=ACNT+1
SET RCNT=0
End DoDot:2
End DoDot:1
+10 ;
+11 ; Call SD API by array of Patient DFNs
+12 SET ERROR=""
+13 KILL DGARRAY
+14 SET DGARRAY(1)=DT
SET DGARRAY("SORT")="P"
SET DGARRAY("FLDS")="1;2"
+15 FOR I=1:1
if '$DATA(VARR(I))!(ERROR'="")
QUIT
Begin DoDot:1
+16 SET DGARRAY(4)=VARR(I)
+17 SET SDCNT=$$SDAPI^SDAMA301(.DGARRAY)
+18 IF SDCNT>0
MERGE ^TMP($JOB,"SDAMA")=^TMP($JOB,"SDAMA301")
+19 IF SDCNT<0
Begin DoDot:2
+20 SET ERROR=$ORDER(^TMP($JOB,"SDAMA301",""))
+21 SET ^TMP($JOB,"SDAMA","ERROR")=^TMP($JOB,"SDAMA301",ERROR)
End DoDot:2
+22 KILL ^TMP($JOB,"SDAMA301")
End DoDot:1
+23 QUIT
+24 ;
PRT(EASTMP,EASDT) ;
+1 NEW EASANV,EASIEN,PAGE,DFN,EASP,EASABRT
+2 ;
+3 SET EASANV=0
SET PAGE=0
+4 DO HDR(.EASDT)
+5 ;
+6 IF '$DATA(@EASTMP)
Begin DoDot:1
+7 WRITE !!?3,">> No Means Test expirations for the selected date range."
End DoDot:1
QUIT
+8 ;
+9 FOR
SET EASANV=$ORDER(@EASTMP@(EASANV))
if 'EASANV
QUIT
Begin DoDot:1
+10 SET EASIEN=0
+11 FOR
SET EASIEN=$ORDER(@EASTMP@(EASANV,EASIEN))
if 'EASIEN
QUIT
Begin DoDot:2
+12 SET EASDAT=@EASTMP@(EASANV,EASIEN)
+13 ; Get data and format print line
DO PRTLINE(EASANV,EASDAT)
+14 IF $EXTRACT(IOST,1,2)="C-"
IF ($Y+5)>IOSL
Begin DoDot:3
+15 SET DIR(0)="E"
+16 DO ^DIR
KILL DIR
+17 IF 'Y
SET EASABRT=1
QUIT
+18 DO HDR(.EASDT)
End DoDot:3
End DoDot:2
if $GET(EASABRT)
QUIT
End DoDot:1
if $GET(EASABRT)
QUIT
+19 QUIT
+20 ;
PRTLINE(EASANV,EASDAT) ; Format and print report line
+1 NEW DFN,EASNAME,EASTAT,EASAPT,EASF,EACL
+2 ;
+3 SET DFN=$PIECE(EASDAT,U)
+4 SET EASNAME=$$GET1^DIQ(2,DFN,.01)
+5 WRITE !,$EXTRACT(EASNAME,1,20)
+6 ;
+7 DO PID^VADPT6
+8 WRITE ?22,VA("PID")
+9 ;
+10 WRITE ?35,$TRANSLATE($$FMTE^XLFDT($$FMADD^XLFDT(EASANV,365),"2F")," ","0")
+11 SET EASTAT=$PIECE(EASDAT,U,5)
+12 WRITE ?46,$SELECT(EASTAT="C":"MT CPR",EASTAT="A":"MT CPE",EASTAT="R":"REQD",EASTAT="N":"NA",EASTAT="P":"PEND",EASTAT="G":"GMT CPR",1:"")
+13 ;
+14 IF $DATA(^TMP($JOB,"SDAMA","ERROR"))
QUIT
+15 DO GETAPT(DFN,.EASAPT)
+16 IF $DATA(EASAPT)
Begin DoDot:1
+17 SET EACL=0
FOR
SET EACL=$ORDER(EASAPT(EACL))
if 'EACL
QUIT
Begin DoDot:2
+18 if $GET(EASF)
WRITE !
+19 WRITE ?55,$EXTRACT($$GET1^DIQ(44,EACL,.01),1,15)," ",$$FMTE^XLFDT(EASAPT(EACL),"2D")
+20 SET EASF=1
End DoDot:2
End DoDot:1
+21 ;
+22 DO KVA^VADPT
+23 QUIT
+24 ;
GETAPT(DFN,EASAPT) ; Get future appointments for patient
+1 NEW EASAP,EASND,EASCL
+2 if '$DATA(^TMP($JOB,"SDAMA",DFN))
QUIT
+3 SET EASAP=0
FOR
SET EASAP=$ORDER(^TMP($JOB,"SDAMA",DFN,EASAP))
if 'EASAP
QUIT
Begin DoDot:1
+4 SET EASND=^TMP($JOB,"SDAMA",DFN,EASAP)
+5 SET EASCL=+$PIECE(EASND,U,2)
SET EASAPT(EASCL)=+EASND
End DoDot:1
+6 QUIT
+7 ;
HDR(EASDT) ; Print report header
+1 NEW ERROR,LINE,SPACE,TXT,HDR,TAB
+2 ;
+3 IF $EXTRACT(IOST,1,2)="C-"
WRITE @IOF
+4 SET TXT="Means Test Expiration Report"
+5 SET SPACE=(IOM-$LENGTH(TXT))/2
+6 SET $PIECE(HDR," ",SPACE)=""
SET HDR=HDR_TXT
+7 WRITE !,HDR
KILL HDR
+8 ;
+9 SET TXT="Anniversary Date(s): "_$$FMTE^XLFDT(EASDT("BEG"),"5D")_" - "_$$FMTE^XLFDT(EASDT("END"),"5D")
+10 SET SPACE=(IOM-$LENGTH(TXT))/2
+11 SET $PIECE(HDR," ",SPACE)=""
SET HDR=HDR_TXT
+12 WRITE !,HDR
KILL HDR
+13 ;
+14 WRITE !!,"Printed: "_$$FMTE^XLFDT($$NOW^XLFDT)
+15 SET PAGE=$GET(PAGE)+1
+16 SET TAB=IOM-8
+17 WRITE ?TAB,"Page "_PAGE
+18 SET ERROR=$GET(^TMP($JOB,"SDAMA","ERROR"))
+19 if ERROR'=""
WRITE !,"Appointment Error: ",ERROR
+20 ;
+21 WRITE !,"Patient",?25,"SSN",?35,"MT Expired",?46,"Status",?57,"Future Appts"
+22 SET $PIECE(LINE,"=",IOM)=""
WRITE !,LINE
+23 QUIT
