- 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 Feb 18, 2025@23:28:07 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