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