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

EASPTRN1.m

Go to the documentation of this file.
  1. EASPTRN1 ;ALB/EJG,GN - GENERATE EAS SUBPROCESSES ; 11/09/2004
  1. ;;1.0;ENROLLMENT APPLICATION SYSTEM;**30,33,47,42,59**; 21-OCT-94
  1. ;;Per VHA Directive 10-93-142, this routine should not be modified.
  1. ;
  1. ; Cloned from IVMPTRN1
  1. ;
  1. ;EAS*1*47 - break up Z09's by Income year, via new "ATR" xref
  1. ;EAS*1*42 - add RXCP testing to Expired tag
  1. ;
  1. ;
  1. DELMT ; send delete mt transaction if pt no longer meets IVM criteria
  1. ;
  1. ; Input - DFN
  1. ; IVMMTDT - date of means test
  1. ;
  1. N I,IVMIY,X
  1. S IVMIY=$$LYR^DGMTSCU1(IVMMTDT)
  1. F I=1:1:5,8:1:14 S $P(X,HLFS,I)=HLQ
  1. S ^TMP("HLS",$J,HLSDT,IVMCT)="ZMT"_HLFS_X
  1. D CLOSE(IVMIY,DFN,2,3) ; set flag to stop future transmissions
  1. Q
  1. ;
  1. ;
  1. CLOSE(IVMIY,DFN,IVMCS,IVMCR) ; Close IVM case record for a patient
  1. ; Input: DFN -- Pointer to the patient in file #2
  1. ; IVMIY -- Income year of the closed case
  1. ; IVMCS -- Closure source [1=IVM | 2=DHCP]
  1. ; IVMCR -- Pointer to the closure reason in file #301.93
  1. ;
  1. N DA,DIE,DR,X,Y,EVENTS,STATUS,EAEVENT,IVEVENT
  1. I '$G(IVMIY)!'$G(DFN)!'$G(IVMCS)!'$G(IVMCR) G CLOSEQ
  1. S IVMDELMT=1 ; flag indicates deletion
  1. S DA=$O(^IVM(301.5,"APT",+DFN,+IVMIY,0))
  1. I $G(^IVM(301.5,+DA,0))']"" G CLOSEQ
  1. ;
  1. ;don't want closing a case to stop transmission of an enrollment event
  1. S STATUS=1
  1. I ($$STATUS^IVMPLOG(+DA,.EVENTS)=0),EVENTS("ENROLL")=1 S STATUS=0
  1. ;
  1. ; If previous years event make sure Enrollment Event does not get
  1. ; updated, and the IVM Event does
  1. ;
  1. S EAEVENT=1,IVEVENT=2
  1. I $G(EXPIRED)=1 S EAEVENT=2,STATUS=0,IVEVENT=1
  1. I $G(EXPIRED)=0 S EAEVENT=1,STATUS=0
  1. D NOW^%DTC S DR=".03////"_STATUS_";.04////1;1.01////"_IVMCR_";1.02////"_IVMCS_";1.03////"_%_";30.01////"_IVEVENT_";30.02////2;30.03////"_$G(EAEVENT)
  1. S DIE="^IVM(301.5," D ^DIE
  1. CLOSEQ Q
  1. ;
  1. ;
  1. PSEUDO ; strip P from pseudo SSNs before transmitting to IVM
  1. ;
  1. N X
  1. S X=IVMPID_$G(IVMPID(1))
  1. S $P(X,HLFS,20)=$E($P(X,HLFS,20),1,9) ; remove P
  1. K IVMPID S IVMPID=$E(X,1,245)
  1. I $L(X)>245 S IVMPID(1)=$E(X,246,999)
  1. Q
  1. ;
  1. ;Check if EDB Z06 in Annual Means Test file #408.31
  1. ; 'Z06 MT via Edb' will be stored in Comments if EDB Z06 Means Test
  1. ;
  1. Z06MT(IVMMTIEN,Z06COM) N FLAG,LINE,COMMENT
  1. I '$G(IVMMTIEN) Q 0
  1. I $G(Z06COM)="" S Z06COM="Z06 MT via Edb"
  1. S (FLAG,LINE)=0
  1. F S LINE=$O(^DGMT(408.31,IVMMTIEN,"C",LINE)) Q:'LINE!(FLAG) D
  1. . S COMMENT=$G(^DGMT(408.31,IVMMTIEN,"C",LINE,0))
  1. . I COMMENT=Z06COM S FLAG=1 Q
  1. Q FLAG
  1. ;
  1. ;Retrieve Means Test information from incoming HL7 message.
  1. ;
  1. CHECKMT(DFN) N SOURCE,IVMLAST,IVMMTDT,IVMMTIEN
  1. I IVMTYPE'=1 Q ;Only want MT = 1
  1. S SOURCE=$P($G(^TMP($J,"IVMCM","ZMT1")),HLFS,22)
  1. S IVMMTDT=$$FMDATE^HLFNC($P($G(^TMP($J,"IVMCM","ZMT1")),HLFS,2))
  1. S IVMLAST=$$LST^DGMTU(DFN,$E(IVMMTDT,1,3)_1231,1)
  1. S IVMMTIEN=+IVMLAST
  1. Q $$Z06MT(IVMMTIEN)
  1. ;
  1. ;Based upon DFN and MT Date find primary MT
  1. ;
  1. VERZ06(DFN) N CMT,CMTDATE,MTIEN,PRIM
  1. S CMT=$$LST^DGMTU(DFN)
  1. S MTIEN=+CMT,CMTDATE=$P(CMT,"^",2)
  1. I 'MTIEN Q 0 ;No Means Test found
  1. S PRIM=$G(^DGMT(408.31,MTIEN,"PRIM"))
  1. I PRIM,$$Z06MT(MTIEN) Q 1
  1. Q 0
  1. ;
  1. ;Check for expired MT or CT ;EAS*1*42
  1. ;
  1. EXPIRED(DFN,DGMTDT) N CMT,PMT,CCT,PCT
  1. S (CMT,PMT,CCT,PCT)=""
  1. S:DGMTYPT=2 PCT=$$LST^DGMTU(DFN,DGMTDT,2) ;Retrieve previous CT
  1. S PMT=$$LST^DGMTU(DFN,DGMTDT,1) ;Retrieve previous MT
  1. I PCT="",PMT="" Q 0
  1. S:DGMTYPT=2 CCT=$$LST^DGMTU(DFN,DT,2) ;Retrieve current CT
  1. S CMT=$$LST^DGMTU(DFN,DT,1) ;Retrieve current MT
  1. ;check for any expired test
  1. I DGMTYPT=2,$P(PCT,"^",2)<$P(CCT,"^",2) Q 1 ;Prev Yr CT is Expired
  1. I $P(PMT,"^",2)<$P(CMT,"^",2) Q 1 ;Prev Yr MT is Expired
  1. Q 0
  1. ;
  1. ;Determine if Z09 should be sent to EDB or HEC legacy ;EAS*1*47
  1. ; Input: DFN
  1. ; Output: Where to Send Z09
  1. ; 0 - HEC Legacy
  1. ; 1 - EDB
  1. ;
  1. WHERETO(ICYR,DFN) N COM,DATE,FOUND,FRMDATE,IEN,MIEN,ONODE,MTD,TYPE,Z06COM
  1. S FOUND=0
  1. S Z06COM="Z06 MT via Edb"
  1. S IEN=$O(^IVM(301.61,"ATR",ICYR,DFN,0)) I IEN="" Q FOUND
  1. S FRMDATE=$P($G(^IVM(301.61,IEN,0)),"^",5) I FRMDATE="" Q FOUND
  1. S TYPE=""
  1. F S TYPE=$O(^DGMT(408.31,"AID",TYPE)) Q:TYPE=""!(FOUND) D
  1. .S MTD=""
  1. .F S MTD=$O(^DGMT(408.31,"AID",TYPE,DFN,MTD)) Q:MTD=""!(FOUND) D
  1. ..S MIEN=""
  1. ..F S MIEN=$O(^DGMT(408.31,"AID",TYPE,DFN,MTD,MIEN)) Q:MIEN=""!(FOUND) D
  1. ...S ONODE=$G(^DGMT(408.31,MIEN,0))
  1. ...S DATE=$P(ONODE,"^",25) ;Use IVM Verified Date
  1. ...I DATE="" S DATE=$P(ONODE,"^",7) ;Use Completed Date
  1. ...S COM=$G(^DGMT(408.31,MIEN,"C",1,0)) ;Comment
  1. ...I DATE'="",COM[Z06COM,FRMDATE>(DATE-1),$G(^DGMT(408.31,MIEN,"PRIM")) S FOUND=1
  1. Q FOUND