- 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 Mar 13, 2025@21:00:13 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
