Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IVMPTRNA

IVMPTRNA.m

Go to the documentation of this file.
  1. 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
  1. ;Per VHA Directive 2004-038, this routine should not be modified.
  1. ;
  1. Q
  1. NTROBX(DGNTARR) ;
  1. N NTRTEMP,I,CS,RS,SS
  1. I $G(HLECH)'="~|\&" N HLECH S HLECH="~|\&"
  1. I $G(HLFS)'="^" N HLFS S HLFS="^"
  1. S CS=$E(HLECH,1),SS=$E(HLECH,4),RS=$E(HLECH,2)
  1. S NTRTEMP("NTR","Y")="1"_CS_"Received NTR Trmt"_CS_"VA0053"
  1. S NTRTEMP("AVI","Y")="2"_CS_"Aviator Pre 1955"_CS_"VA0053"
  1. S NTRTEMP("SUB","Y")="3"_CS_"Sub Trainee pre 1965"_CS_"VA0053"
  1. S NTRTEMP("HNC","Y")="4"_CS_"Dx With Head Neck Cancer"_CS_"VA0053"
  1. S NTRTEMP("NTR","N")="5"_CS_"No NTR Trmt"_CS_"VA0053"
  1. S NTRTEMP("AVI","N")="6"_CS_"Not Aviator Pre 1955"_CS_"VA0053"
  1. S NTRTEMP("SUB","N")="7"_CS_"Not Sub Trainee pre 1965"_CS_"VA0053"
  1. S NTRTEMP("HNC","N")="8"_CS_"Not Dx With Head Neck Cancer"_CS_"VA0053"
  1. S NTRTEMP("NTR","U")="9"_CS_"NTR Trmt Unknown"_CS_"VA0053"
  1. S NTRTEMP("VER","M")="M"_CS_"Military Med Rec"_CS_"VA0052"
  1. S NTRTEMP("VER","S")="S"_CS_"Qual Military Srvc"_CS_"VA0052"
  1. S NTRTEMP("VER","N")="N"_CS_"Not Qualified"_CS_"VA0052"
  1. S NTROBX(2)="CE",NTROBX(3)="VISTA"_CS_"28.11"
  1. S NTROBX(5)=""
  1. F I="NTR","AVI","SUB","HNC" D
  1. . I $G(DGNTARR(I))="" Q
  1. . I NTROBX(5)'="" S NTROBX(5)=$G(NTROBX(5))_RS
  1. . S NTROBX(5)=$G(NTROBX(5))_$G(NTRTEMP(I,$G(DGNTARR(I))))
  1. S NTROBX(11)="F"
  1. S NTROBX(12)=$G(DGNTARR("HDT"))
  1. S NTROBX(14)=$G(DGNTARR("VDT"))
  1. I $G(DGNTARR("VSIT"))'="" D
  1. . S NTROBX(15)=$P($G(^DIC(4,DGNTARR("VSIT"),99)),"^")
  1. S NTROBX(16)=""
  1. I $G(DGNTARR("HSIT"))'="" D
  1. . S $P(NTROBX(16),CS,14)=SS_$P($G(^DIC(4,DGNTARR("HSIT"),99)),"^")
  1. I $G(DGNTARR("VER"))'="" S NTROBX(17)=$G(NTRTEMP("VER",$G(DGNTARR("VER"))))
  1. Q
  1. RF1(DFN,RF1TYP) ; create RF1 segment
  1. ; Input:
  1. ; DFN - Patient IEN
  1. ; RF1TYP - RF1 Type
  1. ; SAD = Street Address Change (Default)
  1. ; CAD = Confidential Address Change
  1. ; CPH = Cell Phone Number Change
  1. ; PNO = Pager Number Change
  1. ; EAD = E-Mail Address Change
  1. ; PHH = Home Phone Number Change
  1. ; RAD Residential Address Change
  1. ;
  1. ; Output: RF1 segment
  1. ;
  1. N X,Y,ADDRSRC,ADRSRC,ADRSIT,ADTDT,I,CS,RS,SS,HLQ,RETURN,RFDAT,ERR
  1. I $G(HLECH)'="~|\&" N HLECH S HLECH="~|\&"
  1. I $G(HLFS)'="^" N HLFS S HLFS="^"
  1. S CS=$E(HLECH,1),SS=$E(HLECH,4),RS=$E(HLECH,2),HLQ=""""
  1. S:$G(RF1TYP)="" RF1TYP="SAD" ;Set type to 'SAD' if no value passed
  1. ; initialize the RETURN variable
  1. S RETURN="RF1",$P(RETURN,HLFS,4)=RF1TYP,$P(RETURN,HLFS,11)=""
  1. Q:'$G(DFN) RETURN
  1. ;I RF1TYP="SAD",$$BADADR^DGUTL3(DFN) Q RETURN
  1. D RF1LOAD(RF1TYP) Q:$D(ERR) RETURN
  1. I RF1TYP'="SAD",$G(ADRDT)="" Q ""
  1. ; RF1 SEQ 1-2 are not currently used
  1. ; RF1 SEQ 3
  1. S $P(RETURN,HLFS,4)=RF1TYP
  1. ; RF1 SEQ 4-5 are not currently used
  1. ; RF1 SEQ 6
  1. S $P(RETURN,HLFS,7)=$G(ADRSIT)
  1. S:$G(ADRSRC)'="" $P(RETURN,HLFS,7)=$P(RETURN,HLFS,7)_CS_ADRSRC
  1. ; RF1 SEQ 7
  1. S $P(RETURN,HLFS,8)=$G(ADRDT)
  1. ; RF1 SEQ 8-11 are not currently used
  1. ; quit with completed RF1 segment
  1. Q RETURN
  1. ;
  1. ZUD(DFN,IVMZTYP,IVMZCNT) ; create ZUD segment
  1. ; IVM*2.0*201 - Send Originating Source and User information to ES
  1. ; Input:
  1. ; DFN - Patient IEN
  1. ; IVMZTYP - ZUD Type
  1. ; SAD = Street Address Change (Default)
  1. ; CAD = Confidential Address Change
  1. ; CPH = Cell Phone Number Change
  1. ; EAD = E-Mail Address Change
  1. ; PHH = Home Phone Number Change
  1. ; RAD Residential Address Change
  1. ; PHB Business Phone Number Change
  1. ; PHC Confidential Phone Number Change
  1. ; IVMZCNT - Sequence number of ZUD segment
  1. ;
  1. ; Output: ZUD segment (ZUD^IVMZCNT^ZUD Type^Change Dt/Tm^Username^DUZ)
  1. ;
  1. N IVMADDT,IVMRTN,IVMERR,IVMADIEN,IVMADUSR
  1. I $G(HLECH)'="~|\&" N HLECH S HLECH="~|\&"
  1. I $G(HLFS)'="^" N HLFS S HLFS="^"
  1. S:$G(IVMZTYP)="" IVMZTYP="SAD" ;Set type to 'SAD' if no value passed
  1. ; initialize the IVMRTN variable with ZUD^ZUD Type
  1. S IVMRTN="ZUD",$P(IVMRTN,HLFS,2)=$G(IVMZCNT),$P(IVMRTN,HLFS,3)=IVMZTYP
  1. Q:'$G(DFN) IVMRTN
  1. S IVMERR=""
  1. D ZUDLOAD(IVMZTYP,.IVMERR) Q:IVMERR'="" IVMRTN
  1. ; If no date, do not send ZUD segment
  1. I $G(IVMADDT)="" Q ""
  1. ; If no IVMADUSR, do not send ZUD segment
  1. I $G(IVMADUSR)="" Q ""
  1. S $P(IVMRTN,HLFS,4)=$G(IVMADDT)
  1. S $P(IVMRTN,HLFS,5)=$G(IVMADUSR)
  1. S $P(IVMRTN,HLFS,6)=$G(IVMADIEN)
  1. ; IVMRTN variable will contain ZUD^IVMZCNT^ZUD Type^Change Dt/Tm^Username^DUZ
  1. Q IVMRTN
  1. ;
  1. ADDRCNV(ADDRSRC) ;convert Address Source to HL7 format
  1. Q:$G(ADDRSRC)']"" ""
  1. Q:ADDRSRC="HEC" "USVAHEC"
  1. Q:ADDRSRC="VAMC" "USVAMC"
  1. Q:ADDRSRC="HBSC" "USVAHBSC"
  1. Q:ADDRSRC="NCOA" "USNCOA"
  1. Q:ADDRSRC="BVA" "USVABVA"
  1. Q:ADDRSRC="VAINS" "USVAINS"
  1. Q:ADDRSRC="USPS" "USPS"
  1. Q:ADDRSRC="LACS" "LACS"
  1. Q:ADDRSRC="VET360" "VET360"
  1. Q ""
  1. ;
  1. RF1LOAD(RF1TYP) ;
  1. N RFDT,RFSRC,RFSIT,GETFLDS,RFDAT,ERR
  1. K ADRDT,ADRSRC,ADRSIT
  1. I RF1TYP="SAD" S RFDT=.118,RFSRC=.119,RFSIT=.12
  1. ;IVM*2.0*215 - Send Change Site in RF1 segment by replacing Chagne User in RFSIT variable
  1. ;I RF1TYP="CAD" S RFDT=.14112,RFSRC="",RFSIT=.14118
  1. I RF1TYP="CAD" S RFDT=.14112,RFSRC="",RFSIT=.14113
  1. I RF1TYP="CPH" S RFDT=.139,RFSRC=.1311,RFSIT=.13111
  1. I RF1TYP="PNO" S RFDT=.1312,RFSRC=.1313,RFSIT=.1314
  1. I RF1TYP="EAD" S RFDT=.136,RFSRC=.137,RFSIT=.138
  1. I RF1TYP="PHH" S RFDT=.1321,RFSRC=.1322,RFSIT=.1323
  1. ; IVM*2.0*164 - Add Residential Address Change
  1. I RF1TYP="RAD" S RFDT=.1158,RFSRC=.11582,RFSIT=.11581
  1. S GETFLDS=RFDT S:RFSRC'="" GETFLDS=GETFLDS_";"_RFSRC S GETFLDS=GETFLDS_";"_RFSIT
  1. D GETS^DIQ(2,DFN_",",GETFLDS,"IE","RFDAT","ERR") Q:$D(ERR)
  1. S ADRDT=$$FMTHL7^XLFDT($G(RFDAT(2,DFN_",",RFDT,"I")))
  1. S:RFSRC'="" ADRSRC=$$EXTERNAL^DILFD(2,RFSRC,"",$G(RFDAT(2,DFN_",",RFSRC,"I")))
  1. ; only populate Change Site if Source=VAMC or NO Source Field
  1. I ($G(ADRSRC)="VAMC")!(RFSRC="") D
  1. . S ADRSIT=$G(RFDAT(2,DFN_",",RFSIT,"I"))
  1. . S:ADRSIT]"" ADRSIT=$$GET1^DIQ(4,ADRSIT_",",99)
  1. S ADRSRC=$$ADDRCNV($G(ADRSRC)) ;convert source to HL7 format
  1. Q
  1. ZUDLOAD(IVMZTYP,IVMERR) ;
  1. ; IVM*2.0*201 - Create ZUD segment
  1. ; Input
  1. ; IVMZTYP - ZUD Type
  1. ; IVMERR - Error message on failure (optional, pass by reference)
  1. ;
  1. N IVMZDT,IVMZUSR,IVMGFLDS,IVMZDAT
  1. S IVMADDT="",IVMADIEN="",IVMADUSR=""
  1. I IVMZTYP="SAD" S IVMZDT=.118,IVMZUSR=.122
  1. I IVMZTYP="CAD" S IVMZDT=.14112,IVMZUSR=.14118
  1. I IVMZTYP="RAD" S IVMZDT=.1158,IVMZUSR=.11583
  1. I IVMZTYP="CPH" S IVMZDT=.139,IVMZUSR=.1319
  1. I IVMZTYP="EAD" S IVMZDT=.136,IVMZUSR=.1318
  1. I IVMZTYP="PHH" S IVMZDT=.1321,IVMZUSR=.1324
  1. I IVMZTYP="PHB" S IVMZDT=.1326,IVMZUSR=.1325
  1. I IVMZTYP="PHC" S IVMZDT=.14112,IVMZUSR=.14119
  1. S IVMGFLDS=IVMZDT S IVMGFLDS=IVMGFLDS_";"_IVMZUSR
  1. D GETS^DIQ(2,DFN_",",IVMGFLDS,"IE","IVMZDAT","IVMERR") Q:IVMERR'=""
  1. S IVMADDT=$$FMTHL7^XLFDT($G(IVMZDAT(2,DFN_",",IVMZDT,"I")))
  1. S IVMADIEN=$G(IVMZDAT(2,DFN_",",IVMZUSR,"I"))
  1. S IVMADUSR=$$EXTERNAL^DILFD(2,IVMZUSR,"",IVMADIEN)
  1. ; If no username, or for some specific user names, blank out the username and DUZ
  1. I ((IVMADUSR="")!(IVMADUSR="POSTMASTER")!(IVMADUSR="PSUSER,APPLICATION PROXY")!(IVMADUSR="PSOAPPLICATIONPROXY,PSO")) D
  1. . S IVMADUSR="",IVMADIEN=""
  1. E D
  1. . S IVMADUSR=$P(IVMADUSR,",")_"~"_$P(IVMADUSR,",",2)
  1. . S IVMADUSR=$P(IVMADUSR," ")_"~"_$P(IVMADUSR," ",2)_"~"_$P(IVMADUSR," ",3)
  1. Q