- EASMTL6 ; ALB/SCK,BRM,LBD,PHH - AUTOMATED MEANS TEST LETTER-INTERACTIVE PRINT ; 5/22/03 9:52am
- ;;1.0;ENROLLMENT APPLICATION SYSTEM;**3,14,15,29,25,22,54**;MAR 15,2001
- ;
- EN ; Main entry point
- ; Input, set in option call, if not passed in, or called interactively, user is asked to specify.
- ; EATYP - Used for selective printing of letters and forms
- ; 1 : 60-Day
- ; 2 : 30-Day
- ; 4 : 0-Day
- ;
- N DIR,DIRUT,POP,EASLOC,Y
- ;
- ;; Select type of letter to print
- I '$G(EATYP) D Q:$D(DIRUT)
- . S DIR(0)="SO^1:60-Day;2:30-Day;4:0-Day"
- . S DIR("?")="Select the type of letter to print"
- . D ^DIR K DIR
- . S EATYP=+Y
- ;
- ;; Select facility filter if appropriate
- S EASLOC=-1
- I $$GET1^DIQ(713,1,8,"I") D Q:$D(DIRUT)
- . S DIR(0)="YAO",DIR("A")="Filter letters by Preferred Facility? "
- . S DIR("B")="NO"
- . S DIR("?")="Enter 'YES' to limit letters to a specific Facility or 'NO' to print all letters."
- . D ^DIR K DIR
- . Q:$D(DIRUT)!('Y)
- . S EASLOC=$$FACNUM
- ;
- K IOP,IO("Q")
- ;
- S %ZIS="QP",%ZIS("B")=$$GET1^DIQ(713,1,5)
- D ^%ZIS K %ZIS
- Q:POP
- I $D(IO("Q")) D QUE Q
- D LTR
- D ^%ZISC
- K EATYP
- Q
- ;
- QUE ; Queue the report
- N ZTRTN,ZTDESC,ZTSAVE,ZTSK,ZTDTH,ZTQUEUED
- ;
- S ZTRTN="LTR^EASMTL6"
- S ZTDESC="EAS MT LETTERS PRINT JOB"
- S ZTSAVE("EATYP")="",ZTSAVE("EASLOC")=""
- S ZTDTH="NOW"
- ;
- D ^%ZTLOAD
- I $D(ZTSK)[0 W !!?5,"Letters canceled!"
- E W !!?5,"Letters queued! [ ",ZTSK," ]"
- D HOME^%ZIS
- Q
- ;
- LTR ; Main entry point
- N EASTMP,EASKP
- ;
- S EASTMP="^TMP(""EASMT"",$J)"
- K @EASTMP
- ;
- I '$D(ZTQUEUED) W !,"...Gathering letters to print...Please wait"
- D BLD(EATYP,EASLOC,EASTMP,.EASKP)
- D RESULT(.EASKP,EATYP)
- I '$D(ZTQUEUED) W !,"...Printing letters..."
- D PRINT(EASTMP,EATYP)
- K @EASTMP,EATYP
- Q
- ;
- RESULT(EASKP,EATYP) ; Send results of letter printing to mail group
- N MSG,XMSUB,XMY,XMTEXT,XMDUZ,TOT,X1
- ;
- S MSG(1)="Letters to print: "_$J($FN(EASKP("CNT"),","),8)
- S MSG(2)="Letters where the print date has not reached: "_$J($FN(EASKP("T"),","),8)
- S MSG(2.5)=""
- S MSG(3)="The following letters were found but not printed for the following reasons:"
- S MSG(4)="Incomplete/Bad Addr : "_$J($FN(EASKP("I"),","),8)
- S MSG(5)="Deceased : "_$J($FN(EASKP("D"),","),8)
- S MSG(6)="MT Changed: "_$J($FN(EASKP("C"),","),8)
- S MSG(7)="Prohibit flag set: "_$J($FN(EASKP("P"),","),8)
- S MSG(8)="Not a User Enrollee: "_$J($FN(EASKP("U"),","),8)
- S MSG(8.5)="Not a User Enrollee of this facility: "_$J($FN(EASKP("O"),","),8)
- S MSG(9)=""
- S TOT=0 F X1="I","D","C","P","O","T","U","CNT" S TOT=TOT+EASKP(X1)
- S MSG(10)="Total Letters Processed: "_$J($FN(TOT,","),8)_" (MT not returned)"
- ;
- S XMSUB=$S(EATYP=1:"60-Day",EATYP=2:"30-Day",1:"0-Day")_" Print Letter Results"
- S XMTEXT="MSG("
- S XMY("G.EAS MTLETTERS")=""
- S XMDUZ="AUTOMATED MT LETTERS"
- D ^XMD
- Q
- ;
- BLD(EATYP,EASLOC,EASTMP,EASKP) ; Build TMP array of letters to print
- N DFN,EASIEN,COUNT,EAX2,EASPTR,EASABRT,EASUE
- ;
- F EAX2="P","D","C","F","T","I","O","U","CNT" S EASKP(EAX2)=0
- S COUNT=0
- ;
- S EASIEN=0 ; Begin loop through un-returned means tests
- F S EASIEN=$O(^EAS(713.2,"AC",0,EASIEN)) Q:'EASIEN D Q:$G(EASABRT)
- . S EASPTR=$$GET1^DIQ(713.2,EASIEN,2,"I") ; Pointer to File 713.1
- . ; begin checks
- . Q:EASPTR<0 ; SAFETY CHECK
- . Q:$$LTRTYP^EASMTL6B(EASIEN)'=EATYP ; Check for appropriate letter type
- . S DFN=$$GET1^DIQ(713.1,EASPTR,.01,"I") Q:'DFN
- . ;; Filter by site, quit if filter not met
- . I +$G(EASLOC)>0 Q:$$GET1^DIQ(2,DFN,27.02,"I")'=+EASLOC
- . I $D(^EAS(713.1,"AP",1,EASPTR)) D Q ; Check Prohibit letter
- . . D CLRFLG^EASMTUTL(0,EASIEN)
- . . S EASKP("P")=EASKP("P")+1
- . I $$DECEASED^EASMTUTL(EASIEN) D Q ; Check Deceased
- . . D CLRFLG^EASMTUTL(0,EASIEN)
- . . S EASKP("D")=EASKP("D")+1
- . I $$CHECKMT^EASMTUTL(EASPTR,EASIEN) D Q ; Check MT changed?
- . . D CLRFLG^EASMTUTL(0,EASIEN)
- . . S EASKP("C")=EASKP("C")+1 Q
- . I $$FUTMT^EASMTUTL(EASIEN) D Q ; Check for a Future MT
- . . D CLRFLG^EASMTUTL(0,EASIEN)
- . . S EASKP("F")=EASKP("F")+1
- . I '$$THRSHLD(EATYP,EASIEN) D Q ; Quit if letter threshold not reached
- . . S EASKP("T")=EASKP("T")+1
- . ; Get User Enrollee status (0=not UE; 1=UE; 2=UE, not this site)
- . S EASUE=$$UESTAT^EASUER(DFN)
- . I 'EASUE D Q ; Quit if not User Enrollee
- . . D NOPRT(EATYP,EASIEN)
- . . S EASKP("U")=EASKP("U")+1
- . I EASUE'=1 D Q ; Quit if User Enrollee site is not this facility
- . . D NOPRT(EATYP,EASIEN)
- . . S EASKP("O")=EASKP("O")+1
- . I $$CHKADR^EASMTL6A(EASPTR) D Q ; Check for valid address
- . . S EASKP("I")=EASKP("I")+1
- . S @EASTMP@(EASIEN)=EATYP ; Build entry
- . S EASKP("CNT")=EASKP("CNT")+1
- . I $D(IO("Q")),$$S^%ZTLOAD("STOPPED BY USER") S EASABRT=1
- Q
- ;
- OWNED(PTR1,EAIEN) ; Check - Does this facility "own" this means test
- ; Returns '1' if means test 'owned' by facility
- ; '0' if not owned
- ;
- N MTNODE,MTLST,MTOWN,RSLT
- ;
- S RSLT=0
- S MTLST=$$LST^DGMTU(PTR1)
- I $P(MTLST,U,1)>0 D
- . S MTNODE=$G(^DGMT(408.31,$P(MTLST,U,1),0))
- . S MTOWN=$$GET1^DIQ(408.34,$P(MTNODE,U,23),.01)
- . I MTOWN="VAMC" S RSLT=1 Q
- . I MTOWN="DCD",$$VERSION^XPDUTL("IVMC") S RSLT=1
- ;
- ;; If another facility 'owns' this MT, update MT Status information
- I 'RSLT D
- . Q:'EAIEN
- . S DIE="^EAS(713.2,",DA=EAIEN
- . S DR="4///YES;5///TODAY;7///MT 'OWNED' BY ANOTHER FACILITY;9///NO;12///NO;18///NO"
- . D ^DIE K DIE
- ;
- Q RSLT
- ;
- PRINT(EASTMP,EATYP) ; Print letters
- N EASIEN,EASABRT,Y
- ;
- U IO
- S EASIEN=0
- F S EASIEN=$O(@EASTMP@(EASIEN)) Q:'EASIEN D Q:$G(EASABRT)
- . D LETTER^EASMTL6A(EASIEN,EATYP) ; Print letter
- . D UPDSTAT(EASIEN,EATYP) ; Update Letter status file, #713.2
- . I $D(IO("Q")),$$S^%ZTLOAD("STOPPED BY USER") S EASABRT=1 Q
- . I '$D(IO("Q")),$E(IOST,1,2)="C-" D
- . . S DIR(0)="E"
- . . D ^DIR K DIR
- . . S:'Y EASABRT=1
- Q
- ;
- THRSHLD(EATYP,EASIEN) ; Check threshold for letter types
- ; Input
- ; EATYP - Letter type to print
- ; EASIEN - IEN for file #713.2
- ;
- ; Output
- ; RSLT = 1: Letter is inside threshold to print
- ; 0: Letter is outside threshold (Don't print)
- ;
- N DIFF,THRESH,RSLT,ANVDT,MTDT
- ;
- S RSLT=1
- Q:'$G(EATYP)
- S THRESH=$S(EATYP=1:60,EATYP=2:30,1:0)
- S MTDT=$$GET1^DIQ(713.2,EASIEN,3,"I")
- S ANVDT=$$ADDLEAP^EASMTUTL(MTDT)
- S DIFF=$$FMDIFF^XLFDT(ANVDT,$$DT^XLFDT)
- I DIFF>THRESH S RSLT=0
- Q RSLT
- ;
- NOPRT(EATYP,EASIEN) ; Letter not printed, update Letter Status file #713.2
- ; Input
- ; EATYP - Letter type to print
- ; EASIEN - IEN for file #713.2
- ;
- N DIE,DR,DA,LTR
- Q:'$G(EATYP) Q:'$G(EASIEN)
- S DIE="^EAS(713.2,",DA=EASIEN
- S LTR=$S(EATYP=1:9,EATYP=2:12,EATYP=4:18,1:0)
- Q:'LTR
- ; Set current letter print statuses = "N"
- S DR=LTR_"///0;"_(LTR+1)_"///0"
- ; If current letter is not 0-day letter, set next letter print = "Y"
- S:LTR'=18 DR=DR_";"_$S(LTR=9:12,1:18)_"///1"
- D ^DIE
- Q
- ;
- UPDSTAT(EASN,EAX) ; Update Letter status file, #713.2
- N DIE,DR,DA,EAPD,EAFLG,NXTFLG
- ;
- S DIE="^EAS(713.2,",DA=EASN
- S DR=$S(EAX=1:10,EAX=2:13,EAX=4:19,1:0)
- Q:'DR
- S EAPD=DR_".5",EAFLG=DR-1
- S DR=DR_"///1;"_EAPD_"///^S X=$$DT^XLFDT;"_EAFLG_"///0"
- S NXTFLG=$S(EAFLG=9:12,EAFLG=12:18,1:0)
- S:NXTFLG>0 DR=DR_";"_NXTFLG_"///1"
- D ^DIE K DIE
- D CLRFLG^EASMTUTL(EAX,EASN)
- Q
- ;
- FACNUM() ; Get facility number
- N RSLT,DIR,Y
- ;
- S DIR(0)="P^4:EMZ"
- S DIR("S")="I '$P($G(^DIC(4,Y,99)),U,4)"
- D ^DIR K DIR
- I $D(DIRUT) S RSLT=0
- E S RSLT=+Y_"^"_$P($G(^DIC(4,+Y,99)),U,1)
- ;
- Q RSLT
- ;
- GETFAC(EADFN,EASARY) ; set facility return address information
- N EASFAC,EAX,EASF,EAS4
- ;
- I $$GET1^DIQ(713,1,9,"I") D
- . S EASFAC=$$GET1^DIQ(2,EADFN,27.02,"I")
- . Q:'EASFAC
- . ;; Check for inactive flag
- . Q:$$GET1^DIQ(4,EASFAC,101,"I")
- . D GETS^DIQ(4,EASFAC,".01;1.01;1.02;1.03;1.04;.02;100","EI","EAS4")
- . S EASF=EASFAC_","
- . ;; Check for valid address information
- . I EAS4(4,EASF,1.01,"E")]"",EAS4(4,EASF,1.03,"E")]"",EAS4(4,EASF,.02,"E")]"" S EASARY("TYP")="P"
- ;
- I $G(EASARY("TYP"))'="P" D
- . S EASFAC=$$SITE^VASITE
- . D GETS^DIQ(4,+EASFAC,".01;1.01;1.02;1.03;1.04;.02;100","EI","EAS4")
- . S EASARY("TYP")="F"
- ;
- S EASARY("FACNUM")=+EASFAC
- S EASARY("FAC")=$$GET1^DIQ(4,+EASFAC,.01,"I")
- F EAX=1.01,1.02,1.03,1.04,100 D
- . S EASARY(EAX)=EAS4(4,+EASFAC_",",EAX,"E")
- S EASARY(.02)=EAS4(4,+EASFAC_",",.02,"E")_"^"_$$GET1^DIQ(5,EAS4(4,+EASFAC_",",.02,"I"),1)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HEASMTL6 8526 printed Feb 18, 2025@23:21:50 Page 2
- EASMTL6 ; ALB/SCK,BRM,LBD,PHH - AUTOMATED MEANS TEST LETTER-INTERACTIVE PRINT ; 5/22/03 9:52am
- +1 ;;1.0;ENROLLMENT APPLICATION SYSTEM;**3,14,15,29,25,22,54**;MAR 15,2001
- +2 ;
- EN ; Main entry point
- +1 ; Input, set in option call, if not passed in, or called interactively, user is asked to specify.
- +2 ; EATYP - Used for selective printing of letters and forms
- +3 ; 1 : 60-Day
- +4 ; 2 : 30-Day
- +5 ; 4 : 0-Day
- +6 ;
- +7 NEW DIR,DIRUT,POP,EASLOC,Y
- +8 ;
- +9 ;; Select type of letter to print
- +10 IF '$GET(EATYP)
- Begin DoDot:1
- +11 SET DIR(0)="SO^1:60-Day;2:30-Day;4:0-Day"
- +12 SET DIR("?")="Select the type of letter to print"
- +13 DO ^DIR
- KILL DIR
- +14 SET EATYP=+Y
- End DoDot:1
- if $DATA(DIRUT)
- QUIT
- +15 ;
- +16 ;; Select facility filter if appropriate
- +17 SET EASLOC=-1
- +18 IF $$GET1^DIQ(713,1,8,"I")
- Begin DoDot:1
- +19 SET DIR(0)="YAO"
- SET DIR("A")="Filter letters by Preferred Facility? "
- +20 SET DIR("B")="NO"
- +21 SET DIR("?")="Enter 'YES' to limit letters to a specific Facility or 'NO' to print all letters."
- +22 DO ^DIR
- KILL DIR
- +23 if $DATA(DIRUT)!('Y)
- QUIT
- +24 SET EASLOC=$$FACNUM
- End DoDot:1
- if $DATA(DIRUT)
- QUIT
- +25 ;
- +26 KILL IOP,IO("Q")
- +27 ;
- +28 SET %ZIS="QP"
- SET %ZIS("B")=$$GET1^DIQ(713,1,5)
- +29 DO ^%ZIS
- KILL %ZIS
- +30 if POP
- QUIT
- +31 IF $DATA(IO("Q"))
- DO QUE
- QUIT
- +32 DO LTR
- +33 DO ^%ZISC
- +34 KILL EATYP
- +35 QUIT
- +36 ;
- QUE ; Queue the report
- +1 NEW ZTRTN,ZTDESC,ZTSAVE,ZTSK,ZTDTH,ZTQUEUED
- +2 ;
- +3 SET ZTRTN="LTR^EASMTL6"
- +4 SET ZTDESC="EAS MT LETTERS PRINT JOB"
- +5 SET ZTSAVE("EATYP")=""
- SET ZTSAVE("EASLOC")=""
- +6 SET ZTDTH="NOW"
- +7 ;
- +8 DO ^%ZTLOAD
- +9 IF $DATA(ZTSK)[0
- WRITE !!?5,"Letters canceled!"
- +10 IF '$TEST
- WRITE !!?5,"Letters queued! [ ",ZTSK," ]"
- +11 DO HOME^%ZIS
- +12 QUIT
- +13 ;
- LTR ; Main entry point
- +1 NEW EASTMP,EASKP
- +2 ;
- +3 SET EASTMP="^TMP(""EASMT"",$J)"
- +4 KILL @EASTMP
- +5 ;
- +6 IF '$DATA(ZTQUEUED)
- WRITE !,"...Gathering letters to print...Please wait"
- +7 DO BLD(EATYP,EASLOC,EASTMP,.EASKP)
- +8 DO RESULT(.EASKP,EATYP)
- +9 IF '$DATA(ZTQUEUED)
- WRITE !,"...Printing letters..."
- +10 DO PRINT(EASTMP,EATYP)
- +11 KILL @EASTMP,EATYP
- +12 QUIT
- +13 ;
- RESULT(EASKP,EATYP) ; Send results of letter printing to mail group
- +1 NEW MSG,XMSUB,XMY,XMTEXT,XMDUZ,TOT,X1
- +2 ;
- +3 SET MSG(1)="Letters to print: "_$JUSTIFY($FNUMBER(EASKP("CNT"),","),8)
- +4 SET MSG(2)="Letters where the print date has not reached: "_$JUSTIFY($FNUMBER(EASKP("T"),","),8)
- +5 SET MSG(2.5)=""
- +6 SET MSG(3)="The following letters were found but not printed for the following reasons:"
- +7 SET MSG(4)="Incomplete/Bad Addr : "_$JUSTIFY($FNUMBER(EASKP("I"),","),8)
- +8 SET MSG(5)="Deceased : "_$JUSTIFY($FNUMBER(EASKP("D"),","),8)
- +9 SET MSG(6)="MT Changed: "_$JUSTIFY($FNUMBER(EASKP("C"),","),8)
- +10 SET MSG(7)="Prohibit flag set: "_$JUSTIFY($FNUMBER(EASKP("P"),","),8)
- +11 SET MSG(8)="Not a User Enrollee: "_$JUSTIFY($FNUMBER(EASKP("U"),","),8)
- +12 SET MSG(8.5)="Not a User Enrollee of this facility: "_$JUSTIFY($FNUMBER(EASKP("O"),","),8)
- +13 SET MSG(9)=""
- +14 SET TOT=0
- FOR X1="I","D","C","P","O","T","U","CNT"
- SET TOT=TOT+EASKP(X1)
- +15 SET MSG(10)="Total Letters Processed: "_$JUSTIFY($FNUMBER(TOT,","),8)_" (MT not returned)"
- +16 ;
- +17 SET XMSUB=$SELECT(EATYP=1:"60-Day",EATYP=2:"30-Day",1:"0-Day")_" Print Letter Results"
- +18 SET XMTEXT="MSG("
- +19 SET XMY("G.EAS MTLETTERS")=""
- +20 SET XMDUZ="AUTOMATED MT LETTERS"
- +21 DO ^XMD
- +22 QUIT
- +23 ;
- BLD(EATYP,EASLOC,EASTMP,EASKP) ; Build TMP array of letters to print
- +1 NEW DFN,EASIEN,COUNT,EAX2,EASPTR,EASABRT,EASUE
- +2 ;
- +3 FOR EAX2="P","D","C","F","T","I","O","U","CNT"
- SET EASKP(EAX2)=0
- +4 SET COUNT=0
- +5 ;
- +6 ; Begin loop through un-returned means tests
- SET EASIEN=0
- +7 FOR
- SET EASIEN=$ORDER(^EAS(713.2,"AC",0,EASIEN))
- if 'EASIEN
- QUIT
- Begin DoDot:1
- +8 ; Pointer to File 713.1
- SET EASPTR=$$GET1^DIQ(713.2,EASIEN,2,"I")
- +9 ; begin checks
- +10 ; SAFETY CHECK
- if EASPTR<0
- QUIT
- +11 ; Check for appropriate letter type
- if $$LTRTYP^EASMTL6B(EASIEN)'=EATYP
- QUIT
- +12 SET DFN=$$GET1^DIQ(713.1,EASPTR,.01,"I")
- if 'DFN
- QUIT
- +13 ;; Filter by site, quit if filter not met
- +14 IF +$GET(EASLOC)>0
- if $$GET1^DIQ(2,DFN,27.02,"I")'=+EASLOC
- QUIT
- +15 ; Check Prohibit letter
- IF $DATA(^EAS(713.1,"AP",1,EASPTR))
- Begin DoDot:2
- +16 DO CLRFLG^EASMTUTL(0,EASIEN)
- +17 SET EASKP("P")=EASKP("P")+1
- End DoDot:2
- QUIT
- +18 ; Check Deceased
- IF $$DECEASED^EASMTUTL(EASIEN)
- Begin DoDot:2
- +19 DO CLRFLG^EASMTUTL(0,EASIEN)
- +20 SET EASKP("D")=EASKP("D")+1
- End DoDot:2
- QUIT
- +21 ; Check MT changed?
- IF $$CHECKMT^EASMTUTL(EASPTR,EASIEN)
- Begin DoDot:2
- +22 DO CLRFLG^EASMTUTL(0,EASIEN)
- +23 SET EASKP("C")=EASKP("C")+1
- QUIT
- End DoDot:2
- QUIT
- +24 ; Check for a Future MT
- IF $$FUTMT^EASMTUTL(EASIEN)
- Begin DoDot:2
- +25 DO CLRFLG^EASMTUTL(0,EASIEN)
- +26 SET EASKP("F")=EASKP("F")+1
- End DoDot:2
- QUIT
- +27 ; Quit if letter threshold not reached
- IF '$$THRSHLD(EATYP,EASIEN)
- Begin DoDot:2
- +28 SET EASKP("T")=EASKP("T")+1
- End DoDot:2
- QUIT
- +29 ; Get User Enrollee status (0=not UE; 1=UE; 2=UE, not this site)
- +30 SET EASUE=$$UESTAT^EASUER(DFN)
- +31 ; Quit if not User Enrollee
- IF 'EASUE
- Begin DoDot:2
- +32 DO NOPRT(EATYP,EASIEN)
- +33 SET EASKP("U")=EASKP("U")+1
- End DoDot:2
- QUIT
- +34 ; Quit if User Enrollee site is not this facility
- IF EASUE'=1
- Begin DoDot:2
- +35 DO NOPRT(EATYP,EASIEN)
- +36 SET EASKP("O")=EASKP("O")+1
- End DoDot:2
- QUIT
- +37 ; Check for valid address
- IF $$CHKADR^EASMTL6A(EASPTR)
- Begin DoDot:2
- +38 SET EASKP("I")=EASKP("I")+1
- End DoDot:2
- QUIT
- +39 ; Build entry
- SET @EASTMP@(EASIEN)=EATYP
- +40 SET EASKP("CNT")=EASKP("CNT")+1
- +41 IF $DATA(IO("Q"))
- IF $$S^%ZTLOAD("STOPPED BY USER")
- SET EASABRT=1
- End DoDot:1
- if $GET(EASABRT)
- QUIT
- +42 QUIT
- +43 ;
- OWNED(PTR1,EAIEN) ; Check - Does this facility "own" this means test
- +1 ; Returns '1' if means test 'owned' by facility
- +2 ; '0' if not owned
- +3 ;
- +4 NEW MTNODE,MTLST,MTOWN,RSLT
- +5 ;
- +6 SET RSLT=0
- +7 SET MTLST=$$LST^DGMTU(PTR1)
- +8 IF $PIECE(MTLST,U,1)>0
- Begin DoDot:1
- +9 SET MTNODE=$GET(^DGMT(408.31,$PIECE(MTLST,U,1),0))
- +10 SET MTOWN=$$GET1^DIQ(408.34,$PIECE(MTNODE,U,23),.01)
- +11 IF MTOWN="VAMC"
- SET RSLT=1
- QUIT
- +12 IF MTOWN="DCD"
- IF $$VERSION^XPDUTL("IVMC")
- SET RSLT=1
- End DoDot:1
- +13 ;
- +14 ;; If another facility 'owns' this MT, update MT Status information
- +15 IF 'RSLT
- Begin DoDot:1
- +16 if 'EAIEN
- QUIT
- +17 SET DIE="^EAS(713.2,"
- SET DA=EAIEN
- +18 SET DR="4///YES;5///TODAY;7///MT 'OWNED' BY ANOTHER FACILITY;9///NO;12///NO;18///NO"
- +19 DO ^DIE
- KILL DIE
- End DoDot:1
- +20 ;
- +21 QUIT RSLT
- +22 ;
- PRINT(EASTMP,EATYP) ; Print letters
- +1 NEW EASIEN,EASABRT,Y
- +2 ;
- +3 USE IO
- +4 SET EASIEN=0
- +5 FOR
- SET EASIEN=$ORDER(@EASTMP@(EASIEN))
- if 'EASIEN
- QUIT
- Begin DoDot:1
- +6 ; Print letter
- DO LETTER^EASMTL6A(EASIEN,EATYP)
- +7 ; Update Letter status file, #713.2
- DO UPDSTAT(EASIEN,EATYP)
- +8 IF $DATA(IO("Q"))
- IF $$S^%ZTLOAD("STOPPED BY USER")
- SET EASABRT=1
- QUIT
- +9 IF '$DATA(IO("Q"))
- IF $EXTRACT(IOST,1,2)="C-"
- Begin DoDot:2
- +10 SET DIR(0)="E"
- +11 DO ^DIR
- KILL DIR
- +12 if 'Y
- SET EASABRT=1
- End DoDot:2
- End DoDot:1
- if $GET(EASABRT)
- QUIT
- +13 QUIT
- +14 ;
- THRSHLD(EATYP,EASIEN) ; Check threshold for letter types
- +1 ; Input
- +2 ; EATYP - Letter type to print
- +3 ; EASIEN - IEN for file #713.2
- +4 ;
- +5 ; Output
- +6 ; RSLT = 1: Letter is inside threshold to print
- +7 ; 0: Letter is outside threshold (Don't print)
- +8 ;
- +9 NEW DIFF,THRESH,RSLT,ANVDT,MTDT
- +10 ;
- +11 SET RSLT=1
- +12 if '$GET(EATYP)
- QUIT
- +13 SET THRESH=$SELECT(EATYP=1:60,EATYP=2:30,1:0)
- +14 SET MTDT=$$GET1^DIQ(713.2,EASIEN,3,"I")
- +15 SET ANVDT=$$ADDLEAP^EASMTUTL(MTDT)
- +16 SET DIFF=$$FMDIFF^XLFDT(ANVDT,$$DT^XLFDT)
- +17 IF DIFF>THRESH
- SET RSLT=0
- +18 QUIT RSLT
- +19 ;
- NOPRT(EATYP,EASIEN) ; Letter not printed, update Letter Status file #713.2
- +1 ; Input
- +2 ; EATYP - Letter type to print
- +3 ; EASIEN - IEN for file #713.2
- +4 ;
- +5 NEW DIE,DR,DA,LTR
- +6 if '$GET(EATYP)
- QUIT
- if '$GET(EASIEN)
- QUIT
- +7 SET DIE="^EAS(713.2,"
- SET DA=EASIEN
- +8 SET LTR=$SELECT(EATYP=1:9,EATYP=2:12,EATYP=4:18,1:0)
- +9 if 'LTR
- QUIT
- +10 ; Set current letter print statuses = "N"
- +11 SET DR=LTR_"///0;"_(LTR+1)_"///0"
- +12 ; If current letter is not 0-day letter, set next letter print = "Y"
- +13 if LTR'=18
- SET DR=DR_";"_$SELECT(LTR=9:12,1:18)_"///1"
- +14 DO ^DIE
- +15 QUIT
- +16 ;
- UPDSTAT(EASN,EAX) ; Update Letter status file, #713.2
- +1 NEW DIE,DR,DA,EAPD,EAFLG,NXTFLG
- +2 ;
- +3 SET DIE="^EAS(713.2,"
- SET DA=EASN
- +4 SET DR=$SELECT(EAX=1:10,EAX=2:13,EAX=4:19,1:0)
- +5 if 'DR
- QUIT
- +6 SET EAPD=DR_".5"
- SET EAFLG=DR-1
- +7 SET DR=DR_"///1;"_EAPD_"///^S X=$$DT^XLFDT;"_EAFLG_"///0"
- +8 SET NXTFLG=$SELECT(EAFLG=9:12,EAFLG=12:18,1:0)
- +9 if NXTFLG>0
- SET DR=DR_";"_NXTFLG_"///1"
- +10 DO ^DIE
- KILL DIE
- +11 DO CLRFLG^EASMTUTL(EAX,EASN)
- +12 QUIT
- +13 ;
- FACNUM() ; Get facility number
- +1 NEW RSLT,DIR,Y
- +2 ;
- +3 SET DIR(0)="P^4:EMZ"
- +4 SET DIR("S")="I '$P($G(^DIC(4,Y,99)),U,4)"
- +5 DO ^DIR
- KILL DIR
- +6 IF $DATA(DIRUT)
- SET RSLT=0
- +7 IF '$TEST
- SET RSLT=+Y_"^"_$PIECE($GET(^DIC(4,+Y,99)),U,1)
- +8 ;
- +9 QUIT RSLT
- +10 ;
- GETFAC(EADFN,EASARY) ; set facility return address information
- +1 NEW EASFAC,EAX,EASF,EAS4
- +2 ;
- +3 IF $$GET1^DIQ(713,1,9,"I")
- Begin DoDot:1
- +4 SET EASFAC=$$GET1^DIQ(2,EADFN,27.02,"I")
- +5 if 'EASFAC
- QUIT
- +6 ;; Check for inactive flag
- +7 if $$GET1^DIQ(4,EASFAC,101,"I")
- QUIT
- +8 DO GETS^DIQ(4,EASFAC,".01;1.01;1.02;1.03;1.04;.02;100","EI","EAS4")
- +9 SET EASF=EASFAC_","
- +10 ;; Check for valid address information
- +11 IF EAS4(4,EASF,1.01,"E")]""
- IF EAS4(4,EASF,1.03,"E")]""
- IF EAS4(4,EASF,.02,"E")]""
- SET EASARY("TYP")="P"
- End DoDot:1
- +12 ;
- +13 IF $GET(EASARY("TYP"))'="P"
- Begin DoDot:1
- +14 SET EASFAC=$$SITE^VASITE
- +15 DO GETS^DIQ(4,+EASFAC,".01;1.01;1.02;1.03;1.04;.02;100","EI","EAS4")
- +16 SET EASARY("TYP")="F"
- End DoDot:1
- +17 ;
- +18 SET EASARY("FACNUM")=+EASFAC
- +19 SET EASARY("FAC")=$$GET1^DIQ(4,+EASFAC,.01,"I")
- +20 FOR EAX=1.01,1.02,1.03,1.04,100
- Begin DoDot:1
- +21 SET EASARY(EAX)=EAS4(4,+EASFAC_",",EAX,"E")
- End DoDot:1
- +22 SET EASARY(.02)=EAS4(4,+EASFAC_",",.02,"E")_"^"_$$GET1^DIQ(5,EAS4(4,+EASFAC_",",.02,"I"),1)
- +23 QUIT