IVMPTRNA ;ALB/CKN,BRM,TDM,LBD,KUM - HL7 FULL DATA TRANSMISSION (Z07) BUILDER(CONTINUED) ;7/18/24 9:13AM
;;2.0;INCOME VERIFICATION MATCH;**46,58,76,105,152,164,201,215**;21-OCT-94;Build 14
;Per VHA Directive 2004-038, this routine should not be modified.
;
Q
NTROBX(DGNTARR) ;
N NTRTEMP,I,CS,RS,SS
I $G(HLECH)'="~|\&" N HLECH S HLECH="~|\&"
I $G(HLFS)'="^" N HLFS S HLFS="^"
S CS=$E(HLECH,1),SS=$E(HLECH,4),RS=$E(HLECH,2)
S NTRTEMP("NTR","Y")="1"_CS_"Received NTR Trmt"_CS_"VA0053"
S NTRTEMP("AVI","Y")="2"_CS_"Aviator Pre 1955"_CS_"VA0053"
S NTRTEMP("SUB","Y")="3"_CS_"Sub Trainee pre 1965"_CS_"VA0053"
S NTRTEMP("HNC","Y")="4"_CS_"Dx With Head Neck Cancer"_CS_"VA0053"
S NTRTEMP("NTR","N")="5"_CS_"No NTR Trmt"_CS_"VA0053"
S NTRTEMP("AVI","N")="6"_CS_"Not Aviator Pre 1955"_CS_"VA0053"
S NTRTEMP("SUB","N")="7"_CS_"Not Sub Trainee pre 1965"_CS_"VA0053"
S NTRTEMP("HNC","N")="8"_CS_"Not Dx With Head Neck Cancer"_CS_"VA0053"
S NTRTEMP("NTR","U")="9"_CS_"NTR Trmt Unknown"_CS_"VA0053"
S NTRTEMP("VER","M")="M"_CS_"Military Med Rec"_CS_"VA0052"
S NTRTEMP("VER","S")="S"_CS_"Qual Military Srvc"_CS_"VA0052"
S NTRTEMP("VER","N")="N"_CS_"Not Qualified"_CS_"VA0052"
S NTROBX(2)="CE",NTROBX(3)="VISTA"_CS_"28.11"
S NTROBX(5)=""
F I="NTR","AVI","SUB","HNC" D
. I $G(DGNTARR(I))="" Q
. I NTROBX(5)'="" S NTROBX(5)=$G(NTROBX(5))_RS
. S NTROBX(5)=$G(NTROBX(5))_$G(NTRTEMP(I,$G(DGNTARR(I))))
S NTROBX(11)="F"
S NTROBX(12)=$G(DGNTARR("HDT"))
S NTROBX(14)=$G(DGNTARR("VDT"))
I $G(DGNTARR("VSIT"))'="" D
. S NTROBX(15)=$P($G(^DIC(4,DGNTARR("VSIT"),99)),"^")
S NTROBX(16)=""
I $G(DGNTARR("HSIT"))'="" D
. S $P(NTROBX(16),CS,14)=SS_$P($G(^DIC(4,DGNTARR("HSIT"),99)),"^")
I $G(DGNTARR("VER"))'="" S NTROBX(17)=$G(NTRTEMP("VER",$G(DGNTARR("VER"))))
Q
RF1(DFN,RF1TYP) ; create RF1 segment
; Input:
; DFN - Patient IEN
; RF1TYP - RF1 Type
; SAD = Street Address Change (Default)
; CAD = Confidential Address Change
; CPH = Cell Phone Number Change
; PNO = Pager Number Change
; EAD = E-Mail Address Change
; PHH = Home Phone Number Change
; RAD Residential Address Change
;
; Output: RF1 segment
;
N X,Y,ADDRSRC,ADRSRC,ADRSIT,ADTDT,I,CS,RS,SS,HLQ,RETURN,RFDAT,ERR
I $G(HLECH)'="~|\&" N HLECH S HLECH="~|\&"
I $G(HLFS)'="^" N HLFS S HLFS="^"
S CS=$E(HLECH,1),SS=$E(HLECH,4),RS=$E(HLECH,2),HLQ=""""
S:$G(RF1TYP)="" RF1TYP="SAD" ;Set type to 'SAD' if no value passed
; initialize the RETURN variable
S RETURN="RF1",$P(RETURN,HLFS,4)=RF1TYP,$P(RETURN,HLFS,11)=""
Q:'$G(DFN) RETURN
;I RF1TYP="SAD",$$BADADR^DGUTL3(DFN) Q RETURN
D RF1LOAD(RF1TYP) Q:$D(ERR) RETURN
I RF1TYP'="SAD",$G(ADRDT)="" Q ""
; RF1 SEQ 1-2 are not currently used
; RF1 SEQ 3
S $P(RETURN,HLFS,4)=RF1TYP
; RF1 SEQ 4-5 are not currently used
; RF1 SEQ 6
S $P(RETURN,HLFS,7)=$G(ADRSIT)
S:$G(ADRSRC)'="" $P(RETURN,HLFS,7)=$P(RETURN,HLFS,7)_CS_ADRSRC
; RF1 SEQ 7
S $P(RETURN,HLFS,8)=$G(ADRDT)
; RF1 SEQ 8-11 are not currently used
; quit with completed RF1 segment
Q RETURN
;
ZUD(DFN,IVMZTYP,IVMZCNT) ; create ZUD segment
; IVM*2.0*201 - Send Originating Source and User information to ES
; Input:
; DFN - Patient IEN
; IVMZTYP - ZUD Type
; SAD = Street Address Change (Default)
; CAD = Confidential Address Change
; CPH = Cell Phone Number Change
; EAD = E-Mail Address Change
; PHH = Home Phone Number Change
; RAD Residential Address Change
; PHB Business Phone Number Change
; PHC Confidential Phone Number Change
; IVMZCNT - Sequence number of ZUD segment
;
; Output: ZUD segment (ZUD^IVMZCNT^ZUD Type^Change Dt/Tm^Username^DUZ)
;
N IVMADDT,IVMRTN,IVMERR,IVMADIEN,IVMADUSR
I $G(HLECH)'="~|\&" N HLECH S HLECH="~|\&"
I $G(HLFS)'="^" N HLFS S HLFS="^"
S:$G(IVMZTYP)="" IVMZTYP="SAD" ;Set type to 'SAD' if no value passed
; initialize the IVMRTN variable with ZUD^ZUD Type
S IVMRTN="ZUD",$P(IVMRTN,HLFS,2)=$G(IVMZCNT),$P(IVMRTN,HLFS,3)=IVMZTYP
Q:'$G(DFN) IVMRTN
S IVMERR=""
D ZUDLOAD(IVMZTYP,.IVMERR) Q:IVMERR'="" IVMRTN
; If no date, do not send ZUD segment
I $G(IVMADDT)="" Q ""
; If no IVMADUSR, do not send ZUD segment
I $G(IVMADUSR)="" Q ""
S $P(IVMRTN,HLFS,4)=$G(IVMADDT)
S $P(IVMRTN,HLFS,5)=$G(IVMADUSR)
S $P(IVMRTN,HLFS,6)=$G(IVMADIEN)
; IVMRTN variable will contain ZUD^IVMZCNT^ZUD Type^Change Dt/Tm^Username^DUZ
Q IVMRTN
;
ADDRCNV(ADDRSRC) ;convert Address Source to HL7 format
Q:$G(ADDRSRC)']"" ""
Q:ADDRSRC="HEC" "USVAHEC"
Q:ADDRSRC="VAMC" "USVAMC"
Q:ADDRSRC="HBSC" "USVAHBSC"
Q:ADDRSRC="NCOA" "USNCOA"
Q:ADDRSRC="BVA" "USVABVA"
Q:ADDRSRC="VAINS" "USVAINS"
Q:ADDRSRC="USPS" "USPS"
Q:ADDRSRC="LACS" "LACS"
Q:ADDRSRC="VET360" "VET360"
Q ""
;
RF1LOAD(RF1TYP) ;
N RFDT,RFSRC,RFSIT,GETFLDS,RFDAT,ERR
K ADRDT,ADRSRC,ADRSIT
I RF1TYP="SAD" S RFDT=.118,RFSRC=.119,RFSIT=.12
;IVM*2.0*215 - Send Change Site in RF1 segment by replacing Chagne User in RFSIT variable
;I RF1TYP="CAD" S RFDT=.14112,RFSRC="",RFSIT=.14118
I RF1TYP="CAD" S RFDT=.14112,RFSRC="",RFSIT=.14113
I RF1TYP="CPH" S RFDT=.139,RFSRC=.1311,RFSIT=.13111
I RF1TYP="PNO" S RFDT=.1312,RFSRC=.1313,RFSIT=.1314
I RF1TYP="EAD" S RFDT=.136,RFSRC=.137,RFSIT=.138
I RF1TYP="PHH" S RFDT=.1321,RFSRC=.1322,RFSIT=.1323
; IVM*2.0*164 - Add Residential Address Change
I RF1TYP="RAD" S RFDT=.1158,RFSRC=.11582,RFSIT=.11581
S GETFLDS=RFDT S:RFSRC'="" GETFLDS=GETFLDS_";"_RFSRC S GETFLDS=GETFLDS_";"_RFSIT
D GETS^DIQ(2,DFN_",",GETFLDS,"IE","RFDAT","ERR") Q:$D(ERR)
S ADRDT=$$FMTHL7^XLFDT($G(RFDAT(2,DFN_",",RFDT,"I")))
S:RFSRC'="" ADRSRC=$$EXTERNAL^DILFD(2,RFSRC,"",$G(RFDAT(2,DFN_",",RFSRC,"I")))
; only populate Change Site if Source=VAMC or NO Source Field
I ($G(ADRSRC)="VAMC")!(RFSRC="") D
. S ADRSIT=$G(RFDAT(2,DFN_",",RFSIT,"I"))
. S:ADRSIT]"" ADRSIT=$$GET1^DIQ(4,ADRSIT_",",99)
S ADRSRC=$$ADDRCNV($G(ADRSRC)) ;convert source to HL7 format
Q
ZUDLOAD(IVMZTYP,IVMERR) ;
; IVM*2.0*201 - Create ZUD segment
; Input
; IVMZTYP - ZUD Type
; IVMERR - Error message on failure (optional, pass by reference)
;
N IVMZDT,IVMZUSR,IVMGFLDS,IVMZDAT
S IVMADDT="",IVMADIEN="",IVMADUSR=""
I IVMZTYP="SAD" S IVMZDT=.118,IVMZUSR=.122
I IVMZTYP="CAD" S IVMZDT=.14112,IVMZUSR=.14118
I IVMZTYP="RAD" S IVMZDT=.1158,IVMZUSR=.11583
I IVMZTYP="CPH" S IVMZDT=.139,IVMZUSR=.1319
I IVMZTYP="EAD" S IVMZDT=.136,IVMZUSR=.1318
I IVMZTYP="PHH" S IVMZDT=.1321,IVMZUSR=.1324
I IVMZTYP="PHB" S IVMZDT=.1326,IVMZUSR=.1325
I IVMZTYP="PHC" S IVMZDT=.14112,IVMZUSR=.14119
S IVMGFLDS=IVMZDT S IVMGFLDS=IVMGFLDS_";"_IVMZUSR
D GETS^DIQ(2,DFN_",",IVMGFLDS,"IE","IVMZDAT","IVMERR") Q:IVMERR'=""
S IVMADDT=$$FMTHL7^XLFDT($G(IVMZDAT(2,DFN_",",IVMZDT,"I")))
S IVMADIEN=$G(IVMZDAT(2,DFN_",",IVMZUSR,"I"))
S IVMADUSR=$$EXTERNAL^DILFD(2,IVMZUSR,"",IVMADIEN)
; If no username, or for some specific user names, blank out the username and DUZ
I ((IVMADUSR="")!(IVMADUSR="POSTMASTER")!(IVMADUSR="PSUSER,APPLICATION PROXY")!(IVMADUSR="PSOAPPLICATIONPROXY,PSO")) D
. S IVMADUSR="",IVMADIEN=""
E D
. S IVMADUSR=$P(IVMADUSR,",")_"~"_$P(IVMADUSR,",",2)
. S IVMADUSR=$P(IVMADUSR," ")_"~"_$P(IVMADUSR," ",2)_"~"_$P(IVMADUSR," ",3)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIVMPTRNA 7453 printed Sep 23, 2025@19:37:53 Page 2
IVMPTRNA ;ALB/CKN,BRM,TDM,LBD,KUM - HL7 FULL DATA TRANSMISSION (Z07) BUILDER(CONTINUED) ;7/18/24 9:13AM
+1 ;;2.0;INCOME VERIFICATION MATCH;**46,58,76,105,152,164,201,215**;21-OCT-94;Build 14
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 QUIT
NTROBX(DGNTARR) ;
+1 NEW NTRTEMP,I,CS,RS,SS
+2 IF $GET(HLECH)'="~|\&"
NEW HLECH
SET HLECH="~|\&"
+3 IF $GET(HLFS)'="^"
NEW HLFS
SET HLFS="^"
+4 SET CS=$EXTRACT(HLECH,1)
SET SS=$EXTRACT(HLECH,4)
SET RS=$EXTRACT(HLECH,2)
+5 SET NTRTEMP("NTR","Y")="1"_CS_"Received NTR Trmt"_CS_"VA0053"
+6 SET NTRTEMP("AVI","Y")="2"_CS_"Aviator Pre 1955"_CS_"VA0053"
+7 SET NTRTEMP("SUB","Y")="3"_CS_"Sub Trainee pre 1965"_CS_"VA0053"
+8 SET NTRTEMP("HNC","Y")="4"_CS_"Dx With Head Neck Cancer"_CS_"VA0053"
+9 SET NTRTEMP("NTR","N")="5"_CS_"No NTR Trmt"_CS_"VA0053"
+10 SET NTRTEMP("AVI","N")="6"_CS_"Not Aviator Pre 1955"_CS_"VA0053"
+11 SET NTRTEMP("SUB","N")="7"_CS_"Not Sub Trainee pre 1965"_CS_"VA0053"
+12 SET NTRTEMP("HNC","N")="8"_CS_"Not Dx With Head Neck Cancer"_CS_"VA0053"
+13 SET NTRTEMP("NTR","U")="9"_CS_"NTR Trmt Unknown"_CS_"VA0053"
+14 SET NTRTEMP("VER","M")="M"_CS_"Military Med Rec"_CS_"VA0052"
+15 SET NTRTEMP("VER","S")="S"_CS_"Qual Military Srvc"_CS_"VA0052"
+16 SET NTRTEMP("VER","N")="N"_CS_"Not Qualified"_CS_"VA0052"
+17 SET NTROBX(2)="CE"
SET NTROBX(3)="VISTA"_CS_"28.11"
+18 SET NTROBX(5)=""
+19 FOR I="NTR","AVI","SUB","HNC"
Begin DoDot:1
+20 IF $GET(DGNTARR(I))=""
QUIT
+21 IF NTROBX(5)'=""
SET NTROBX(5)=$GET(NTROBX(5))_RS
+22 SET NTROBX(5)=$GET(NTROBX(5))_$GET(NTRTEMP(I,$GET(DGNTARR(I))))
End DoDot:1
+23 SET NTROBX(11)="F"
+24 SET NTROBX(12)=$GET(DGNTARR("HDT"))
+25 SET NTROBX(14)=$GET(DGNTARR("VDT"))
+26 IF $GET(DGNTARR("VSIT"))'=""
Begin DoDot:1
+27 SET NTROBX(15)=$PIECE($GET(^DIC(4,DGNTARR("VSIT"),99)),"^")
End DoDot:1
+28 SET NTROBX(16)=""
+29 IF $GET(DGNTARR("HSIT"))'=""
Begin DoDot:1
+30 SET $PIECE(NTROBX(16),CS,14)=SS_$PIECE($GET(^DIC(4,DGNTARR("HSIT"),99)),"^")
End DoDot:1
+31 IF $GET(DGNTARR("VER"))'=""
SET NTROBX(17)=$GET(NTRTEMP("VER",$GET(DGNTARR("VER"))))
+32 QUIT
RF1(DFN,RF1TYP) ; create RF1 segment
+1 ; Input:
+2 ; DFN - Patient IEN
+3 ; RF1TYP - RF1 Type
+4 ; SAD = Street Address Change (Default)
+5 ; CAD = Confidential Address Change
+6 ; CPH = Cell Phone Number Change
+7 ; PNO = Pager Number Change
+8 ; EAD = E-Mail Address Change
+9 ; PHH = Home Phone Number Change
+10 ; RAD Residential Address Change
+11 ;
+12 ; Output: RF1 segment
+13 ;
+14 NEW X,Y,ADDRSRC,ADRSRC,ADRSIT,ADTDT,I,CS,RS,SS,HLQ,RETURN,RFDAT,ERR
+15 IF $GET(HLECH)'="~|\&"
NEW HLECH
SET HLECH="~|\&"
+16 IF $GET(HLFS)'="^"
NEW HLFS
SET HLFS="^"
+17 SET CS=$EXTRACT(HLECH,1)
SET SS=$EXTRACT(HLECH,4)
SET RS=$EXTRACT(HLECH,2)
SET HLQ=""""
+18 ;Set type to 'SAD' if no value passed
if $GET(RF1TYP)=""
SET RF1TYP="SAD"
+19 ; initialize the RETURN variable
+20 SET RETURN="RF1"
SET $PIECE(RETURN,HLFS,4)=RF1TYP
SET $PIECE(RETURN,HLFS,11)=""
+21 if '$GET(DFN)
QUIT RETURN
+22 ;I RF1TYP="SAD",$$BADADR^DGUTL3(DFN) Q RETURN
+23 DO RF1LOAD(RF1TYP)
if $DATA(ERR)
QUIT RETURN
+24 IF RF1TYP'="SAD"
IF $GET(ADRDT)=""
QUIT ""
+25 ; RF1 SEQ 1-2 are not currently used
+26 ; RF1 SEQ 3
+27 SET $PIECE(RETURN,HLFS,4)=RF1TYP
+28 ; RF1 SEQ 4-5 are not currently used
+29 ; RF1 SEQ 6
+30 SET $PIECE(RETURN,HLFS,7)=$GET(ADRSIT)
+31 if $GET(ADRSRC)'=""
SET $PIECE(RETURN,HLFS,7)=$PIECE(RETURN,HLFS,7)_CS_ADRSRC
+32 ; RF1 SEQ 7
+33 SET $PIECE(RETURN,HLFS,8)=$GET(ADRDT)
+34 ; RF1 SEQ 8-11 are not currently used
+35 ; quit with completed RF1 segment
+36 QUIT RETURN
+37 ;
ZUD(DFN,IVMZTYP,IVMZCNT) ; create ZUD segment
+1 ; IVM*2.0*201 - Send Originating Source and User information to ES
+2 ; Input:
+3 ; DFN - Patient IEN
+4 ; IVMZTYP - ZUD Type
+5 ; SAD = Street Address Change (Default)
+6 ; CAD = Confidential Address Change
+7 ; CPH = Cell Phone Number Change
+8 ; EAD = E-Mail Address Change
+9 ; PHH = Home Phone Number Change
+10 ; RAD Residential Address Change
+11 ; PHB Business Phone Number Change
+12 ; PHC Confidential Phone Number Change
+13 ; IVMZCNT - Sequence number of ZUD segment
+14 ;
+15 ; Output: ZUD segment (ZUD^IVMZCNT^ZUD Type^Change Dt/Tm^Username^DUZ)
+16 ;
+17 NEW IVMADDT,IVMRTN,IVMERR,IVMADIEN,IVMADUSR
+18 IF $GET(HLECH)'="~|\&"
NEW HLECH
SET HLECH="~|\&"
+19 IF $GET(HLFS)'="^"
NEW HLFS
SET HLFS="^"
+20 ;Set type to 'SAD' if no value passed
if $GET(IVMZTYP)=""
SET IVMZTYP="SAD"
+21 ; initialize the IVMRTN variable with ZUD^ZUD Type
+22 SET IVMRTN="ZUD"
SET $PIECE(IVMRTN,HLFS,2)=$GET(IVMZCNT)
SET $PIECE(IVMRTN,HLFS,3)=IVMZTYP
+23 if '$GET(DFN)
QUIT IVMRTN
+24 SET IVMERR=""
+25 DO ZUDLOAD(IVMZTYP,.IVMERR)
if IVMERR'=""
QUIT IVMRTN
+26 ; If no date, do not send ZUD segment
+27 IF $GET(IVMADDT)=""
QUIT ""
+28 ; If no IVMADUSR, do not send ZUD segment
+29 IF $GET(IVMADUSR)=""
QUIT ""
+30 SET $PIECE(IVMRTN,HLFS,4)=$GET(IVMADDT)
+31 SET $PIECE(IVMRTN,HLFS,5)=$GET(IVMADUSR)
+32 SET $PIECE(IVMRTN,HLFS,6)=$GET(IVMADIEN)
+33 ; IVMRTN variable will contain ZUD^IVMZCNT^ZUD Type^Change Dt/Tm^Username^DUZ
+34 QUIT IVMRTN
+35 ;
ADDRCNV(ADDRSRC) ;convert Address Source to HL7 format
+1 if $GET(ADDRSRC)']""
QUIT ""
+2 if ADDRSRC="HEC"
QUIT "USVAHEC"
+3 if ADDRSRC="VAMC"
QUIT "USVAMC"
+4 if ADDRSRC="HBSC"
QUIT "USVAHBSC"
+5 if ADDRSRC="NCOA"
QUIT "USNCOA"
+6 if ADDRSRC="BVA"
QUIT "USVABVA"
+7 if ADDRSRC="VAINS"
QUIT "USVAINS"
+8 if ADDRSRC="USPS"
QUIT "USPS"
+9 if ADDRSRC="LACS"
QUIT "LACS"
+10 if ADDRSRC="VET360"
QUIT "VET360"
+11 QUIT ""
+12 ;
RF1LOAD(RF1TYP) ;
+1 NEW RFDT,RFSRC,RFSIT,GETFLDS,RFDAT,ERR
+2 KILL ADRDT,ADRSRC,ADRSIT
+3 IF RF1TYP="SAD"
SET RFDT=.118
SET RFSRC=.119
SET RFSIT=.12
+4 ;IVM*2.0*215 - Send Change Site in RF1 segment by replacing Chagne User in RFSIT variable
+5 ;I RF1TYP="CAD" S RFDT=.14112,RFSRC="",RFSIT=.14118
+6 IF RF1TYP="CAD"
SET RFDT=.14112
SET RFSRC=""
SET RFSIT=.14113
+7 IF RF1TYP="CPH"
SET RFDT=.139
SET RFSRC=.1311
SET RFSIT=.13111
+8 IF RF1TYP="PNO"
SET RFDT=.1312
SET RFSRC=.1313
SET RFSIT=.1314
+9 IF RF1TYP="EAD"
SET RFDT=.136
SET RFSRC=.137
SET RFSIT=.138
+10 IF RF1TYP="PHH"
SET RFDT=.1321
SET RFSRC=.1322
SET RFSIT=.1323
+11 ; IVM*2.0*164 - Add Residential Address Change
+12 IF RF1TYP="RAD"
SET RFDT=.1158
SET RFSRC=.11582
SET RFSIT=.11581
+13 SET GETFLDS=RFDT
if RFSRC'=""
SET GETFLDS=GETFLDS_";"_RFSRC
SET GETFLDS=GETFLDS_";"_RFSIT
+14 DO GETS^DIQ(2,DFN_",",GETFLDS,"IE","RFDAT","ERR")
if $DATA(ERR)
QUIT
+15 SET ADRDT=$$FMTHL7^XLFDT($GET(RFDAT(2,DFN_",",RFDT,"I")))
+16 if RFSRC'=""
SET ADRSRC=$$EXTERNAL^DILFD(2,RFSRC,"",$GET(RFDAT(2,DFN_",",RFSRC,"I")))
+17 ; only populate Change Site if Source=VAMC or NO Source Field
+18 IF ($GET(ADRSRC)="VAMC")!(RFSRC="")
Begin DoDot:1
+19 SET ADRSIT=$GET(RFDAT(2,DFN_",",RFSIT,"I"))
+20 if ADRSIT]""
SET ADRSIT=$$GET1^DIQ(4,ADRSIT_",",99)
End DoDot:1
+21 ;convert source to HL7 format
SET ADRSRC=$$ADDRCNV($GET(ADRSRC))
+22 QUIT
ZUDLOAD(IVMZTYP,IVMERR) ;
+1 ; IVM*2.0*201 - Create ZUD segment
+2 ; Input
+3 ; IVMZTYP - ZUD Type
+4 ; IVMERR - Error message on failure (optional, pass by reference)
+5 ;
+6 NEW IVMZDT,IVMZUSR,IVMGFLDS,IVMZDAT
+7 SET IVMADDT=""
SET IVMADIEN=""
SET IVMADUSR=""
+8 IF IVMZTYP="SAD"
SET IVMZDT=.118
SET IVMZUSR=.122
+9 IF IVMZTYP="CAD"
SET IVMZDT=.14112
SET IVMZUSR=.14118
+10 IF IVMZTYP="RAD"
SET IVMZDT=.1158
SET IVMZUSR=.11583
+11 IF IVMZTYP="CPH"
SET IVMZDT=.139
SET IVMZUSR=.1319
+12 IF IVMZTYP="EAD"
SET IVMZDT=.136
SET IVMZUSR=.1318
+13 IF IVMZTYP="PHH"
SET IVMZDT=.1321
SET IVMZUSR=.1324
+14 IF IVMZTYP="PHB"
SET IVMZDT=.1326
SET IVMZUSR=.1325
+15 IF IVMZTYP="PHC"
SET IVMZDT=.14112
SET IVMZUSR=.14119
+16 SET IVMGFLDS=IVMZDT
SET IVMGFLDS=IVMGFLDS_";"_IVMZUSR
+17 DO GETS^DIQ(2,DFN_",",IVMGFLDS,"IE","IVMZDAT","IVMERR")
if IVMERR'=""
QUIT
+18 SET IVMADDT=$$FMTHL7^XLFDT($GET(IVMZDAT(2,DFN_",",IVMZDT,"I")))
+19 SET IVMADIEN=$GET(IVMZDAT(2,DFN_",",IVMZUSR,"I"))
+20 SET IVMADUSR=$$EXTERNAL^DILFD(2,IVMZUSR,"",IVMADIEN)
+21 ; If no username, or for some specific user names, blank out the username and DUZ
+22 IF ((IVMADUSR="")!(IVMADUSR="POSTMASTER")!(IVMADUSR="PSUSER,APPLICATION PROXY")!(IVMADUSR="PSOAPPLICATIONPROXY,PSO"))
Begin DoDot:1
+23 SET IVMADUSR=""
SET IVMADIEN=""
End DoDot:1
+24 IF '$TEST
Begin DoDot:1
+25 SET IVMADUSR=$PIECE(IVMADUSR,",")_"~"_$PIECE(IVMADUSR,",",2)
+26 SET IVMADUSR=$PIECE(IVMADUSR," ")_"~"_$PIECE(IVMADUSR," ",2)_"~"_$PIECE(IVMADUSR," ",3)
End DoDot:1
+27 QUIT
