IVMPTRN9 ;ALB/KCL,CN,BRM,TDM,EG,LBD,TGH,JAM,HM,KUM - HL7 FULL DATA TRANSMISSION (Z07) BUILDER (CONTINUED) ;12/7/12 2:56pm
;;2.0;INCOME VERIFICATION MATCH;**9,11,19,12,21,17,46,50,53,34,49,58,79,99,116,105,115,152,160,164,180,193,201**;21-OCT-94;Build 17
;Per VHA Directive 2004-038, this routine should not be modified.
;
;
GOTO ; place to break up the routine
;
; create (ZIO) Inpatient/Outpatient segment for veteran
S N101015=$G(^DPT(DFN,1010.15))
S ZIOSEG="ZIO^1^"_$$EN^IVMUFNC1(DFN,IVMMTDT,.IVMQUERY) ;seq 1-3
S ZIOSEG=ZIOSEG_"^"_$$LTD^IVMUFNC(DFN,.IVMQUERY) ;seq 4
S X=$P(N101015,"^",9),$P(ZIOSEG,U,6)=$S(X=0:"N",X=1:"Y",1:HLQ) ;Appt Request
S X=$P(N101015,"^",11),$P(ZIOSEG,U,7)=$S(X]"":$$HLDATE^HLFNC(X),1:HLQ) ;Appt Request Date
; jam ; IVM*2.0*180 - add seq 7, field 1010.1515 - Appt Request Change DT/TM
S X=$P(N101015,"^",15),$P(ZIOSEG,U,8)=$S(X]"":$$HLDATE^HLFNC(X,"TS"),1:HLQ)
S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=ZIOSEG
;
; create (NTE) Notes and Comments segment
D NTE^IVMUFNC4(DFN,.IVMNTE,IVMMTDT)
I '$D(IVMNTE) D
. S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)="NTE^1"
I $D(IVMNTE) D
. ; - get notes and comments
. F IVMSUB=0:0 S IVMSUB=$O(IVMNTE(IVMSUB)) Q:'IVMSUB D
. . S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=IVMNTE(IVMSUB)
;
; create (IN1) Insurance segment(s) for all active insurance
K ^TMP("VAFIN1",$J)
D EN^VAFHLIN1(DFN,"1,4,5,7,8,9,12,13,15,16,17,28,36")
F IVMSUB=0:0 S IVMSUB=$O(^TMP("VAFIN1",$J,IVMSUB)) Q:'IVMSUB D
. S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=^TMP("VAFIN1",$J,+IVMSUB,0)
;
;find if the deletion flags were set in the IVM Patient file, and if so, should the deletion indicators be sent?
F I="RX","MT","HARDSHIP","DATE OF TEST","LTC" S DELETE(I)=""
S IVMPIEN=$$FIND^IVMPLOG(DFN,($E(IVMMTDT,1,3)-1))
I IVMPIEN D
. S IVMPNODE=$G(^IVM(301.5,IVMPIEN,0))
. I $P(IVMPNODE,"^",8)!$P(IVMPNODE,"^",9)!$P(IVMPNODE,"^",10)!$P(IVMPNODE,"^",11) S DELETE("SET")=1
. ;was the MT deletion flag set, and if so verify that there is no completed MT
. I $P(IVMPNODE,"^",8),(TESTTYPE'=1)!(TESTCODE="")!("ACGP"'[TESTCODE) S DELETE("DATE OF TEST")=$P(IVMPNODE,"^",8),DELETE("MT")=1
. ;
. ;was the hardship deletion flag set, and if so verify that there is no completed hardship
. I $P(IVMPNODE,"^",10),'HARDSHIP D
. . S:('DELETE("DATE OF TEST")) DELETE("DATE OF TEST")=$P(IVMPNODE,"^",10)
. . S DELETE("HARDSHIP")=1
;
; create (ZMT) Means Test segment
;
S SEQS=$S(TESTTYPE=1:"1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,21,22,23,24,25,26,28,29,30,31,32",1:"1,17") ;IVM*2.0*160 IVM*2.0*193 added hardship expiration
S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^IVMCZMT(DFN,SEQS,IVMMTDT,1,1,.DELETE,1)
;
; create (ZMT) Rx-Copay Test segment
I IVMPIEN D
. ;was the RX deletion flag set, and if so verify that there is no completed test
. I $P(IVMPNODE,"^",9),(TESTTYPE'=2)!(TESTCODE="")!("EM"'[TESTCODE) S DELETE("DATE OF TEST")=$P(IVMPNODE,"^",9),DELETE("RX")=1
;
N IVMCPDT,CPTST,LINK,CPDATE
;should be ok to get the last co-pay test for this year vs. looking from the IVMMTDT backwards
;as long as the means test date is in the current year
S CPTST=$$LST^DGMTU(DFN,$E(IVMIY,1,3)+1_1231,2)
I CPTST D
. S CPDATE=$P(CPTST,U,2)
. S LINK=$P($G(^DGMT(408.31,+CPTST,2)),U,6)
. I TESTTYPE=1,$E(CPDATE,1,3)=$E(IVMMTDT,1,3) D
. . ;if you have a means test and a linked co-pay test then send both (the means test
. . ;was already sent from above)
. . ;if means and copay are not linked, don't send the co-pay test (the means test
. . ;was already sent from above)
. . I LINK=+$$LST^DGMTU(DFN,IVMMTDT,1) S TESTTYPE=2,(IVMCPDT,IVMMTDT)=CPDATE
. . Q
. Q
;always send the 2nd ZMT segment
S SEQS="1,17"
;can also send a co-pay test if there is no means test (see module GETTYPE)
I TESTTYPE=2 D
. S SEQS="1,2,3,4,5,6,7,9,10,12,15,16,17,18,21,22,25,26,30,31,32" ;IVM*2.0*160 IVM*2.0*193 adding hardship expiration date
. Q
S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^IVMCZMT(DFN,SEQS,IVMMTDT,2,2,.DELETE,1)
;
; create (ZMT) Long Term Care Copay Exemption Test segment
I IVMPIEN D
. ; set deletion indicators if LTC test deletion should be transmitted
. I $P(IVMPNODE,"^",11) S DELETE("LTC")=1 S:('DELETE("DATE OF TEST")) DELETE("DATE OF TEST")=$P(IVMPNODE,"^",11)
;
S SEQS="1,2,3,4,5,7,9,10,12,16,17,18,22,25,30,31,32" ;IVM*2.0*160 IVM*2.0*193 adding hardship expiration date
S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^IVMCZMT(DFN,SEQS,IVMMTDT,4,4,.DELETE,1)
;
;if the deletion flags were set in the IVM Patient file, unset them
I $G(DELETE("SET")) D
. N DATA
. S DATA(.08)="",DATA(.09)="",DATA(.1)="",DATA(.11)=""
. I $$UPD^DGENDBS(301.5,IVMPIEN,.DATA)
;
; create (ZBT) Beneficiary Travel segment based on last BT Claim
S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZBT($$BTCLM^IVMUFNC4(DFN),"1,2,3,4,7")
;
; create (ZFE) Fee Basis segment(s)
D EN^FBHLZFE(DFN,"1,2,3,4,5")
F IVMSUB=0:0 S IVMSUB=+$O(FBZFE(IVMSUB)) Q:'IVMSUB D
. S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$G(FBZFE(+IVMSUB))
;
; create (ZSP) Service Period segment
S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZSP(DFN,1,1)
;
; optionally create (OBX) segment for Patient Sensitivity Flag
K OBXTMP
S OBXCNT=0,GETCUR=$$FINDSEC^DGENSEC(DFN)
I GETCUR,$$GET^DGENSEC(GETCUR,.DGSEC) D
. Q:(DGSEC("LEVEL")'=1)&(DGSEC("LEVEL")'=0)
. S OBXTMP(2)="CE",OBXTMP(3)="38.1"_$E(HL("ECH"))_"SECURITY LOG"
. S:DGSEC("LEVEL") OBXTMP(5)="Y"_$E(HL("ECH"))_"YES"_$E(HL("ECH"))_"HL70136"
. S:'DGSEC("LEVEL") OBXTMP(5)="N"_$E(HL("ECH"))_"NO"_$E(HL("ECH"))_"HL70136"
. S OBXTMP(11)="R",OBXTMP(14)=DGSEC("DATETIME")
. S OBXTMP(16)="" I $G(DGSEC("SOURCE"))'="" D
. . S $P(OBXTMP(16),$E(HL("ECH")),14)=$E(HL("ECH"),4)_DGSEC("SOURCE")
. S IVMCT=IVMCT+1,OBXCNT=OBXCNT+1
. S ^TMP("HLS",$J,IVMCT)=$$EN^VAFHLOBX(.OBXTMP,OBXCNT,"2,3,5,11,14,16")
. I $G(OBXTMP(16))'="" S $P(^TMP("HLS",$J,IVMCT),"^",17)=$G(OBXTMP(16))
;
; create (OBX) segment for NTR
; CALL PIMS API TO GET NTRARRY OF NTR DATA
S GETCUR=$$ENRGET^DGNTAPI1(DFN)
I GETCUR D NTROBX^IVMPTRNA(.DGNTARR)
I $D(NTROBX) D
. S IVMCT=IVMCT+1,OBXCNT=OBXCNT+1
. S ^TMP("HLS",$J,IVMCT)=$$EN^VAFHLOBX(.NTROBX,OBXCNT,"2,3,5,11,12,14,15,16,17")
. I $G(NTROBX(16))'="" S $P(^TMP("HLS",$J,IVMCT),"^",17)=$G(NTROBX(16))
. K NTROBX
;
; create (RF1) segment
S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$RF1^IVMPTRNA(DFN,"SAD")
; IVM*2.0*164 - Add Residential Address Change
F RF1TYP="CAD","CPH","PNO","EAD","PHH","RAD" D ;Create Optional RF1 Segments
. S RF1SEG=$$RF1^IVMPTRNA(DFN,RF1TYP) Q:RF1SEG=""
. S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=RF1SEG
;
; IVM*2.0*201 - Send Originating Source and user information to ES
; create (ZUD) segment
N IVMZTYP,IVMZSEG,IVMZCNT
S IVMZCNT=1
S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$ZUD^IVMPTRNA(DFN,"SAD",IVMZCNT),IVMZCNT=IVMZCNT+1
F IVMZTYP="CAD","RAD","CPH","EAD","PHH","PHB","PHC" D ;Create Optional ZUD Segments
. S IVMZSEG=$$ZUD^IVMPTRNA(DFN,IVMZTYP,IVMZCNT) Q:IVMZSEG=""
. S IVMZCNT=IVMZCNT+1
. S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=IVMZSEG
;
Q
;
GETTYPE(DFN,IVMMTDT,CODE,HARDSHIP,ACTVIEN) ;
;Determines the type of test to include in the Z10. HEC wants only the
;test that they would consider primary,i.e., preference given to a comptleted means test, even if not currently in effect.
;
;Input:
; DFN
; IVMMTDT -date to be the search for the test
;Output:
; Function value - type of test to send in Z10
; CODE - status code of test (pass by reference)
; HARDSHIP - hardship indicator (pass by reference)
; ACTVIEN - ien of test that should have the associated Income Relations (pass by reference)
;
N TESTTYPE,MTNODE,RXNODE,NODE0,NODE2
S TESTTYPE=1
S (HARDSHIP,CODE,ACTVIEN)=""
Q:'$G(IVMMTDT) TESTTYPE
Q:'$G(DFN) TESTTYPE
;
S MTNODE=$$LST^DGMTU(DFN,IVMMTDT,1) I $E($P(MTNODE,"^",2),1,3)'=$E(IVMMTDT,1,3) S MTNODE=""
S RXNODE=$$LST^DGMTU(DFN,IVMMTDT,2) I $E($P(RXNODE,"^",2),1,3)'=$E(IVMMTDT,1,3) S RXNODE=""
;
I MTNODE="" S MTNODE=$$FUT^DGMTU(DFN,"",1) I $E($P(MTNODE,"^",2),1,3)'=$E(IVMMTDT,1,3) S MTNODE=""
I RXNODE="" S RXNODE=$$FUT^DGMTU(DFN,"",2) I $E($P(RXNODE,"^",2),1,3)'=$E(IVMMTDT,1,3) S RXNODE=""
D
. ;determine which test has the associated income relations
. ;
. I +MTNODE S CODE=$P(MTNODE,"^",4) I CODE'="",("ACGPR"[CODE) S ACTVIEN=+MTNODE Q
. I +RXNODE S CODE=$P(RXNODE,"^",4) I CODE'="",("EMI"[CODE) S ACTVIEN=+RXNODE Q
. I +MTNODE S ACTVIEN=+MTNODE Q
. I +RXNODE S ACTVIEN=+RXNODE Q
I ACTVIEN,+MTNODE,+RXNODE D TRANSFER^DGMTU4(DFN,$S((ACTVIEN=+MTNODE):+RXNODE,1:+MTNODE),ACTVIEN)
;
;now find the primary test
I '(+MTNODE) G CHKCOPAY
S CODE=$P(MTNODE,"^",4)
S HARDSHIP=$P($G(^DGMT(408.31,+MTNODE,0)),"^",20)
I (CODE="")!("ACGP"'[CODE) S NODE2=$G(^DGMT(408.31,+MTNODE,2)),CODE=$$GETCODE^DGMTH($P(NODE2,"^",3)) I (CODE="")!("ACGP"'[CODE) G CHKCOPAY
;
G QGETTYPE
;
CHKCOPAY ;
I '(+RXNODE) G QGETTYPE
S CODE=$P(RXNODE,"^",4)
I (CODE="")!("EM"'[CODE) S NODE2=$G(^DGMT(408.31,+RXNODE,2)),CODE=$$GETCODE^DGMTH($P(NODE2,"^",3)) I (CODE="")!("EM"'[CODE) G QGETTYPE
S TESTTYPE=2
;
QGETTYPE ;
Q TESTTYPE
;
FILTER(DFN) ; address transmission filter
; Check Bad Address Indicator for a known bad address and
; Scrutinize the Street Address line 1 field for known bad address
; strings based on functionality currently in place in HEC Legacy.
;
; Input: DFN - ien of the Patient (#2) file
; Output: 0 - filter passed (ok to transmit address)
; 1 - filter failed (do not transmit address)
;
N VAPA
Q:'$G(DFN) 1 ;DFN missing
Q:$$BADADR^DGUTL3(DFN) 1 ;check Bad Address Indicator
D ADD^VADPT ;get patient address
; Street Address Line 1 or Zip Code is <null>
Q:($G(VAPA(1))="")!($P($G(VAPA(11)),"^")="") 1
; St Addr Line 1 contains 'UNKNOWN', 'HOMELESS', or 'ADDRESS'
Q:(VAPA(1)["UNKNOWN")!(VAPA(1)["HOMELESS")!(VAPA(1)["ADDRESS") 1
; The first two characters of the address is equal to '**'
Q:$E(VAPA(1),1,2)="**" 1
; passed all address filters - ok to send
Q 0
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIVMPTRN9 10146 printed Dec 13, 2024@02:02:32 Page 2
IVMPTRN9 ;ALB/KCL,CN,BRM,TDM,EG,LBD,TGH,JAM,HM,KUM - HL7 FULL DATA TRANSMISSION (Z07) BUILDER (CONTINUED) ;12/7/12 2:56pm
+1 ;;2.0;INCOME VERIFICATION MATCH;**9,11,19,12,21,17,46,50,53,34,49,58,79,99,116,105,115,152,160,164,180,193,201**;21-OCT-94;Build 17
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ;
GOTO ; place to break up the routine
+1 ;
+2 ; create (ZIO) Inpatient/Outpatient segment for veteran
+3 SET N101015=$GET(^DPT(DFN,1010.15))
+4 ;seq 1-3
SET ZIOSEG="ZIO^1^"_$$EN^IVMUFNC1(DFN,IVMMTDT,.IVMQUERY)
+5 ;seq 4
SET ZIOSEG=ZIOSEG_"^"_$$LTD^IVMUFNC(DFN,.IVMQUERY)
+6 ;Appt Request
SET X=$PIECE(N101015,"^",9)
SET $PIECE(ZIOSEG,U,6)=$SELECT(X=0:"N",X=1:"Y",1:HLQ)
+7 ;Appt Request Date
SET X=$PIECE(N101015,"^",11)
SET $PIECE(ZIOSEG,U,7)=$SELECT(X]"":$$HLDATE^HLFNC(X),1:HLQ)
+8 ; jam ; IVM*2.0*180 - add seq 7, field 1010.1515 - Appt Request Change DT/TM
+9 SET X=$PIECE(N101015,"^",15)
SET $PIECE(ZIOSEG,U,8)=$SELECT(X]"":$$HLDATE^HLFNC(X,"TS"),1:HLQ)
+10 SET IVMCT=IVMCT+1
SET ^TMP("HLS",$JOB,IVMCT)=ZIOSEG
+11 ;
+12 ; create (NTE) Notes and Comments segment
+13 DO NTE^IVMUFNC4(DFN,.IVMNTE,IVMMTDT)
+14 IF '$DATA(IVMNTE)
Begin DoDot:1
+15 SET IVMCT=IVMCT+1
SET ^TMP("HLS",$JOB,IVMCT)="NTE^1"
End DoDot:1
+16 IF $DATA(IVMNTE)
Begin DoDot:1
+17 ; - get notes and comments
+18 FOR IVMSUB=0:0
SET IVMSUB=$ORDER(IVMNTE(IVMSUB))
if 'IVMSUB
QUIT
Begin DoDot:2
+19 SET IVMCT=IVMCT+1
SET ^TMP("HLS",$JOB,IVMCT)=IVMNTE(IVMSUB)
End DoDot:2
End DoDot:1
+20 ;
+21 ; create (IN1) Insurance segment(s) for all active insurance
+22 KILL ^TMP("VAFIN1",$JOB)
+23 DO EN^VAFHLIN1(DFN,"1,4,5,7,8,9,12,13,15,16,17,28,36")
+24 FOR IVMSUB=0:0
SET IVMSUB=$ORDER(^TMP("VAFIN1",$JOB,IVMSUB))
if 'IVMSUB
QUIT
Begin DoDot:1
+25 SET IVMCT=IVMCT+1
SET ^TMP("HLS",$JOB,IVMCT)=^TMP("VAFIN1",$JOB,+IVMSUB,0)
End DoDot:1
+26 ;
+27 ;find if the deletion flags were set in the IVM Patient file, and if so, should the deletion indicators be sent?
+28 FOR I="RX","MT","HARDSHIP","DATE OF TEST","LTC"
SET DELETE(I)=""
+29 SET IVMPIEN=$$FIND^IVMPLOG(DFN,($EXTRACT(IVMMTDT,1,3)-1))
+30 IF IVMPIEN
Begin DoDot:1
+31 SET IVMPNODE=$GET(^IVM(301.5,IVMPIEN,0))
+32 IF $PIECE(IVMPNODE,"^",8)!$PIECE(IVMPNODE,"^",9)!$PIECE(IVMPNODE,"^",10)!$PIECE(IVMPNODE,"^",11)
SET DELETE("SET")=1
+33 ;was the MT deletion flag set, and if so verify that there is no completed MT
+34 IF $PIECE(IVMPNODE,"^",8)
IF (TESTTYPE'=1)!(TESTCODE="")!("ACGP"'[TESTCODE)
SET DELETE("DATE OF TEST")=$PIECE(IVMPNODE,"^",8)
SET DELETE("MT")=1
+35 ;
+36 ;was the hardship deletion flag set, and if so verify that there is no completed hardship
+37 IF $PIECE(IVMPNODE,"^",10)
IF 'HARDSHIP
Begin DoDot:2
+38 if ('DELETE("DATE OF TEST"))
SET DELETE("DATE OF TEST")=$PIECE(IVMPNODE,"^",10)
+39 SET DELETE("HARDSHIP")=1
End DoDot:2
End DoDot:1
+40 ;
+41 ; create (ZMT) Means Test segment
+42 ;
+43 ;IVM*2.0*160 IVM*2.0*193 added hardship expiration
SET SEQS=$SELECT(TESTTYPE=1:"1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,21,22,23,24,25,26,28,29,30,31,32",1:"1,17")
+44 SET IVMCT=IVMCT+1
SET ^TMP("HLS",$JOB,IVMCT)=$$EN^IVMCZMT(DFN,SEQS,IVMMTDT,1,1,.DELETE,1)
+45 ;
+46 ; create (ZMT) Rx-Copay Test segment
+47 IF IVMPIEN
Begin DoDot:1
+48 ;was the RX deletion flag set, and if so verify that there is no completed test
+49 IF $PIECE(IVMPNODE,"^",9)
IF (TESTTYPE'=2)!(TESTCODE="")!("EM"'[TESTCODE)
SET DELETE("DATE OF TEST")=$PIECE(IVMPNODE,"^",9)
SET DELETE("RX")=1
End DoDot:1
+50 ;
+51 NEW IVMCPDT,CPTST,LINK,CPDATE
+52 ;should be ok to get the last co-pay test for this year vs. looking from the IVMMTDT backwards
+53 ;as long as the means test date is in the current year
+54 SET CPTST=$$LST^DGMTU(DFN,$EXTRACT(IVMIY,1,3)+1_1231,2)
+55 IF CPTST
Begin DoDot:1
+56 SET CPDATE=$PIECE(CPTST,U,2)
+57 SET LINK=$PIECE($GET(^DGMT(408.31,+CPTST,2)),U,6)
+58 IF TESTTYPE=1
IF $EXTRACT(CPDATE,1,3)=$EXTRACT(IVMMTDT,1,3)
Begin DoDot:2
+59 ;if you have a means test and a linked co-pay test then send both (the means test
+60 ;was already sent from above)
+61 ;if means and copay are not linked, don't send the co-pay test (the means test
+62 ;was already sent from above)
+63 IF LINK=+$$LST^DGMTU(DFN,IVMMTDT,1)
SET TESTTYPE=2
SET (IVMCPDT,IVMMTDT)=CPDATE
+64 QUIT
End DoDot:2
+65 QUIT
End DoDot:1
+66 ;always send the 2nd ZMT segment
+67 SET SEQS="1,17"
+68 ;can also send a co-pay test if there is no means test (see module GETTYPE)
+69 IF TESTTYPE=2
Begin DoDot:1
+70 ;IVM*2.0*160 IVM*2.0*193 adding hardship expiration date
SET SEQS="1,2,3,4,5,6,7,9,10,12,15,16,17,18,21,22,25,26,30,31,32"
+71 QUIT
End DoDot:1
+72 SET IVMCT=IVMCT+1
SET ^TMP("HLS",$JOB,IVMCT)=$$EN^IVMCZMT(DFN,SEQS,IVMMTDT,2,2,.DELETE,1)
+73 ;
+74 ; create (ZMT) Long Term Care Copay Exemption Test segment
+75 IF IVMPIEN
Begin DoDot:1
+76 ; set deletion indicators if LTC test deletion should be transmitted
+77 IF $PIECE(IVMPNODE,"^",11)
SET DELETE("LTC")=1
if ('DELETE("DATE OF TEST"))
SET DELETE("DATE OF TEST")=$PIECE(IVMPNODE,"^",11)
End DoDot:1
+78 ;
+79 ;IVM*2.0*160 IVM*2.0*193 adding hardship expiration date
SET SEQS="1,2,3,4,5,7,9,10,12,16,17,18,22,25,30,31,32"
+80 SET IVMCT=IVMCT+1
SET ^TMP("HLS",$JOB,IVMCT)=$$EN^IVMCZMT(DFN,SEQS,IVMMTDT,4,4,.DELETE,1)
+81 ;
+82 ;if the deletion flags were set in the IVM Patient file, unset them
+83 IF $GET(DELETE("SET"))
Begin DoDot:1
+84 NEW DATA
+85 SET DATA(.08)=""
SET DATA(.09)=""
SET DATA(.1)=""
SET DATA(.11)=""
+86 IF $$UPD^DGENDBS(301.5,IVMPIEN,.DATA)
End DoDot:1
+87 ;
+88 ; create (ZBT) Beneficiary Travel segment based on last BT Claim
+89 SET IVMCT=IVMCT+1
SET ^TMP("HLS",$JOB,IVMCT)=$$EN^VAFHLZBT($$BTCLM^IVMUFNC4(DFN),"1,2,3,4,7")
+90 ;
+91 ; create (ZFE) Fee Basis segment(s)
+92 DO EN^FBHLZFE(DFN,"1,2,3,4,5")
+93 FOR IVMSUB=0:0
SET IVMSUB=+$ORDER(FBZFE(IVMSUB))
if 'IVMSUB
QUIT
Begin DoDot:1
+94 SET IVMCT=IVMCT+1
SET ^TMP("HLS",$JOB,IVMCT)=$GET(FBZFE(+IVMSUB))
End DoDot:1
+95 ;
+96 ; create (ZSP) Service Period segment
+97 SET IVMCT=IVMCT+1
SET ^TMP("HLS",$JOB,IVMCT)=$$EN^VAFHLZSP(DFN,1,1)
+98 ;
+99 ; optionally create (OBX) segment for Patient Sensitivity Flag
+100 KILL OBXTMP
+101 SET OBXCNT=0
SET GETCUR=$$FINDSEC^DGENSEC(DFN)
+102 IF GETCUR
IF $$GET^DGENSEC(GETCUR,.DGSEC)
Begin DoDot:1
+103 if (DGSEC("LEVEL")'=1)&(DGSEC("LEVEL")'=0)
QUIT
+104 SET OBXTMP(2)="CE"
SET OBXTMP(3)="38.1"_$EXTRACT(HL("ECH"))_"SECURITY LOG"
+105 if DGSEC("LEVEL")
SET OBXTMP(5)="Y"_$EXTRACT(HL("ECH"))_"YES"_$EXTRACT(HL("ECH"))_"HL70136"
+106 if 'DGSEC("LEVEL")
SET OBXTMP(5)="N"_$EXTRACT(HL("ECH"))_"NO"_$EXTRACT(HL("ECH"))_"HL70136"
+107 SET OBXTMP(11)="R"
SET OBXTMP(14)=DGSEC("DATETIME")
+108 SET OBXTMP(16)=""
IF $GET(DGSEC("SOURCE"))'=""
Begin DoDot:2
+109 SET $PIECE(OBXTMP(16),$EXTRACT(HL("ECH")),14)=$EXTRACT(HL("ECH"),4)_DGSEC("SOURCE")
End DoDot:2
+110 SET IVMCT=IVMCT+1
SET OBXCNT=OBXCNT+1
+111 SET ^TMP("HLS",$JOB,IVMCT)=$$EN^VAFHLOBX(.OBXTMP,OBXCNT,"2,3,5,11,14,16")
+112 IF $GET(OBXTMP(16))'=""
SET $PIECE(^TMP("HLS",$JOB,IVMCT),"^",17)=$GET(OBXTMP(16))
End DoDot:1
+113 ;
+114 ; create (OBX) segment for NTR
+115 ; CALL PIMS API TO GET NTRARRY OF NTR DATA
+116 SET GETCUR=$$ENRGET^DGNTAPI1(DFN)
+117 IF GETCUR
DO NTROBX^IVMPTRNA(.DGNTARR)
+118 IF $DATA(NTROBX)
Begin DoDot:1
+119 SET IVMCT=IVMCT+1
SET OBXCNT=OBXCNT+1
+120 SET ^TMP("HLS",$JOB,IVMCT)=$$EN^VAFHLOBX(.NTROBX,OBXCNT,"2,3,5,11,12,14,15,16,17")
+121 IF $GET(NTROBX(16))'=""
SET $PIECE(^TMP("HLS",$JOB,IVMCT),"^",17)=$GET(NTROBX(16))
+122 KILL NTROBX
End DoDot:1
+123 ;
+124 ; create (RF1) segment
+125 SET IVMCT=IVMCT+1
SET ^TMP("HLS",$JOB,IVMCT)=$$RF1^IVMPTRNA(DFN,"SAD")
+126 ; IVM*2.0*164 - Add Residential Address Change
+127 ;Create Optional RF1 Segments
FOR RF1TYP="CAD","CPH","PNO","EAD","PHH","RAD"
Begin DoDot:1
+128 SET RF1SEG=$$RF1^IVMPTRNA(DFN,RF1TYP)
if RF1SEG=""
QUIT
+129 SET IVMCT=IVMCT+1
SET ^TMP("HLS",$JOB,IVMCT)=RF1SEG
End DoDot:1
+130 ;
+131 ; IVM*2.0*201 - Send Originating Source and user information to ES
+132 ; create (ZUD) segment
+133 NEW IVMZTYP,IVMZSEG,IVMZCNT
+134 SET IVMZCNT=1
+135 SET IVMCT=IVMCT+1
SET ^TMP("HLS",$JOB,IVMCT)=$$ZUD^IVMPTRNA(DFN,"SAD",IVMZCNT)
SET IVMZCNT=IVMZCNT+1
+136 ;Create Optional ZUD Segments
FOR IVMZTYP="CAD","RAD","CPH","EAD","PHH","PHB","PHC"
Begin DoDot:1
+137 SET IVMZSEG=$$ZUD^IVMPTRNA(DFN,IVMZTYP,IVMZCNT)
if IVMZSEG=""
QUIT
+138 SET IVMZCNT=IVMZCNT+1
+139 SET IVMCT=IVMCT+1
SET ^TMP("HLS",$JOB,IVMCT)=IVMZSEG
End DoDot:1
+140 ;
+141 QUIT
+142 ;
GETTYPE(DFN,IVMMTDT,CODE,HARDSHIP,ACTVIEN) ;
+1 ;Determines the type of test to include in the Z10. HEC wants only the
+2 ;test that they would consider primary,i.e., preference given to a comptleted means test, even if not currently in effect.
+3 ;
+4 ;Input:
+5 ; DFN
+6 ; IVMMTDT -date to be the search for the test
+7 ;Output:
+8 ; Function value - type of test to send in Z10
+9 ; CODE - status code of test (pass by reference)
+10 ; HARDSHIP - hardship indicator (pass by reference)
+11 ; ACTVIEN - ien of test that should have the associated Income Relations (pass by reference)
+12 ;
+13 NEW TESTTYPE,MTNODE,RXNODE,NODE0,NODE2
+14 SET TESTTYPE=1
+15 SET (HARDSHIP,CODE,ACTVIEN)=""
+16 if '$GET(IVMMTDT)
QUIT TESTTYPE
+17 if '$GET(DFN)
QUIT TESTTYPE
+18 ;
+19 SET MTNODE=$$LST^DGMTU(DFN,IVMMTDT,1)
IF $EXTRACT($PIECE(MTNODE,"^",2),1,3)'=$EXTRACT(IVMMTDT,1,3)
SET MTNODE=""
+20 SET RXNODE=$$LST^DGMTU(DFN,IVMMTDT,2)
IF $EXTRACT($PIECE(RXNODE,"^",2),1,3)'=$EXTRACT(IVMMTDT,1,3)
SET RXNODE=""
+21 ;
+22 IF MTNODE=""
SET MTNODE=$$FUT^DGMTU(DFN,"",1)
IF $EXTRACT($PIECE(MTNODE,"^",2),1,3)'=$EXTRACT(IVMMTDT,1,3)
SET MTNODE=""
+23 IF RXNODE=""
SET RXNODE=$$FUT^DGMTU(DFN,"",2)
IF $EXTRACT($PIECE(RXNODE,"^",2),1,3)'=$EXTRACT(IVMMTDT,1,3)
SET RXNODE=""
+24 Begin DoDot:1
+25 ;determine which test has the associated income relations
+26 ;
+27 IF +MTNODE
SET CODE=$PIECE(MTNODE,"^",4)
IF CODE'=""
IF ("ACGPR"[CODE)
SET ACTVIEN=+MTNODE
QUIT
+28 IF +RXNODE
SET CODE=$PIECE(RXNODE,"^",4)
IF CODE'=""
IF ("EMI"[CODE)
SET ACTVIEN=+RXNODE
QUIT
+29 IF +MTNODE
SET ACTVIEN=+MTNODE
QUIT
+30 IF +RXNODE
SET ACTVIEN=+RXNODE
QUIT
End DoDot:1
+31 IF ACTVIEN
IF +MTNODE
IF +RXNODE
DO TRANSFER^DGMTU4(DFN,$SELECT((ACTVIEN=+MTNODE):+RXNODE,1:+MTNODE),ACTVIEN)
+32 ;
+33 ;now find the primary test
+34 IF '(+MTNODE)
GOTO CHKCOPAY
+35 SET CODE=$PIECE(MTNODE,"^",4)
+36 SET HARDSHIP=$PIECE($GET(^DGMT(408.31,+MTNODE,0)),"^",20)
+37 IF (CODE="")!("ACGP"'[CODE)
SET NODE2=$GET(^DGMT(408.31,+MTNODE,2))
SET CODE=$$GETCODE^DGMTH($PIECE(NODE2,"^",3))
IF (CODE="")!("ACGP"'[CODE)
GOTO CHKCOPAY
+38 ;
+39 GOTO QGETTYPE
+40 ;
CHKCOPAY ;
+1 IF '(+RXNODE)
GOTO QGETTYPE
+2 SET CODE=$PIECE(RXNODE,"^",4)
+3 IF (CODE="")!("EM"'[CODE)
SET NODE2=$GET(^DGMT(408.31,+RXNODE,2))
SET CODE=$$GETCODE^DGMTH($PIECE(NODE2,"^",3))
IF (CODE="")!("EM"'[CODE)
GOTO QGETTYPE
+4 SET TESTTYPE=2
+5 ;
QGETTYPE ;
+1 QUIT TESTTYPE
+2 ;
FILTER(DFN) ; address transmission filter
+1 ; Check Bad Address Indicator for a known bad address and
+2 ; Scrutinize the Street Address line 1 field for known bad address
+3 ; strings based on functionality currently in place in HEC Legacy.
+4 ;
+5 ; Input: DFN - ien of the Patient (#2) file
+6 ; Output: 0 - filter passed (ok to transmit address)
+7 ; 1 - filter failed (do not transmit address)
+8 ;
+9 NEW VAPA
+10 ;DFN missing
if '$GET(DFN)
QUIT 1
+11 ;check Bad Address Indicator
if $$BADADR^DGUTL3(DFN)
QUIT 1
+12 ;get patient address
DO ADD^VADPT
+13 ; Street Address Line 1 or Zip Code is <null>
+14 if ($GET(VAPA(1))="")!($PIECE($GET(VAPA(11)),"^")="")
QUIT 1
+15 ; St Addr Line 1 contains 'UNKNOWN', 'HOMELESS', or 'ADDRESS'
+16 if (VAPA(1)["UNKNOWN")!(VAPA(1)["HOMELESS")!(VAPA(1)["ADDRESS")
QUIT 1
+17 ; The first two characters of the address is equal to '**'
+18 if $EXTRACT(VAPA(1),1,2)="**"
QUIT 1
+19 ; passed all address filters - ok to send
+20 QUIT 0
