EASMTRP3 ; ALB/GAH - MEANS TEST ANV DATES BY APPT DATE ; 10/10/2006
;;1.0;ENROLLMENT APPLICATION SYSTEM;**3,15,46,64,77**;MAR 15,2001;Build 11
;
QUE ; Que off the appointment list search by MT anniversary date
N EASDT,ZTSAVE
;
S DIR(0)="DAO^DT::EX"
S DIR("B")="TODAY",DIR("A")="Run report for date: ",DIR("?")="^D HELP^%DTC"
D ^DIR K DIR
Q:$D(DIRUT)
S EASDT=Y
;
S ZTSAVE("EASDT")=""
D EN^XUTMDEVQ("EN^EASMTRP3","EAS MT DUE BY APPOINTMENT RPT",.ZTSAVE)
Q
;
EN ; Main entry point for appointment list by MT anniversary date
N EASSC,ERROR,PAGE,ACNT,RCNT,DGARRAY,I,CLARR,SDCNT,DGADDF,DGMSGF,DGREQF
K ^TMP("EASAP",$J)
S PAGE=1,^TMP("EASAP",$J,"APDT")=EASDT
;
; Build Array of Valid Clinic IENs
S ACNT=1,(RCNT,EASSC)=0 F S EASSC=$O(^SC(EASSC)) Q:'EASSC D
.Q:'$D(^SC(EASSC,0))
.Q:$P(^SC(EASSC,0),U,3)'="C"
.S RCNT=RCNT+1,CLARR(ACNT)=$G(CLARR(ACNT))_EASSC_";"
.; Group Clinic IENs by no more than thirty
.I RCNT>29 S ACNT=ACNT+1,RCNT=0
;
; Call SD API by array of Clinic IENs
S DGARRAY(1)=EASDT_";"_EASDT,DGARRAY("FLDS")="1;3"
F I=1:1 Q:'$D(CLARR(I)) D
.S DGARRAY(2)=CLARR(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",CLARR(I))=^TMP($J,"SDAMA301",ERROR)
.K ^TMP($J,"SDAMA301")
D LOOP,PRINT
K DGARRAY,CLARR,I,^TMP($J,"SDAMA")
Q
;
LOOP ; Loop through a clinic's appointment list
N DFN,EASANV,EASAPT
;
S EASSC=0 F S EASSC=$O(^TMP($J,"SDAMA",EASSC)) Q:'EASSC D
.; Check for retrieval error
.I $D(^TMP($J,"SDAMA",EASSC))=1 S ^TMP("EASAP",$J,"CLN",EASSC)=^TMP($J,"SDAMA",EASSC) Q
.S DFN=0 F S DFN=$O(^TMP($J,"SDAMA",EASSC,DFN)) Q:'DFN D
..S EASAPT=0 F S EASAPT=$O(^TMP($J,"SDAMA",EASSC,DFN,EASAPT)) Q:'EASAPT D
...; Quit if appointment has been cancelled
...Q:$P($P(^TMP($J,"SDAMA",EASSC,DFN,EASAPT),U,3),";")["C"
...S LASTMT=$$LST^DGMTU(DFN) ; Get patient's last Means test
...; Quit if means test is no longer required or pending
...Q:"^N^P^"[(U_$P(LASTMT,U,4)_U)
...; Quit if means test is not required by DGMTR (EAS*1.0*64)
...I $P(LASTMT,U,4)'="R" S (DGADDF,DGMSGF)=1 D EN^DGMTR I '$G(DGREQF) Q
...; Quit if Cat C, agreed to pay deduct. and MT was after 10/5/1999
...I $P(LASTMT,U,4)="C",$$GET1^DIQ(408.31,+LASTMT,.11,"I"),$P(LASTMT,U,2)>2991005 Q
...; Quit if a Future Dated MT is on file
...Q:$$FUT^DGMTU(DFN)
...; If appt dt is later than anniversary dt, add veteran to list.
...S EASANV=$P(LASTMT,U,2)
...S:$P(LASTMT,U,4)'="R" EASANV=$$FMADD^XLFDT(EASANV,365)
...I EASDT'<EASANV S ^TMP("EASAP",$J,"CLN",EASSC,DFN,EASAPT)=""
Q
;
PRINT ; Print Report
N EACLN,ERROR,DFN,LASTMT,VA,ANVDT,PAGE,EASABRT,APDT,XX
;
I '$D(^TMP("EASAP",$J,"CLN")) D Q
. S PAGE=1 S XX=$$HDR("")
. W !!?3,"No MT Anniversary dates found for this appointment date."
;
W !
S (EACLN,ERROR)=0
F S EACLN=$O(^TMP("EASAP",$J,"CLN",EACLN)) Q:'EACLN D Q:$G(EASABRT)!ERROR
. S PAGE=1 S EASABRT=$$HDR(EACLN) Q:$G(EASABRT)
. I $D(^TMP("EASAP",$J,"CLN",EACLN))=1 S ERROR=1 W !,^TMP("EASAP",$J,"CLN",EACLN) Q
. S DFN=0
. F S DFN=$O(^TMP("EASAP",$J,"CLN",EACLN,DFN)) Q:'DFN D Q:$G(EASABRT)
. . S LASTMT=$$LST^DGMTU(DFN),ANVDT=$P(LASTMT,U,2)
. . I $P(LASTMT,U,4)'="R",ANVDT>0 S ANVDT=$$FMADD^XLFDT(ANVDT,365)
. . W !?3,$$GET1^DIQ(2,DFN,.01)
. . D PID^VADPT6
. . W ?30,VA("BID") K VA
. . W ?38,$S(ANVDT>0:$$FMTE^XLFDT(ANVDT),1:"")
. . S APDT=0
. . F S APDT=$O(^TMP("EASAP",$J,"CLN",EACLN,DFN,APDT)) Q:'APDT D Q:$G(EASABRT)
. . . W ?55,$$FMTE^XLFDT(APDT,"2P"),!
. . . I ($Y+5)>IOSL S EASABRT=$$HDR(EACLN)
;
Q
;
HDR(EASCLN) ; Report Header
N TAB,LINE,CLINIC,RSLT
;
S RSLT=0
I $E(IOST,1,2)="C-" D I RSLT Q RSLT
. S DIR(0)="E"
. D ^DIR K DIR
. I 'Y S RSLT=1
;
W @IOF
S CLINIC=$S(EASCLN>0:$$GET1^DIQ(44,EASCLN,.01),1:"")
W "Means Test Expiration Report by Appt Date "_$S(CLINIC]"":"for "_CLINIC,1:"")
W !!,"For Appointment Date: ",$$FMTE^XLFDT(^TMP("EASAP",$J,"APDT"))
W !,"Print Date: ",$$FMTE^XLFDT($$NOW^XLFDT)
S TAB=IOM-10
W ?TAB,"Page "_PAGE
S PAGE=PAGE+1
;
W !!?30,"Last",?38,"Anniversary",?55,"Appointment"
W !?3,"Name",?30,"Four",?38,"Date",?55,"Time"
S $P(LINE,"=",IOM)="" W !,LINE,!
;
Q 0
;
PAUSE ;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HEASMTRP3 4333 printed Oct 16, 2024@17:56:20 Page 2
EASMTRP3 ; ALB/GAH - MEANS TEST ANV DATES BY APPT DATE ; 10/10/2006
+1 ;;1.0;ENROLLMENT APPLICATION SYSTEM;**3,15,46,64,77**;MAR 15,2001;Build 11
+2 ;
QUE ; Que off the appointment list search by MT anniversary date
+1 NEW EASDT,ZTSAVE
+2 ;
+3 SET DIR(0)="DAO^DT::EX"
+4 SET DIR("B")="TODAY"
SET DIR("A")="Run report for date: "
SET DIR("?")="^D HELP^%DTC"
+5 DO ^DIR
KILL DIR
+6 if $DATA(DIRUT)
QUIT
+7 SET EASDT=Y
+8 ;
+9 SET ZTSAVE("EASDT")=""
+10 DO EN^XUTMDEVQ("EN^EASMTRP3","EAS MT DUE BY APPOINTMENT RPT",.ZTSAVE)
+11 QUIT
+12 ;
EN ; Main entry point for appointment list by MT anniversary date
+1 NEW EASSC,ERROR,PAGE,ACNT,RCNT,DGARRAY,I,CLARR,SDCNT,DGADDF,DGMSGF,DGREQF
+2 KILL ^TMP("EASAP",$JOB)
+3 SET PAGE=1
SET ^TMP("EASAP",$JOB,"APDT")=EASDT
+4 ;
+5 ; Build Array of Valid Clinic IENs
+6 SET ACNT=1
SET (RCNT,EASSC)=0
FOR
SET EASSC=$ORDER(^SC(EASSC))
if 'EASSC
QUIT
Begin DoDot:1
+7 if '$DATA(^SC(EASSC,0))
QUIT
+8 if $PIECE(^SC(EASSC,0),U,3)'="C"
QUIT
+9 SET RCNT=RCNT+1
SET CLARR(ACNT)=$GET(CLARR(ACNT))_EASSC_";"
+10 ; Group Clinic IENs by no more than thirty
+11 IF RCNT>29
SET ACNT=ACNT+1
SET RCNT=0
End DoDot:1
+12 ;
+13 ; Call SD API by array of Clinic IENs
+14 SET DGARRAY(1)=EASDT_";"_EASDT
SET DGARRAY("FLDS")="1;3"
+15 FOR I=1:1
if '$DATA(CLARR(I))
QUIT
Begin DoDot:1
+16 SET DGARRAY(2)=CLARR(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",CLARR(I))=^TMP($JOB,"SDAMA301",ERROR)
End DoDot:2
+22 KILL ^TMP($JOB,"SDAMA301")
End DoDot:1
+23 DO LOOP
DO PRINT
+24 KILL DGARRAY,CLARR,I,^TMP($JOB,"SDAMA")
+25 QUIT
+26 ;
LOOP ; Loop through a clinic's appointment list
+1 NEW DFN,EASANV,EASAPT
+2 ;
+3 SET EASSC=0
FOR
SET EASSC=$ORDER(^TMP($JOB,"SDAMA",EASSC))
if 'EASSC
QUIT
Begin DoDot:1
+4 ; Check for retrieval error
+5 IF $DATA(^TMP($JOB,"SDAMA",EASSC))=1
SET ^TMP("EASAP",$JOB,"CLN",EASSC)=^TMP($JOB,"SDAMA",EASSC)
QUIT
+6 SET DFN=0
FOR
SET DFN=$ORDER(^TMP($JOB,"SDAMA",EASSC,DFN))
if 'DFN
QUIT
Begin DoDot:2
+7 SET EASAPT=0
FOR
SET EASAPT=$ORDER(^TMP($JOB,"SDAMA",EASSC,DFN,EASAPT))
if 'EASAPT
QUIT
Begin DoDot:3
+8 ; Quit if appointment has been cancelled
+9 if $PIECE($PIECE(^TMP($JOB,"SDAMA",EASSC,DFN,EASAPT),U,3),";")["C"
QUIT
+10 ; Get patient's last Means test
SET LASTMT=$$LST^DGMTU(DFN)
+11 ; Quit if means test is no longer required or pending
+12 if "^N^P^"[(U_$PIECE(LASTMT,U,4)_U)
QUIT
+13 ; Quit if means test is not required by DGMTR (EAS*1.0*64)
+14 IF $PIECE(LASTMT,U,4)'="R"
SET (DGADDF,DGMSGF)=1
DO EN^DGMTR
IF '$GET(DGREQF)
QUIT
+15 ; Quit if Cat C, agreed to pay deduct. and MT was after 10/5/1999
+16 IF $PIECE(LASTMT,U,4)="C"
IF $$GET1^DIQ(408.31,+LASTMT,.11,"I")
IF $PIECE(LASTMT,U,2)>2991005
QUIT
+17 ; Quit if a Future Dated MT is on file
+18 if $$FUT^DGMTU(DFN)
QUIT
+19 ; If appt dt is later than anniversary dt, add veteran to list.
+20 SET EASANV=$PIECE(LASTMT,U,2)
+21 if $PIECE(LASTMT,U,4)'="R"
SET EASANV=$$FMADD^XLFDT(EASANV,365)
+22 IF EASDT'<EASANV
SET ^TMP("EASAP",$JOB,"CLN",EASSC,DFN,EASAPT)=""
End DoDot:3
End DoDot:2
End DoDot:1
+23 QUIT
+24 ;
PRINT ; Print Report
+1 NEW EACLN,ERROR,DFN,LASTMT,VA,ANVDT,PAGE,EASABRT,APDT,XX
+2 ;
+3 IF '$DATA(^TMP("EASAP",$JOB,"CLN"))
Begin DoDot:1
+4 SET PAGE=1
SET XX=$$HDR("")
+5 WRITE !!?3,"No MT Anniversary dates found for this appointment date."
End DoDot:1
QUIT
+6 ;
+7 WRITE !
+8 SET (EACLN,ERROR)=0
+9 FOR
SET EACLN=$ORDER(^TMP("EASAP",$JOB,"CLN",EACLN))
if 'EACLN
QUIT
Begin DoDot:1
+10 SET PAGE=1
SET EASABRT=$$HDR(EACLN)
if $GET(EASABRT)
QUIT
+11 IF $DATA(^TMP("EASAP",$JOB,"CLN",EACLN))=1
SET ERROR=1
WRITE !,^TMP("EASAP",$JOB,"CLN",EACLN)
QUIT
+12 SET DFN=0
+13 FOR
SET DFN=$ORDER(^TMP("EASAP",$JOB,"CLN",EACLN,DFN))
if 'DFN
QUIT
Begin DoDot:2
+14 SET LASTMT=$$LST^DGMTU(DFN)
SET ANVDT=$PIECE(LASTMT,U,2)
+15 IF $PIECE(LASTMT,U,4)'="R"
IF ANVDT>0
SET ANVDT=$$FMADD^XLFDT(ANVDT,365)
+16 WRITE !?3,$$GET1^DIQ(2,DFN,.01)
+17 DO PID^VADPT6
+18 WRITE ?30,VA("BID")
KILL VA
+19 WRITE ?38,$SELECT(ANVDT>0:$$FMTE^XLFDT(ANVDT),1:"")
+20 SET APDT=0
+21 FOR
SET APDT=$ORDER(^TMP("EASAP",$JOB,"CLN",EACLN,DFN,APDT))
if 'APDT
QUIT
Begin DoDot:3
+22 WRITE ?55,$$FMTE^XLFDT(APDT,"2P"),!
+23 IF ($Y+5)>IOSL
SET EASABRT=$$HDR(EACLN)
End DoDot:3
if $GET(EASABRT)
QUIT
End DoDot:2
if $GET(EASABRT)
QUIT
End DoDot:1
if $GET(EASABRT)!ERROR
QUIT
+24 ;
+25 QUIT
+26 ;
HDR(EASCLN) ; Report Header
+1 NEW TAB,LINE,CLINIC,RSLT
+2 ;
+3 SET RSLT=0
+4 IF $EXTRACT(IOST,1,2)="C-"
Begin DoDot:1
+5 SET DIR(0)="E"
+6 DO ^DIR
KILL DIR
+7 IF 'Y
SET RSLT=1
End DoDot:1
IF RSLT
QUIT RSLT
+8 ;
+9 WRITE @IOF
+10 SET CLINIC=$SELECT(EASCLN>0:$$GET1^DIQ(44,EASCLN,.01),1:"")
+11 WRITE "Means Test Expiration Report by Appt Date "_$SELECT(CLINIC]"":"for "_CLINIC,1:"")
+12 WRITE !!,"For Appointment Date: ",$$FMTE^XLFDT(^TMP("EASAP",$JOB,"APDT"))
+13 WRITE !,"Print Date: ",$$FMTE^XLFDT($$NOW^XLFDT)
+14 SET TAB=IOM-10
+15 WRITE ?TAB,"Page "_PAGE
+16 SET PAGE=PAGE+1
+17 ;
+18 WRITE !!?30,"Last",?38,"Anniversary",?55,"Appointment"
+19 WRITE !?3,"Name",?30,"Four",?38,"Date",?55,"Time"
+20 SET $PIECE(LINE,"=",IOM)=""
WRITE !,LINE,!
+21 ;
+22 QUIT 0
+23 ;
PAUSE ;
+1 QUIT
