EASPREC6 ;ALB/BD,MNH,LMD - ROUTINE TO PROCESS INCOMING (Z06 EVENT TYPE) HL7 MESSAGES ;6/16/04 9:28am
;;1.0;ENROLLMENT APPLICATION SYSTEM;**111,113**;21-OCT-94;Build 53
;;Per VA Directive 6402, this routine should not be modified.
;
;** Warning ** currently only one ZMT seg per Z06 can be processed.
;
;EAS*1*113 Send Bulletin if BTFI is different than what is on file
; - added DGMTYPT and passed down thru all calls that need.
; o DGMTYPT = 1 (Means Test, MT)
; o DGMTYPT = 2 (RX Copay Test, CT)
;
; This routine will process (validate) batch ORU Means Test(event type
; Z06) HL7 messages received from the IVM center. Format of batch:
; BHS
; {MSH
; PID
; ZIC
; ZIR
; {ZDP
; ZIC
; ZIR
; }
; ZMT
; ZIV
; }
; BTS
;
EN ; entry point to validate Means Test messages
;
N DEPFLG,EDB,CANCFLG,CASEFLG,SEGSTR,SEGMENTS,MISSING,ERRFLG,Z06COM
N IVM2,IVM3,IVM7,IVM8,IVM10,IVM12,IVM17,IVM18,IVM20,IVM25,IVM26,IVM32,IVMIY ;Add BT indicator EAS*1*113
N IVMDA,IVMPAT,IVMMTSTS,MTFND,UPMTS,MTDATE,TYPE,EASMTDT,EASZ06,EXPIRED
N IVM5,EASZ06D,DGMTYPT
S SEGSTR="00000000000" ;One byte for each segment in message
S SEGMENTS="BHS,MSH,PID,PID,ZIC,ZIR,ZDP,ZIC,ZIR,ZMT,ZIV,BTS"
S Z06COM="Z06 MT via Edb"
S (CASEFLG,DEPFLG,ERRFLG,HLERR,IVMDA,IVMFLGC,MTFND,UPMTS)=0
EN1 F S IVMDA=$O(^TMP($J,IVMRTN,IVMDA)) Q:'IVMDA D I $D(HLERR) D ACK^IVMPREC S ERRFLG=1 Q
.K HLERR
.D GET
.D @IVMSEG1 ;process each segment type
Q:ERRFLG ;Error detected do not continue
S MISSING=$F(SEGSTR,0) ;Ensure all required segments
I MISSING D I $D(HLERR) D ACK^IVMPREC,CLEANUP Q
. S TYPE=$S(MISSING=3!(MISSING=4):"Veteran's",MISSING>4&(MISSING<8):"Spouse's",1:"")
. S HLERR="Missing "_TYPE_" "_$P(SEGMENTS,",",(MISSING-1))_" Segment"
D PROCESS
I $D(HLERR) D ACK^IVMPREC
; cleanup
CLEANUP K DGLY,DGMTP,IVMDAP,IVMDAS,IVMDAZ,IVMDGLY,CANCFLG,IVMFLGC,IVMMT31
K IVMMTDT,IVMMTIEN,IVMSEG,IVMSEG1,IVMSTAT,IVMTEXT,XMSUB,HLERR,CLOSFLG
K IVMZ10,IVMDAV,ZIVSEG,ZMTSEG
Q
;
;Dependent upon type of Z06 sent perform the following;
;IVM Case Status:
; Value of 1 = Create/Update Z06 MT/CT, Close Case & Mark REASON CODE
; as 'Converted'
; Value of 0 = Cancel Z06 MT/CT and Mark REASON CODE as 'Not Convert'
;
; If Z06 MT/CT and IVM Case Status is 1 and Z06 MT/CT doesn't exist then
; Create new Z06 MT/CT (new Z06 MT/CT becomes primary and existing
; MT/CT becomes non-primary)
; Assign REASON CODE of 'Converted' in #301.5
; If Z06 MT/CT already exists then
; If IVM Case Status is 0 Then
; Delete Z06 MT/CT for income year and return old MT/CT to primary
; Change REASON CODE from 'Converted' to 'Not Converted' in #301.5
; If IVM Case Status is 1 Then
; Update MT/CT Z06 and Close/Convert Case
; Else (Z06 MT/CT, IVM Case Status=0 and Z06 MT/CT does not exist)
; Send back 'AE' to Edb indicating MT/CT Z06 not available for
; cancellation
;
PROCESS N DIC,%,%H,%I,IVMDATE
D NOW^%DTC
S IVMDATE=%
I '$D(ZMTSEG) S HLERR="ZMT Segment is Missing" Q
S EASZ06=1,EXPIRED=0
S:DGMTYPT=2 IVMCEB=$P($$RXST^IBARXEU(DFN),"^",2) ;prev RX sts
I $G(IVMMTIEN)="" D ; Find any primary for the same year/test type
. S CURMT=$$LST^DGMTU(DFN,IVMMTDT,DGMTYPT)
. I $E($P(CURMT,U,2),1,3)'=$E(IVMMTDT,1,3) Q ;TMK
. S IVMMTIEN=$P(CURMT,"^",1)
. S IVMMTDT=$P(CURMT,"^",2)
. S IVMMTSTS=$P(CURMT,"^",3)
I $G(IVMMTIEN)]"" D ;dgmtp is event driver variable
. S (IVMMT31,DGMTP)=$G(^DGMT(408.31,IVMMTIEN,0))
;
; EAS*1*113
; Send BT Bulletin if BTFI is different than what is on file
;
; Input:
; DFN = IEN of Patient
N DT,DGCAT,FININD
; DFN = IEN of Patient
; DT = Today's Date
S DT=IVMDATE
; DGCAT = Current Means Test Status
S DGCAT=$P($G(^DG(408.32,IVM3,0)),"^",1)
; IVMCEB = Previous Means Test Status
; IVM10 = Date/Time Test Completed
S FININD="" I $D(IVMMTIEN) S FININD=$G(^DGMT(408.31,IVMMTIEN,4)) ;financial indicator EAS*1*113
;
I IVM32'=FININD D SET^EASBTBUL(DFN,DT,DGCAT,$G(IVMCEB),$G(IVM10))
;
;
; No previous 408.31 test on file
I 'MTFND D Q
. I CASEFLG D ;Case=1 Close/Converted
. . ;change old MT/CT to non-primary
. . I $G(IVMMTIEN)>0 D
. . . S DA=IVMMTIEN,DIE="^DGMT(408.31,",DR="2////0;"
. . . D ^DIE K DA,DIE,DR
. . ;
. . S IVMMTDT=EASMTDT
. . D ^EASUM6 ;Copied from EASUM1 Create New Z06 MT/CT
. . I $G(IVMMTDT)="" S IVMMTDT=EASMTDT
. . I $$EXPIRED^EASPTRN1(DFN,$G(IVMMTDT)) D
. . . S EXPIRED=1,IVMZ10="UPLOAD IN PROGRESS"
. . D CLOSE(IVMIY,DFN,1,6) ;Close Case/Converted
. ;
. I 'CASEFLG D Q
. . S:DGMTYPT=1 HLERR="Existing Z06 MT not found"
. . S:DGMTYPT=2 HLERR="Existing Z06 CT not found"
;
; Previous 408.31 test on file
I MTFND D
. I 'CASEFLG D ;Case=0 Close/Not Convert
. . ; Check to see if MT/CT Z06 exists prior to trying to delete
. . ; If NOT defined then send an AE back to Edb
. . I 'UPMTS D Q ;Existing Z06 not found
. . . S:DGMTYPT=1 HLERR="Existing Z06 MT not found"
. . . S:DGMTYPT=2 HLERR="Existing Z06 CT not found"
. . I UPMTS D Q
. . . N CURMT,IVMMTI,IVMDFN,DGCAT
. . . S IVMDFN=DFN ;Save off DFN
. . . I $$EXPIRED^EASPTRN1(DFN,$G(IVMMTDT)) D
. . . . S EXPIRED=1,IVMZ10="UPLOAD IN PROGRESS"
. . . S DGCAT=$P($G(^DG(408.32,IVM3,0)),"^",1),IVM5=""
. . . S EASZ06D=1 ;Set del flag for IB event
. . . D ^EASUM9 ;Delete Z06 MT/CT
. . . S DFN=IVMDFN
. . . I $G(IVMMTDT)="" S IVMMTDT=EASMTDT
. . . D CLOSE(IVMIY,DFN,1,7) ;Close Case/Not Converted
. ;
. I CASEFLG D ;Case=1 Close/Converted
. . Q:$G(IVMMTIEN)<1
. . S DA=IVMMTIEN,DIE="^DGMT(408.31,"
. . S DR=".03////^S X=IVM3;.12////^S X=IVM8;.07////^S X=IVM10;"
. . S DR=DR_".09////^S X=IVM25;.11////^S X=IVM7;.18////^S X=IVM12;"
. . S DR=DR_".23////^S X=IVM18;.25////^S X=IVM20;"
. . S DR=DR_"2.02////^S X=IVMDATE;2.03////^S X=IVM26;"
. . S DR=DR_"4////^S X=IVM32;" ;BT Financial Indicator EAS*1*113
. . D ^DIE K DA,DIE,DR ;Update existing Z06
. . I $G(IVMMTDT)="" S IVMMTDT=EASMTDT
. . I $$EXPIRED^EASPTRN1(DFN,$G(IVMMTDT)) D
. . . S EXPIRED=1,IVMZ10="UPLOAD IN PROGRESS"
. . D CLOSE(IVMIY,DFN,1,6) ;Close Case/Converted
. . S DGCAT=$P($G(^DG(408.32,IVM3,0)),"^",1),IVM5=""
. . D MTBULL^EASUM9,MAIL^IVMUFNC() ;Send Bulletin
Q
;
MSH S (HLMID,MSGID)=$P(IVMSEG,HLFS,10) ;Message control id from MSH
Q
PID ;Handle wrapped PID segment
N I,IVMPID,PIDSTR,COMP,CNTR,NOPID,TMPARY,PID3ARY,CNTR2
S CNTR=1,NOPID=0,PIDSTR(CNTR)=$P(IVMSEG,"^",2,999)
F D Q:NOPID
.S IVMDA=$O(^TMP($J,IVMRTN,IVMDA)),IVMSEG=$G(^(+IVMDA,0))
.I $E(IVMSEG,1,4)="ZIC^" S NOPID=1,IVMDA=IVMDA-1 Q
.S CNTR=CNTR+1,PIDSTR(CNTR)=IVMSEG
.S SEGSTR=$E(SEGSTR,1,IVMDA-1)_"1"_$E(SEGSTR,IVMDA,$L(SEGSTR)) ;Extend SEGSTR for wrapped PID
D BLDPID^IVMPREC6(.PIDSTR,.IVMPID) ;Create IVMPID subscripted by seq #
;convert "" to null for PID segment
S CNTR="" F S CNTR=$O(IVMPID(CNTR)) Q:CNTR="" D
.I $O(IVMPID(CNTR,"")) D Q
..S CNTR2="" F S CNTR2=$O(IVMPID(CNTR,CNTR2)) Q:CNTR2="" D
...S IVMPID(CNTR,CNTR2)=$$CLEARF^IVMPRECA(IVMPID(CNTR,CNTR2),$E(HLECH))
.I IVMPID(CNTR)=HLQ S IVMPID(CNTR)=""
M TMPARY(3)=IVMPID(3) D PARSPID3^IVMUFNC(.TMPARY,.PID3ARY)
S DFN=$G(PID3ARY("PI")),ICN=$G(PID3ARY("NI"))
K TMPARY,PID3ARY
I '$$MATCH^IVMUFNC(DFN,ICN,"","","I",.ERRMSG) S HLERR=ERRMSG Q
S IVMDAP=IVMDA ;Save IVMDA for veteran PID segment
Q
ZIC I 'DEPFLG S IVMDGLY=$P(IVMSEG,"^",3) ;Income year
Q
ZIR Q
ZDP S DEPFLG=1
Q
;Get primary means test
; IVMMTDT - means test date
; DGLY - income year
; If Means Test not in DHCP, don't upload IVM Means Test
;
ZMT N IVMIEN,MTCODE ;EAS*1*42
S IVMDAZ=IVMDA,ZMTSEG=IVMSEG ;ZMT segment ivmda
D PARSEZMT(ZMTSEG) ;Retrieve ZMT Values
;Means test date from ZMT segment
S (EASMTDT,IVMMTDT)=$$FMDATE^HLFNC($P(IVMSEG,HLFS,3))
S DGMTYPT=$G(IVM17) ;int type of test
S:DGMTYPT="" DGMTYPT=1 ;insure type defined
S DGLY=$$LYR^DGMTSCU1(IVMMTDT) ;Get means test to be updated
S MTDATE=-IVMMTDT
S IVMIEN=""
S MTFND=0
F S IVMIEN=$O(^DGMT(408.31,"AID",DGMTYPT,DFN,MTDATE,IVMIEN)) Q:MTFND!(IVMIEN="") D
. S IVMMTIEN=IVMIEN
. ; match to MT Z06 from Edb
. S MTCODE=$P($G(^DGMT(408.31,IVMIEN,0)),"^",3)
. I (MTCODE=6)!(MTCODE=16)!(MTCODE=8) D ;Previous Converted MT/CT - EAS*1.0*111
. . S UPMTS=IVMIEN
. . S MTFND=1
I IVM7="" S (UPMTS,MTFND)=1 ;- EAS*1.0*111 need override for reversal.
Q
ZIV S IVMDAV=IVMDA,ZIVSEG=IVMSEG
S IVMIY=$P(IVMSEG,HLFS,3)
S IVMIY=$$FMDATE^HLFNC(IVMIY)
I $E(IVMIY,4,7)'="0000"!($E(IVMIY,1,3)<292) D Q
. S HLERR="Invalid Income Year"
I "01"'[$P(IVMSEG,HLFS,9) D Q
. S HLERR="Case Status not 0 or 1"
I $P(IVMSEG,HLFS,9)=1 S CASEFLG=1 ;Close/Convert Case Flag
I $P(IVMSEG,HLFS,9)=0 S CASEFLG=0 ;Delete/Not Converted MT Flag
BHS Q
BTS Q
;
GET ; get HL7 segment from ^TMP
;S IVMDA=$O(^TMP($J,IVMRTN,+IVMDA))
S IVMSEG=$G(^TMP($J,IVMRTN,+IVMDA,0))
S IVMSEG1=$E(IVMSEG,1,3)
S $E(SEGSTR,IVMDA)=1
Q
;
;Parse ZMT Segment for MT Data
;
PARSEZMT(ZSEG) ;
N CMPDATE
S IVM2=$$FMDATE^HLFNC($P(ZSEG,"^",3)) ;Means Test Date
S IVM3=$O(^DG(408.32,"C",$P(ZSEG,"^",4),"")) ;Means Test Status
;S IVM7=$S($P(ZSEG,"^",8)="Y":1,$P(ZSEG,"^",8)=1:1,$P(ZSEG,"^",8)="":"",1:0) ;Agrees To Deductible
S IVM7=$S($P(ZSEG,"^",8)]"Yy":1,$P(ZSEG,"^",8)=1:1,$P(ZSEG,"^",8)="":"",1:0) ;Agrees To Deductible
S IVM8=$P(ZSEG,"^",9) ;Threshold A
S CMPDATE=$P(ZSEG,"^",11) S:$E($G(CMPDATE),9,14)="000000" CMPDATE=$E(CMPDATE,1,8) S:+CMPDATE=0 CMPDATE="" S IVM10=$$FMDATE^HLFNC(CMPDATE) ;Date/Time Completed
S IVM12=$P(ZSEG,"^",13) ;Number of Dependents
S IVM17=$P(ZSEG,"^",18) ;Type of Test
S IVM18=$P(ZSEG,"^",19) ;Source of Test
S IVM20=$$FMDATE^HLFNC($P(ZSEG,"^",21)) ;IVM Verified MT
S IVM25=$$FMDATE^HLFNC($P(ZSEG,"^",26)) ;D/T Last Changed
S IVM26=$O(^DG(408.32,"C",$P(ZSEG,"^",27),"")) ;Test Determined Status
S IVM32=$P(ZSEG,"^",32) ;EAS*1*113
;S IVM32=$S(IVM32="Y":1,IVM32="N":0,1:IVM32) ;BT Financial Indicator EAS*1*113
S IVM32=$S(IVM32["""":"",1:IVM32) ;BT Financial Indicator
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////2;30.02////2"
S DIE="^IVM(301.5," D ^DIE
CLOSEQ Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HEASPREC6 11376 printed Sep 23, 2025@19:31:44 Page 2
EASPREC6 ;ALB/BD,MNH,LMD - ROUTINE TO PROCESS INCOMING (Z06 EVENT TYPE) HL7 MESSAGES ;6/16/04 9:28am
+1 ;;1.0;ENROLLMENT APPLICATION SYSTEM;**111,113**;21-OCT-94;Build 53
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;** Warning ** currently only one ZMT seg per Z06 can be processed.
+5 ;
+6 ;EAS*1*113 Send Bulletin if BTFI is different than what is on file
+7 ; - added DGMTYPT and passed down thru all calls that need.
+8 ; o DGMTYPT = 1 (Means Test, MT)
+9 ; o DGMTYPT = 2 (RX Copay Test, CT)
+10 ;
+11 ; This routine will process (validate) batch ORU Means Test(event type
+12 ; Z06) HL7 messages received from the IVM center. Format of batch:
+13 ; BHS
+14 ; {MSH
+15 ; PID
+16 ; ZIC
+17 ; ZIR
+18 ; {ZDP
+19 ; ZIC
+20 ; ZIR
+21 ; }
+22 ; ZMT
+23 ; ZIV
+24 ; }
+25 ; BTS
+26 ;
EN ; entry point to validate Means Test messages
+1 ;
+2 NEW DEPFLG,EDB,CANCFLG,CASEFLG,SEGSTR,SEGMENTS,MISSING,ERRFLG,Z06COM
+3 ;Add BT indicator EAS*1*113
NEW IVM2,IVM3,IVM7,IVM8,IVM10,IVM12,IVM17,IVM18,IVM20,IVM25,IVM26,IVM32,IVMIY
+4 NEW IVMDA,IVMPAT,IVMMTSTS,MTFND,UPMTS,MTDATE,TYPE,EASMTDT,EASZ06,EXPIRED
+5 NEW IVM5,EASZ06D,DGMTYPT
+6 ;One byte for each segment in message
SET SEGSTR="00000000000"
+7 SET SEGMENTS="BHS,MSH,PID,PID,ZIC,ZIR,ZDP,ZIC,ZIR,ZMT,ZIV,BTS"
+8 SET Z06COM="Z06 MT via Edb"
+9 SET (CASEFLG,DEPFLG,ERRFLG,HLERR,IVMDA,IVMFLGC,MTFND,UPMTS)=0
EN1 FOR
SET IVMDA=$ORDER(^TMP($JOB,IVMRTN,IVMDA))
if 'IVMDA
QUIT
Begin DoDot:1
+1 KILL HLERR
+2 DO GET
+3 ;process each segment type
DO @IVMSEG1
End DoDot:1
IF $DATA(HLERR)
DO ACK^IVMPREC
SET ERRFLG=1
QUIT
+4 ;Error detected do not continue
if ERRFLG
QUIT
+5 ;Ensure all required segments
SET MISSING=$FIND(SEGSTR,0)
+6 IF MISSING
Begin DoDot:1
+7 SET TYPE=$SELECT(MISSING=3!(MISSING=4):"Veteran's",MISSING>4&(MISSING<8):"Spouse's",1:"")
+8 SET HLERR="Missing "_TYPE_" "_$PIECE(SEGMENTS,",",(MISSING-1))_" Segment"
End DoDot:1
IF $DATA(HLERR)
DO ACK^IVMPREC
DO CLEANUP
QUIT
+9 DO PROCESS
+10 IF $DATA(HLERR)
DO ACK^IVMPREC
+11 ; cleanup
CLEANUP KILL DGLY,DGMTP,IVMDAP,IVMDAS,IVMDAZ,IVMDGLY,CANCFLG,IVMFLGC,IVMMT31
+1 KILL IVMMTDT,IVMMTIEN,IVMSEG,IVMSEG1,IVMSTAT,IVMTEXT,XMSUB,HLERR,CLOSFLG
+2 KILL IVMZ10,IVMDAV,ZIVSEG,ZMTSEG
+3 QUIT
+4 ;
+5 ;Dependent upon type of Z06 sent perform the following;
+6 ;IVM Case Status:
+7 ; Value of 1 = Create/Update Z06 MT/CT, Close Case & Mark REASON CODE
+8 ; as 'Converted'
+9 ; Value of 0 = Cancel Z06 MT/CT and Mark REASON CODE as 'Not Convert'
+10 ;
+11 ; If Z06 MT/CT and IVM Case Status is 1 and Z06 MT/CT doesn't exist then
+12 ; Create new Z06 MT/CT (new Z06 MT/CT becomes primary and existing
+13 ; MT/CT becomes non-primary)
+14 ; Assign REASON CODE of 'Converted' in #301.5
+15 ; If Z06 MT/CT already exists then
+16 ; If IVM Case Status is 0 Then
+17 ; Delete Z06 MT/CT for income year and return old MT/CT to primary
+18 ; Change REASON CODE from 'Converted' to 'Not Converted' in #301.5
+19 ; If IVM Case Status is 1 Then
+20 ; Update MT/CT Z06 and Close/Convert Case
+21 ; Else (Z06 MT/CT, IVM Case Status=0 and Z06 MT/CT does not exist)
+22 ; Send back 'AE' to Edb indicating MT/CT Z06 not available for
+23 ; cancellation
+24 ;
PROCESS NEW DIC,%,%H,%I,IVMDATE
+1 DO NOW^%DTC
+2 SET IVMDATE=%
+3 IF '$DATA(ZMTSEG)
SET HLERR="ZMT Segment is Missing"
QUIT
+4 SET EASZ06=1
SET EXPIRED=0
+5 ;prev RX sts
if DGMTYPT=2
SET IVMCEB=$PIECE($$RXST^IBARXEU(DFN),"^",2)
+6 ; Find any primary for the same year/test type
IF $GET(IVMMTIEN)=""
Begin DoDot:1
+7 SET CURMT=$$LST^DGMTU(DFN,IVMMTDT,DGMTYPT)
+8 ;TMK
IF $EXTRACT($PIECE(CURMT,U,2),1,3)'=$EXTRACT(IVMMTDT,1,3)
QUIT
+9 SET IVMMTIEN=$PIECE(CURMT,"^",1)
+10 SET IVMMTDT=$PIECE(CURMT,"^",2)
+11 SET IVMMTSTS=$PIECE(CURMT,"^",3)
End DoDot:1
+12 ;dgmtp is event driver variable
IF $GET(IVMMTIEN)]""
Begin DoDot:1
+13 SET (IVMMT31,DGMTP)=$GET(^DGMT(408.31,IVMMTIEN,0))
End DoDot:1
+14 ;
+15 ; EAS*1*113
+16 ; Send BT Bulletin if BTFI is different than what is on file
+17 ;
+18 ; Input:
+19 ; DFN = IEN of Patient
+20 NEW DT,DGCAT,FININD
+21 ; DFN = IEN of Patient
+22 ; DT = Today's Date
+23 SET DT=IVMDATE
+24 ; DGCAT = Current Means Test Status
+25 SET DGCAT=$PIECE($GET(^DG(408.32,IVM3,0)),"^",1)
+26 ; IVMCEB = Previous Means Test Status
+27 ; IVM10 = Date/Time Test Completed
+28 ;financial indicator EAS*1*113
SET FININD=""
IF $DATA(IVMMTIEN)
SET FININD=$GET(^DGMT(408.31,IVMMTIEN,4))
+29 ;
+30 IF IVM32'=FININD
DO SET^EASBTBUL(DFN,DT,DGCAT,$GET(IVMCEB),$GET(IVM10))
+31 ;
+32 ;
+33 ; No previous 408.31 test on file
+34 IF 'MTFND
Begin DoDot:1
+35 ;Case=1 Close/Converted
IF CASEFLG
Begin DoDot:2
+36 ;change old MT/CT to non-primary
+37 IF $GET(IVMMTIEN)>0
Begin DoDot:3
+38 SET DA=IVMMTIEN
SET DIE="^DGMT(408.31,"
SET DR="2////0;"
+39 DO ^DIE
KILL DA,DIE,DR
End DoDot:3
+40 ;
+41 SET IVMMTDT=EASMTDT
+42 ;Copied from EASUM1 Create New Z06 MT/CT
DO ^EASUM6
+43 IF $GET(IVMMTDT)=""
SET IVMMTDT=EASMTDT
+44 IF $$EXPIRED^EASPTRN1(DFN,$GET(IVMMTDT))
Begin DoDot:3
+45 SET EXPIRED=1
SET IVMZ10="UPLOAD IN PROGRESS"
End DoDot:3
+46 ;Close Case/Converted
DO CLOSE(IVMIY,DFN,1,6)
End DoDot:2
+47 ;
+48 IF 'CASEFLG
Begin DoDot:2
+49 if DGMTYPT=1
SET HLERR="Existing Z06 MT not found"
+50 if DGMTYPT=2
SET HLERR="Existing Z06 CT not found"
End DoDot:2
QUIT
End DoDot:1
QUIT
+51 ;
+52 ; Previous 408.31 test on file
+53 IF MTFND
Begin DoDot:1
+54 ;Case=0 Close/Not Convert
IF 'CASEFLG
Begin DoDot:2
+55 ; Check to see if MT/CT Z06 exists prior to trying to delete
+56 ; If NOT defined then send an AE back to Edb
+57 ;Existing Z06 not found
IF 'UPMTS
Begin DoDot:3
+58 if DGMTYPT=1
SET HLERR="Existing Z06 MT not found"
+59 if DGMTYPT=2
SET HLERR="Existing Z06 CT not found"
End DoDot:3
QUIT
+60 IF UPMTS
Begin DoDot:3
+61 NEW CURMT,IVMMTI,IVMDFN,DGCAT
+62 ;Save off DFN
SET IVMDFN=DFN
+63 IF $$EXPIRED^EASPTRN1(DFN,$GET(IVMMTDT))
Begin DoDot:4
+64 SET EXPIRED=1
SET IVMZ10="UPLOAD IN PROGRESS"
End DoDot:4
+65 SET DGCAT=$PIECE($GET(^DG(408.32,IVM3,0)),"^",1)
SET IVM5=""
+66 ;Set del flag for IB event
SET EASZ06D=1
+67 ;Delete Z06 MT/CT
DO ^EASUM9
+68 SET DFN=IVMDFN
+69 IF $GET(IVMMTDT)=""
SET IVMMTDT=EASMTDT
+70 ;Close Case/Not Converted
DO CLOSE(IVMIY,DFN,1,7)
End DoDot:3
QUIT
End DoDot:2
+71 ;
+72 ;Case=1 Close/Converted
IF CASEFLG
Begin DoDot:2
+73 if $GET(IVMMTIEN)<1
QUIT
+74 SET DA=IVMMTIEN
SET DIE="^DGMT(408.31,"
+75 SET DR=".03////^S X=IVM3;.12////^S X=IVM8;.07////^S X=IVM10;"
+76 SET DR=DR_".09////^S X=IVM25;.11////^S X=IVM7;.18////^S X=IVM12;"
+77 SET DR=DR_".23////^S X=IVM18;.25////^S X=IVM20;"
+78 SET DR=DR_"2.02////^S X=IVMDATE;2.03////^S X=IVM26;"
+79 ;BT Financial Indicator EAS*1*113
SET DR=DR_"4////^S X=IVM32;"
+80 ;Update existing Z06
DO ^DIE
KILL DA,DIE,DR
+81 IF $GET(IVMMTDT)=""
SET IVMMTDT=EASMTDT
+82 IF $$EXPIRED^EASPTRN1(DFN,$GET(IVMMTDT))
Begin DoDot:3
+83 SET EXPIRED=1
SET IVMZ10="UPLOAD IN PROGRESS"
End DoDot:3
+84 ;Close Case/Converted
DO CLOSE(IVMIY,DFN,1,6)
+85 SET DGCAT=$PIECE($GET(^DG(408.32,IVM3,0)),"^",1)
SET IVM5=""
+86 ;Send Bulletin
DO MTBULL^EASUM9
DO MAIL^IVMUFNC()
End DoDot:2
End DoDot:1
+87 QUIT
+88 ;
MSH ;Message control id from MSH
SET (HLMID,MSGID)=$PIECE(IVMSEG,HLFS,10)
+1 QUIT
PID ;Handle wrapped PID segment
+1 NEW I,IVMPID,PIDSTR,COMP,CNTR,NOPID,TMPARY,PID3ARY,CNTR2
+2 SET CNTR=1
SET NOPID=0
SET PIDSTR(CNTR)=$PIECE(IVMSEG,"^",2,999)
+3 FOR
Begin DoDot:1
+4 SET IVMDA=$ORDER(^TMP($JOB,IVMRTN,IVMDA))
SET IVMSEG=$GET(^(+IVMDA,0))
+5 IF $EXTRACT(IVMSEG,1,4)="ZIC^"
SET NOPID=1
SET IVMDA=IVMDA-1
QUIT
+6 SET CNTR=CNTR+1
SET PIDSTR(CNTR)=IVMSEG
+7 ;Extend SEGSTR for wrapped PID
SET SEGSTR=$EXTRACT(SEGSTR,1,IVMDA-1)_"1"_$EXTRACT(SEGSTR,IVMDA,$LENGTH(SEGSTR))
End DoDot:1
if NOPID
QUIT
+8 ;Create IVMPID subscripted by seq #
DO BLDPID^IVMPREC6(.PIDSTR,.IVMPID)
+9 ;convert "" to null for PID segment
+10 SET CNTR=""
FOR
SET CNTR=$ORDER(IVMPID(CNTR))
if CNTR=""
QUIT
Begin DoDot:1
+11 IF $ORDER(IVMPID(CNTR,""))
Begin DoDot:2
+12 SET CNTR2=""
FOR
SET CNTR2=$ORDER(IVMPID(CNTR,CNTR2))
if CNTR2=""
QUIT
Begin DoDot:3
+13 SET IVMPID(CNTR,CNTR2)=$$CLEARF^IVMPRECA(IVMPID(CNTR,CNTR2),$EXTRACT(HLECH))
End DoDot:3
End DoDot:2
QUIT
+14 IF IVMPID(CNTR)=HLQ
SET IVMPID(CNTR)=""
End DoDot:1
+15 MERGE TMPARY(3)=IVMPID(3)
DO PARSPID3^IVMUFNC(.TMPARY,.PID3ARY)
+16 SET DFN=$GET(PID3ARY("PI"))
SET ICN=$GET(PID3ARY("NI"))
+17 KILL TMPARY,PID3ARY
+18 IF '$$MATCH^IVMUFNC(DFN,ICN,"","","I",.ERRMSG)
SET HLERR=ERRMSG
QUIT
+19 ;Save IVMDA for veteran PID segment
SET IVMDAP=IVMDA
+20 QUIT
ZIC ;Income year
IF 'DEPFLG
SET IVMDGLY=$PIECE(IVMSEG,"^",3)
+1 QUIT
ZIR QUIT
ZDP SET DEPFLG=1
+1 QUIT
+2 ;Get primary means test
+3 ; IVMMTDT - means test date
+4 ; DGLY - income year
+5 ; If Means Test not in DHCP, don't upload IVM Means Test
+6 ;
ZMT ;EAS*1*42
NEW IVMIEN,MTCODE
+1 ;ZMT segment ivmda
SET IVMDAZ=IVMDA
SET ZMTSEG=IVMSEG
+2 ;Retrieve ZMT Values
DO PARSEZMT(ZMTSEG)
+3 ;Means test date from ZMT segment
+4 SET (EASMTDT,IVMMTDT)=$$FMDATE^HLFNC($PIECE(IVMSEG,HLFS,3))
+5 ;int type of test
SET DGMTYPT=$GET(IVM17)
+6 ;insure type defined
if DGMTYPT=""
SET DGMTYPT=1
+7 ;Get means test to be updated
SET DGLY=$$LYR^DGMTSCU1(IVMMTDT)
+8 SET MTDATE=-IVMMTDT
+9 SET IVMIEN=""
+10 SET MTFND=0
+11 FOR
SET IVMIEN=$ORDER(^DGMT(408.31,"AID",DGMTYPT,DFN,MTDATE,IVMIEN))
if MTFND!(IVMIEN="")
QUIT
Begin DoDot:1
+12 SET IVMMTIEN=IVMIEN
+13 ; match to MT Z06 from Edb
+14 SET MTCODE=$PIECE($GET(^DGMT(408.31,IVMIEN,0)),"^",3)
+15 ;Previous Converted MT/CT - EAS*1.0*111
IF (MTCODE=6)!(MTCODE=16)!(MTCODE=8)
Begin DoDot:2
+16 SET UPMTS=IVMIEN
+17 SET MTFND=1
End DoDot:2
End DoDot:1
+18 ;- EAS*1.0*111 need override for reversal.
IF IVM7=""
SET (UPMTS,MTFND)=1
+19 QUIT
ZIV SET IVMDAV=IVMDA
SET ZIVSEG=IVMSEG
+1 SET IVMIY=$PIECE(IVMSEG,HLFS,3)
+2 SET IVMIY=$$FMDATE^HLFNC(IVMIY)
+3 IF $EXTRACT(IVMIY,4,7)'="0000"!($EXTRACT(IVMIY,1,3)<292)
Begin DoDot:1
+4 SET HLERR="Invalid Income Year"
End DoDot:1
QUIT
+5 IF "01"'[$PIECE(IVMSEG,HLFS,9)
Begin DoDot:1
+6 SET HLERR="Case Status not 0 or 1"
End DoDot:1
QUIT
+7 ;Close/Convert Case Flag
IF $PIECE(IVMSEG,HLFS,9)=1
SET CASEFLG=1
+8 ;Delete/Not Converted MT Flag
IF $PIECE(IVMSEG,HLFS,9)=0
SET CASEFLG=0
BHS QUIT
BTS QUIT
+1 ;
GET ; get HL7 segment from ^TMP
+1 ;S IVMDA=$O(^TMP($J,IVMRTN,+IVMDA))
+2 SET IVMSEG=$GET(^TMP($JOB,IVMRTN,+IVMDA,0))
+3 SET IVMSEG1=$EXTRACT(IVMSEG,1,3)
+4 SET $EXTRACT(SEGSTR,IVMDA)=1
+5 QUIT
+6 ;
+7 ;Parse ZMT Segment for MT Data
+8 ;
PARSEZMT(ZSEG) ;
+1 NEW CMPDATE
+2 ;Means Test Date
SET IVM2=$$FMDATE^HLFNC($PIECE(ZSEG,"^",3))
+3 ;Means Test Status
SET IVM3=$ORDER(^DG(408.32,"C",$PIECE(ZSEG,"^",4),""))
+4 ;S IVM7=$S($P(ZSEG,"^",8)="Y":1,$P(ZSEG,"^",8)=1:1,$P(ZSEG,"^",8)="":"",1:0) ;Agrees To Deductible
+5 ;Agrees To Deductible
SET IVM7=$SELECT($PIECE(ZSEG,"^",8)]"Yy":1,$PIECE(ZSEG,"^",8)=1:1,$PIECE(ZSEG,"^",8)="":"",1:0)
+6 ;Threshold A
SET IVM8=$PIECE(ZSEG,"^",9)
+7 ;Date/Time Completed
SET CMPDATE=$PIECE(ZSEG,"^",11)
if $EXTRACT($GET(CMPDATE),9,14)="000000"
SET CMPDATE=$EXTRACT(CMPDATE,1,8)
if +CMPDATE=0
SET CMPDATE=""
SET IVM10=$$FMDATE^HLFNC(CMPDATE)
+8 ;Number of Dependents
SET IVM12=$PIECE(ZSEG,"^",13)
+9 ;Type of Test
SET IVM17=$PIECE(ZSEG,"^",18)
+10 ;Source of Test
SET IVM18=$PIECE(ZSEG,"^",19)
+11 ;IVM Verified MT
SET IVM20=$$FMDATE^HLFNC($PIECE(ZSEG,"^",21))
+12 ;D/T Last Changed
SET IVM25=$$FMDATE^HLFNC($PIECE(ZSEG,"^",26))
+13 ;Test Determined Status
SET IVM26=$ORDER(^DG(408.32,"C",$PIECE(ZSEG,"^",27),""))
+14 ;EAS*1*113
SET IVM32=$PIECE(ZSEG,"^",32)
+15 ;S IVM32=$S(IVM32="Y":1,IVM32="N":0,1:IVM32) ;BT Financial Indicator EAS*1*113
+16 ;BT Financial Indicator
SET IVM32=$SELECT(IVM32["""":"",1:IVM32)
+17 QUIT
+18 ;
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 ;S EAEVENT=1,IVEVENT=2
+20 ;I $G(EXPIRED)=1 S EAEVENT=2,STATUS=0,IVEVENT=1
+21 ;I $G(EXPIRED)=0 S EAEVENT=1,STATUS=0
+22 DO NOW^%DTC
SET DR=".03////"_STATUS_";.04////1;1.01////"_IVMCR_";1.02////"_IVMCS_";1.03////"_%_";30.01////2;30.02////2"
+23 SET DIE="^IVM(301.5,"
DO ^DIE
CLOSEQ QUIT
+1 ;
