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

BYIMSEG1.m

Go to the documentation of this file. 
  1. BYIMSEG1 ;IHS/CIM/THL - IMMUNIZATION DATA EXCHANGE;
  1.  ;;2.0;BYIM IMMUNIZATION DATA EXCHANGE;**3,4,5,6,7,8,9**;JUL 11, 2017;Build 22
  1.  ;
  1.  ;this routine will contain code to supplement fields in the
  1.  ;HL7 segments
  1.  ;
  1. IN1MCARE ;MEDICARE IN1 SEGMENTS
  1.  ;PATCH 9 NMCI CHANGE MCR NUMBER
  1.  S INDA(1)=INDA
  1.  D IN1MCR17
  1.  D IN1MCR49
  1.  ;PATCH 9 END
  1.  Q
  1.  ;-----
  1. IN1MCR17 ;
  1.  S X="SEL^SELF^HL70063"
  1.  S INA("IN1MCR17")=X
  1.  S INA("IN1MCR17",1)=X
  1.  S INA("IN1MCR17",INDA)=X
  1.  S INA("IN1MCR17",INDA,1)=X
  1.  S INA("IN1MCR17",9000003,INDA)=X
  1.  S INA("IN1MCR17",9000003,INDA,1)=X
  1.  Q
  1.  ;-----
  1. IN1MCR49 ;
  1.  ;AUPN V99.1 PATCH 26 REQUIRED
  1.  S X=$$GETMCR^AGUTL(INDA,DT)
  1.  S INA("IN1MCR49")=X
  1.  S INA("IN1MCR49",1)=X
  1.  S INA("IN1MCR49",INDA)=X
  1.  S INA("IN1MCR49",INDA,1)=X
  1.  S INA("IN1MCR49",9000003,INDA)=X
  1.  S INA("IN1MCR49",9000003,INDA,1)=X
  1.  Q
  1.  ;-----
  1. IN1RRE ;RAILROAD IN1 SEGMENTS
  1.  ;PATCH 9 NMCI CHANGE MCR NUMBER
  1.  ;AUPN V99.1 PATCH 26 REQUIRED
  1.  S INDA(1)=INDA
  1.  D IN1RRE49
  1.  ;PATCH 9 END
  1.  Q
  1.  ;-----
  1. IN1RRE49 ;
  1.  ;AUPN V99.1 PATCH 26 REQUIRED
  1.  S X=$$GETRRE^AGUTL(INDA,DT)
  1.  S INA("IN1RRE49")=X
  1.  S INA("IN1RRE49",1)=X
  1.  S INA("IN1RRE49",INDA)=X
  1.  S INA("IN1RRE49",INDA,1)=X
  1.  S INA("IN1RRE49",9000003,INDA)=X
  1.  S INA("IN1RRE49",9000003,INDA,1)=X
  1.  Q
  1.  ;-----
  1. OBXCE ;EP;
  1.  D VSET^BYIMSEGS(INDA)
  1.  D OBXCE1
  1.  D OBXCE2
  1.  D OBXCE3
  1.  D OBXCE4
  1.  D OBXCE5
  1.  D OBXCE11
  1.  D OBXCE14
  1.  D OBXCE17
  1.  Q
  1.  ;-----
  1. OBXCE1 ;subid
  1.  S INA("OBXCE1",INDA)="1"
  1.  Q
  1.  ;-----
  1. OBXCE2 ;vt
  1.  S INA("OBXCE2",INDA)="CE"
  1.  Q
  1.  ;-----
  1. OBXCE3 ;od
  1.  S INA("OBXCE3",INDA)="64994-7"_CS_"funding eligibility for immunization"_CS_"LN"
  1.  Q
  1.  ;-----
  1. OBXCE4 ;osid
  1.  S INA("OBXCE4",INDA)="1"
  1.  Q
  1.  ;-----
  1. OBXCE5 ;ov
  1.  S INA("OBXCE5",INDA)=$$IVFC^BYIMIMM3(INDA)
  1.  Q
  1.  ;-----
  1. OBXCE11 ;abn
  1.  S INA("OBXCE11",INDA)="F"
  1.  Q
  1.  ;-----
  1. OBXCE14 ;edt
  1.  S INA("OBXCE14",INDA)=""
  1.  N X
  1.  S X=$P(X12,U)
  1.  S:'X X=$P(V0,U)
  1.  Q:'X
  1.  S INA("OBXCE14",INDA)=$E($$TIMEIO^INHUT10(X),1,8)
  1.  Q
  1.  ;-----
  1. OBXCE17 ;METHOD OF CAPTURE
  1.  S INA("OBXCE17",INDA)="VXC40"_CS_"per immunization"_CS_"CDCPHINVS"
  1. OBXCEEND Q
  1.  ;-----
  1.  ;-----
  1. OBXPR ;EP;VIS PRESENTED
  1.  D VSET^BYIMSEGS(INDA)
  1.  D OBXPR1
  1.  D OBXPR2
  1.  D OBXPR3
  1.  D OBXPR4
  1.  D OBXPR5
  1.  Q
  1.  ;-----
  1. OBXPR1 ;subid
  1.  S INA("OBXPR1",INDA)="5"
  1.  Q
  1.  ;-----
  1. OBXPR2 ;vt
  1.  S INA("OBXPR2",INDA)="TS"
  1.  Q
  1.  ;-----
  1. OBXPR3 ;od
  1.  S INA("OBXPR3",INDA)="29769-7"_CS_"Date vaccine information statement presented"_CS_"LN"
  1.  Q
  1.  ;-----
  1. OBXPR4 ;osid
  1.  S INA("OBXPR4",INDA)="2"
  1.  Q
  1.  ;-----
  1. OBXPR5 ;ov
  1.  N X
  1.  S X=""
  1.  S INA("OBXPR5",INDA)=""
  1.  S X=$P(V0,".")
  1.  S:X X=X+17000000
  1.  S INA("OBXPR5",INDA)=X
  1. OBXPREND Q
  1.  ;-----
  1.  ;-----
  1. OBXPB ;EP;VIS PUBLISHED
  1.  D VSET^BYIMSEGS(INDA)
  1.  D OBXPB1
  1.  D OBXPB2
  1.  D OBXPB3
  1.  D OBXPB4
  1.  D OBXPB5
  1.  Q
  1.  ;-----
  1. OBXPB1 ;subid
  1.  S INA("OBXPB1",INDA)="4"
  1.  Q
  1.  ;-----
  1. OBXPB2 ;vt
  1.  S INA("OBXPB2",INDA)="TS"
  1.  Q
  1.  ;-----
  1. OBXPB3 ;od
  1.  S INA("OBXPB3",INDA)="29768-9"_CS_"Date vaccine information statement published"_CS_"LN"
  1.  Q
  1.  ;-----
  1. OBXPB4 ;osid
  1.  S INA("OBXPB4",INDA)="2"
  1.  Q
  1.  ;-----
  1. OBXPB5 ;ov
  1.  N X,Y,Z
  1.  S PUB=""
  1.  S INA("OBXPB5",INDA)=""
  1.  D PUB(X0)
  1.  S:$L(PUB)=7 INA("OBXPB5",INDA)=PUB+17000000
  1. OBXPBEND Q
  1.  ;-----
  1.  ;-----
  1. REFUSAL(DFN,UIF) ;EP;TO CREATE REFUSAL RELATED SEGMENTS
  1.  ;DFN   = PATIENT DFN
  1.  ;UIF   = IEN FOR ^INTHU
  1.  Q:'$G(UIF)
  1.  D:$G(DFN) R1(DFN,UIF)
  1.  D:$G(DFN) V1(DFN,UIF)
  1.  D COMP(UIF)
  1.  Q
  1.  ;-----
  1. R1(DFN,UIF) ;EP;FIND PATIENT RELATED REFUSALS
  1.  ;DFN   = PATIENT DFN
  1.  ;UIF   = IEN FOR ^INTHU
  1.  ;N X,Y,Z
  1.  ;PATCH 7 - CHANGE VARIABLE 'X' TO 'REFX'
  1.  N REFX,Y,Z
  1.  S INDA=$O(INA("ORC1",9999999999),-1)
  1.  S REFX=0
  1.  F  S REFX=$O(^AUPNPREF("AC",DFN,REFX)) Q:'REFX  S X0=$G(^AUPNPREF(REFX,0)) D:+X0=3
  1.  .;PATCH 7 EXPAND QUIT LOGIC SO DOES NOT QUIT IF 'ALL' IMM'S
  1.  .;Q:$D(^BYIMEXP("REF",REFX))
  1.  .I $G(^BYIMEXP("REF",REFX)),$G(BYIMALL)'=2 Q
  1.  .Q:'$P(X0,U,6)
  1.  .Q:'$D(^AUTTIMM($P(X0,U,6),0))
  1.  .S INDA=INDA+1
  1.  .S Y="ORC|RE||9999^CDC|CR|"
  1.  .S LCT=+$O(^INTHU(UIF,3,9999999999),-1)+1
  1.  .S ^INTHU(UIF,3,LCT,0)=Y
  1.  .S V0=$P(X0,U,3)
  1.  .N CS
  1.  .S CS=U
  1.  .;PATCH 7 GET PAT REFUSAL DATE DIRECTLY
  1.  .S INA("RXA3",INDA)=$P($G(^AUPNPREF(REFX,0)),U,3)
  1.  .S:INA("RXA3",INDA)]"" INA("RXA3",INDA)=INA("RXA3",INDA)+17000000
  1.  .;D RXA3^BYIMSEGS
  1.  .;END CHANGE
  1.  .N IZDA
  1.  .S IZDA=+$P(X0,U,6)
  1.  .I '$D(^AUTTIMM(IZDA,0)) S IZDA=$P(X0,U,4) S:IZDA]"" IZDA=+$O(^AUTTIMM("B",IZDA,0))
  1.  .S Z0=$G(^AUTTIMM(IZDA,0))
  1.  .D RXA5^BYIMSEGS
  1.  .S Z=$S($P($G(^DPT(DFN,0)),U,3)<(DT-180000):"03^Patient decision",1:"00^Parental decision")_CS_"NIP002"
  1.  .S LCT=+$O(^INTHU(UIF,3,9999999999),-1)+1
  1.  .S ^INTHU(UIF,3,LCT,0)="RXA|0|1|"_INA("RXA3",INDA)_"||"_INA("RXA5",INDA)_"|999|||01^HISTORICAL INFORMATION - SOURCE UNSPECIFIED^NIP001|||||||||"_Z_"||RE|CR|"
  1.  .;PATCH 7 ADD IIS ID CODE FOR REFUSALS IF AVAILABLE
  1.  .S X=$P($G(^BYIMPARA($$DUZ^BYIMIMM(),5,$$DUZ^BYIMIMM(),0)),U,2)
  1.  .S:X="" X=$E($P($G(^DIC(4,+$G(^AUTTSITE(1,0)),0)),U),1,20)
  1.  .S X="^^^"_X
  1.  .S $P(^INTHU(UIF,3,LCT,0),"|",12)=X
  1.  .S:'$G(BYIMMU2)&'$G(BYIMTEST) ^BYIMEXP("REF",REFX)=DT
  1.  Q
  1.  ;-----
  1. V1(DFN,UIF) ;EP;DETERMINE VARICELLA EXPOSURE
  1.  ;DFN   = PATIENT DFN
  1.  ;UIF   = IEN FOR ^INTHU
  1.  Q:'$D(^BIPC("B",+DFN))
  1.  N VDAT,BIX,LCT,ORC,RXA,OBX
  1.  S VDAT=""
  1.  S BIX=0
  1.  F  S BIX=$O(^BIPC("B",DFN,BIX)) Q:'BIX  D:$P($G(^BIPC(BIX,0)),U,2)
  1.  .I $G(^BYIMEXP("HXV",BIX)),$G(BYIMALL)'=2 Q
  1.  .;PATCH 7
  1.  .;FILTER OUT NON-CONTRAINDICATION ENTRIES
  1.  .Q:"^11^13^16^17^18^"[(U_$P($G(^BIPC(BIX,0)),U,3)_U)
  1.  .S IMM=$P($G(^BIPC(BIX,0)),U,2)
  1.  .S VDAT=$P(^BIPC(BIX,0),U,4)
  1.  .Q:$L(VDAT)'=7
  1.  .S:'$G(BYIMMU2) ^BYIMEXP("HXV",BIX)=VDAT
  1.  .S LCT=+$O(^INTHU(UIF,3,9999999999),-1)+1
  1.  .S VDAT=VDAT+17000000
  1.  .S ORC="ORC|RE||9999^CDC|CR|"
  1.  .S RXA="RXA|0|1|"_VDAT_"|"_VDAT_"|998^No vaccine administered^CVX|999|"
  1.  .S $P(RXA,"|",21)="NA|CR|"
  1.  .N X
  1.  .S X=$G(^BYIMCON(IMM,0))
  1.  .I X="" S OBX="OBX|1|CE|30945-0^Vaccination contraindication/precaution^LN|1|00000000^Reason not recorded^SCT||||||F|CR|"
  1.  .I X]"" S OBX="OBX|1|CE|30945-0^Vaccination contraindication/precaution^LN|1|"_$P(X,U,2)_U_$P(X,U,3)_"^SCT||||||F|CR|"
  1.  .S ^INTHU(UIF,3,LCT,0)=ORC
  1.  .S LCT=+$O(^INTHU(UIF,3,9999999999),-1)+1
  1.  .S ^INTHU(UIF,3,LCT,0)=RXA
  1.  .S LCT=+$O(^INTHU(UIF,3,9999999999),-1)+1
  1.  .S ^INTHU(UIF,3,LCT,0)=OBX
  1.  Q
  1.  ;-----
  1. COMP(UIF) ;EP;REFORMAT MESSAGE PRIOR TO TRANSMISSION
  1.  ;UIF   = IEN FOR ^INTHU
  1.  N X,Y,Z,CNT
  1.  K ^BYIMTMP("UIF",UIF)
  1.  S CNT=0
  1.  S XX=0
  1.  F  S XX=$O(^INTHU(UIF,3,XX)) Q:'XX  S X=^(XX,0) D
  1.  .S CNT=$O(^BYIMTMP("UIF",UIF,3,9999999999),-1)+1
  1.  .S ^BYIMTMP("UIF",UIF,3,CNT,0)=X
  1.  .Q:X'["ORC|"!($E(X,1,4)'?3U1"|")
  1.  .D NORC(UIF)
  1.  .D EVAL(UIF)
  1.  K ^INTHU(UIF,3)
  1.  S X=0
  1.  F  S X=$O(^BYIMTMP("UIF",UIF,3,X)) Q:'X  S Y=^(X,0) S:Y]"" ^INTHU(UIF,3,X,0)=Y
  1.  K ^BYIMTMP("UIF",UIF)
  1.  Q
  1.  ;-----
  1.  ;-----
  1. NORC(UIF) ;FIND NEXT ORC
  1.  N X,Y,Z
  1.  S J=XX+1
  1.  S X=XX
  1.  F  S X=$O(^INTHU(UIF,3,X)) Q:'X  I ^(X,0)["ORC|" S XX=X-1 Q
  1.  S:J>XX XX=$O(^INTHU(UIF,3,9999999999),-1)
  1.  Q
  1.  ;-----
  1. EVAL(UIF) ;EVAL FOR MULTIPLE VACCINE RXA'S
  1.  N X,Y,Z,HIST,CNT,RXA,CVX,CVXDA,NAM,OBXPR,OBXPU
  1.  S RXA=""
  1.  S OBXPR=""
  1.  S OBXPU=""
  1.  S HIST=0
  1.  F J=J:1:XX D
  1.  .S X2="",X=$G(^INTHU(UIF,3,J,0))
  1.  .I X'["|CR|",$G(^INTHU(UIF,3,J+1,0))["|CR|" S X2=^(0),J=J+1
  1.  .S CNT=$O(^BYIMTMP("UIF",UIF,3,9999999999),-1)+1
  1.  .D:$E(X,1,4)="RXA|"
  1.  ..S RXA=X
  1.  ..S HIST=+$P(RXA,"|",10)
  1.  .I 'HIST,X'["vaccine info" D
  1.  ..S ^BYIMTMP("UIF",UIF,3,CNT,0)=X
  1.  ..S:X2]"" CNT=CNT+1,^BYIMTMP("UIF",UIF,3,CNT,0)=X2,X2=""
  1.  .I HIST,"|MSH|PID|ORC|RXA|"[("|"_$E(X,1,3)_"|") D
  1.  ..S ^BYIMTMP("UIF",UIF,3,CNT,0)=X
  1.  ..S:X2]"" CNT=CNT+1,^BYIMTMP("UIF",UIF,3,CNT,0)=X2,X2=""
  1.  .S:X["present" OBXPR=$G(^INTHU(UIF,3,J,0))
  1.  .S:X["publish" OBXPU=$G(^INTHU(UIF,3,J,0))
  1.  Q:RXA=""
  1.  Q:HIST
  1.  Q:$P(RXA,"|",19)]""
  1.  S CVX=+$P(RXA,"|",6)
  1.  S CVXDA=+$O(^AUTTIMM("C",CVX,0))
  1.  S X=$G(^AUTTIMM(CVXDA,0))
  1.  ;PATCH 7 GET DIRECT PUB DATE
  1.  N ORPUB
  1.  S ORPUB=$P(X,U,13)
  1.  S CMP=$P($G(^AUTTIMM(CVXDA,0)),U,21,26)
  1.  I $L(CMP)>5 D E1(RXA,CMP) Q
  1.  S:$P($G(^BYIMNOS(CVXDA,0)),U,2) X=$G(^AUTTIMM(+$P(^(0),U,2),0))
  1.  S NAM=$P(X,U)
  1.  S CVX=+$P(X,U,3)
  1.  S CVXDA=+$O(^AUTTIMM("C",CVX,0))
  1.  S PUB=$P(X,U,13)
  1.  S:'PUB PUB=$P($G(^BYIMNOS(CVXDA,0)),U,3)
  1.  ;PATCH 7 USE DIRECT PUB DATE IF NOT GENERIC DEFAULT
  1.  S:'PUB PUB=ORPUB
  1.  D:$G(OBXPU)]""
  1.  .S $P(OBXPU,"|",6)=PUB+17000000
  1.  .S:OBXPU'["|CR|" OBXPU=OBXPU_"|CR|"
  1.  .S CNT=$O(^BYIMTMP("UIF",UIF,3,9999999999),-1)+1
  1.  .S ^BYIMTMP("UIF",UIF,3,CNT,0)=OBXPU
  1.  D:$G(OBXPR)]""
  1.  .S:OBXPR'["|CR|" OBXPR=OBXPR_"|CR|"
  1.  .S CNT=$O(^BYIMTMP("UIF",UIF,3,9999999999),-1)+1
  1.  .S ^BYIMTMP("UIF",UIF,3,CNT,0)=OBXPR
  1.  Q
  1.  ;-----
  1. E1(RXA,CMP) ;
  1.  N J,K,L,X,Y,Z,XX
  1.  S CNT=$O(^BYIMTMP("UIF",UIF,3,9999999999),-1)
  1.  S X=$G(^BYIMTMP("UIF",UIF,3,CNT,0))
  1.  I $E(X,1,9)="OBX|3|CE|" K ^BYIMTMP("UIF",UIF,3,CNT)
  1.  S K=2
  1.  S L=1
  1.  F J=1:1:6 S X=$P(CMP,U,J) D:X
  1.  .S:$P($G(^BYIMNOS(X,0)),U,2) X=$P(^(0),U,2),NOSPUB=$P(^(0),U,3)
  1.  .S X=$G(^AUTTIMM(X,0))
  1.  .S NAM=$P(X,U)
  1.  .S CVX=$P(X,U,3)
  1.  .S PUB=$P(X,U,13)
  1.  .I 'PUB,NOSPUB S PUB=NOSPUB
  1.  .S K=K+1
  1.  .S L=L+1
  1.  .S X="OBX|"_K_"|"
  1.  .S $P(X,"|",3)="CE"
  1.  .S $P(X,"|",4)="30956-7"_U_"vaccine type"_U_"LN"
  1.  .S $P(X,"|",5)=L
  1.  .S $P(X,"|",6)=(CVX_U_NAM_U_"CVX")
  1.  .S $P(X,"|",12)="F"
  1.  .S CNT=$O(^BYIMTMP("UIF",UIF,3,9999999999),-1)+1
  1.  .S ^BYIMTMP("UIF",UIF,3,CNT,0)=X_"|CR|"
  1.  .S K=K+1
  1.  .S $P(OBXPU,"|",2)=K
  1.  .S $P(OBXPU,"|",5)=L
  1.  .S $P(OBXPU,"|",6)=PUB+17000000
  1.  .S $P(OBXPU,"|",12)="F"
  1.  .S CNT=$O(^BYIMTMP("UIF",UIF,3,9999999999),-1)+1
  1.  .S ^BYIMTMP("UIF",UIF,3,CNT,0)=OBXPU
  1.  .S K=K+1
  1.  .S $P(OBXPR,"|",2)=K
  1.  .S $P(OBXPR,"|",5)=L
  1.  .S $P(OBXPR,"|",12)="F"
  1.  .S CNT=$O(^BYIMTMP("UIF",UIF,3,9999999999),-1)+1
  1.  .S ^BYIMTMP("UIF",UIF,3,CNT,0)=OBXPR
  1.  Q
  1.  ;-----
  1.  ;-----
  1. OBXTY ;EP;
  1.  D VSET^BYIMSEGS(INDA)
  1.  D OBXTY1
  1.  D OBXTY2
  1.  D OBXTY3
  1.  D OBXTY4
  1.  D OBXTY5
  1.  D OBXTY11
  1.  Q
  1.  ;-----
  1. OBXTY1 ;subid
  1.  S INA("OBXTY1",INDA)="3"
  1.  Q
  1.  ;-----
  1. OBXTY2 ;vt
  1.  S INA("OBXTY2",INDA)="CE"
  1.  Q
  1.  ;-----
  1. OBXTY3 ;od
  1.  S INA("OBXTY3",INDA)="30956-7"_CS_"vaccine type"_CS_"LN"
  1.  Q
  1.  ;-----
  1. OBXTY4 ;osid
  1.  S INA("OBXTY4",INDA)="2"
  1.  Q
  1.  ;-----
  1. OBXTY5 ;ov
  1.  N X
  1.  S CVX=$P(Z0,U,3)
  1.  S IDA=+$O(^AUTTIMM("C",+CVX,0))
  1.  S:$P($G(^BYIMNOS(IDA,0)),U,2) IDA=$P(^(0),U,2)
  1.  S X=$G(^AUTTIMM(IDA,0))
  1.  S CVX=$P(X,U,3)
  1.  S:$L(CVX)=1 CVX="0"_CVX
  1.  S INA("OBXTY5",INDA)=CVX_CS_$P(X,U)_CS_"CVX"
  1.  Q
  1.  ;-----
  1. OBXTY11 ;abn
  1.  S INA("OBXTY11",INDA)="F"
  1.  Q
  1.  ;-----
  1. OBXTYEND Q
  1.  ;-----
  1.  ;-----
  1. QRF ;EP;main QRF routine driver
  1.  S INA("INQWHICH")="ANY"
  1.  D QRF1
  1.  D QRF2
  1.  D QRF3
  1.  D QRF5
  1.  Q
  1.  ;-----
  1. QRF1 ;
  1.  S INA("QRF1")=$P($G(^DIC(4,$$DUZ^BYIMIMM(),0)),U)
  1.  Q
  1. QRF2 ;
  1.  S INA("QRF2")=""
  1.  Q
  1.  ;-----
  1. QRF3 ;
  1.  ;S INA("INQEDTM")=$G(INA("QEDT"))
  1.  S INA("QRF3")=""
  1.  Q
  1.  ;-----
  1. QRF5 ;build the other query subject filter
  1.  N BYIMDA,BYIMSSN,BYIMDOB,BYIMBST,BYIMBCN,BYIMMCN,BYIMMNM,BYIMMMN,BYIMMSSN,BYIMFNM
  1.  S BYIMDA=$O(INA("QNM",0))
  1.  Q:'BYIMDA
  1.  N X,Y,Z,X0,X24
  1.  S X0=$G(^DPT(BYIMDA,0))
  1.  Q:X0=""
  1.  S BYIMSSN=$TR($P(X0,U,9),"-")
  1.  S BYIMDOB=$P(X0,U,3)+17000000
  1.  S BYIMBST=$P($G(^DIC(5,+$P(X0,U,12),0)),U,2)
  1.  S BYIMBCN=$P($G(^AUPNPAT(BYIMDA,11)),U,5)
  1.  S BYIMMCN=""
  1.  S BYIMMNM=""
  1.  S BYIMMMN=""
  1.  S BYIMMSSN=""
  1.  S BYIMFNM=""
  1.  S X24=$G(^DPT(BYIMDA,.24))
  1.  S X=$P(X24,U,2)
  1.  S:X]"" BYIMMNM=$$QRFNAME(X)
  1.  S X=$P(X24,U,3)
  1.  S:X]"" BYIMMMN=$$QRFNAME(X)
  1.  S X=$P(X24,U)
  1.  S:X]"" BYIMFNM=$$QRFNAME(X)
  1.  S BYIMFSSN=""
  1.  S INA("QRF5")=BYIMSSN_RS_BYIMDOB_RS_BYIMBST_RS_BYIMBCN_RS_BYIMMCN_RS_BYIMMNM_RS_BYIMMMN_RS_BYIMMSSN_RS_BYIMFNM_RS_BYIMFSSN
  1.  Q
  1.  ;-----
  1. QRFNAME(NAME) ;FORMAT NAME
  1.  Q:NAME="" ""
  1.  S X=$P(NAME,",")_U_$P($P(NAME,",",2)," ")
  1.  S:NAME[" " X=X_U_$P(NAME," ",2)
  1.  Q X
  1. QRFEND Q
  1.  ;-----
  1.  ;-----
  1. FHS ;EP;
  1.  Q
  1.  ;-----
  1. PUB(X0) ;FIND PUB DATE
  1.  S PUB=$P(X0,U,12)
  1.  Q:$L(PUB)=7
  1.  S IDA=+X0
  1.  Q:'IDA
  1.  S BYIMNOS=$G(^BYIMNOS(IDA,0))
  1.  ;PATCH 7 GET DIRECT PUB DATE IF NOS NOT DEFINED
  1.  ;Q:'BYIMNOS
  1.  I 'BYIMNOS S PUB=$P($G(^AUTTIMM(IDA,0)),U,13) Q
  1.  S NOSDA=+$P(BYIMNOS,U,2)
  1.  S PUB=$P(BYIMNOS,U,3)
  1.  ;S:NOSDA=IDA PUB=$P(X0,U,12)
  1.  I 'PUB,NOSDA S PUB=$P($G(^AUTTIMM(NOSDA,0)),U,13)
  1.  ;I 'PUB,NOSPUB S PUB=NOSPUB
  1.  Q
  1. OBXFS ;EP;
  1.  ;PATCH 6 TO INCLUDE FUNDING SOURCE OBX SEGMENT
  1.  D VSET^BYIMSEGS(INDA)
  1.  D OBXFS1
  1.  D OBXFS2
  1.  D OBXFS3
  1.  D OBXFS4
  1.  D OBXFS5
  1.  D OBXFS11
  1.  D OBXFS14
  1.  Q
  1.  ;-----
  1. OBXFS1 ;subid
  1.  S INA("OBXFS1",INDA)="2"
  1.  Q
  1.  ;-----
  1. OBXFS2 ;vt
  1.  S INA("OBXFS2",INDA)="CE"
  1.  Q
  1.  ;-----
  1. OBXFS3 ;od
  1.  S INA("OBXFS3",INDA)="30963-3"_CS_"funding source for immunization"_CS_"LN"
  1.  Q
  1.  ;-----
  1. OBXFS4 ;osid
  1.  S INA("OBXFS4",INDA)="1"
  1.  Q
  1.  ;-----
  1. OBXFS5 ;ov
  1.  S INA("OBXFS5",INDA)=$$IVFS^BYIMIMM3(INDA)
  1.  Q
  1.  ;-----
  1. OBXFS11 ;abn
  1.  S INA("OBXFS11",INDA)="F"
  1.  Q
  1.  ;-----
  1. OBXFS14 ;edt
  1.  S INA("OBXFS14",INDA)=""
  1.  N X
  1.  S X=$P(X12,U)
  1.  S:'X X=$P(V0,U)
  1.  Q:'X
  1.  S INA("OBXFS14",INDA)=$E($$TIMEIO^INHUT10(X),1,8)
  1.  Q
  1.  ;-----
  1. OBXFSEND Q
  1.  ;-----
  1.  ;-----
  1. RXR ;EP;
  1.  D RXR1
  1.  D RXR2
  1.  Q
  1.  ;-----
  1. RXR1 ;
  1.  S INA("RXR1",INDA)=""
  1.  N X,R
  1.  D VSET^BYIMSEGS(INDA)
  1.  S X=$P(X0,U,9)
  1.  Q:X=""
  1.  S R=$E(X,$L(X))
  1.  ;PATCH 7 CORRECT IN TO NASAL
  1.  ;S:X="O" R="O"
  1.  S:X="IN" R="N"
  1.  Q:"IDNOS"'[R
  1.  S:R="I" X="IM"_CS_"Intramuscular"
  1.  S:R="D" X="ID"_CS_"Intradermal"
  1.  S:R="N" X="NS"_CS_"Nasal"
  1.  S:R="O" X="PO"_CS_"Oral"
  1.  S:R="S" X="SC"_CS_"Subcutaneous"
  1.  S INA("RXR1",INDA)=X_CS_"HL70162"
  1.  Q
  1.  ;-----
  1. RXR2 ;
  1.  S INA("RXR2",INDA)=""
  1.  N X,R
  1.  D VSET^BYIMSEGS(INDA)
  1.  S X=$P(X0,U,9)
  1.  Q:X=""
  1.  S R=$E(X,1,2)
  1.  ;PATCH 7 CORRECT SHIFT OF LI AND RI
  1.  ;S:R="LI" R="LA"
  1.  ;S:R="RI" R="RA"
  1.  Q:R="O"!(R="IN")
  1.  S:R="LT" X=R_CS_"Left Thigh"
  1.  S:R="LA" X=R_CS_"Left Arm"
  1.  S:R="LD" X=R_CS_"Left Deltoid"
  1.  S:R="LG" X=R_CS_"Left Gluteus Medius"
  1.  S:R="LL" X="LVL"_CS_"Left Vastus Lateralis"
  1.  S:R="LV" X="LVL"_CS_"Left Vastus Lateralis"
  1.  S:R="LI" X="LLFA"_CS_"Left Lower Forearm"
  1.  S:R="LL" X="LLFA"_CS_"Left Lower Forearm"
  1.  S:R="RA" X=R_CS_"Right Arm"
  1.  S:R="RT" X=R_CS_"Right Thigh"
  1.  S:R="RV" X="RVL"_CS_"Right Vastus Lateralis"
  1.  S:R="RG" X=R_CS_"Right Gluteous Medius"
  1.  S:R="RD" X=R_CS_"Right Deltoid"
  1.  S:R="RI" X="RLFA"_CS_"Right Lower Forearm"
  1.  S:R="RL" X="RLFA"_CS_"Right Lower Forearm"
  1.  S INA("RXR2",INDA)=X_CS_"HL70163"
  1. RXREND Q
  1.  ;-----
  1. PD1 ;EP;
  1.  D PD13
  1.  D PD111
  1.  D PD112
  1.  D PD113
  1.  D PD116
  1.  D PD117
  1.  D PD118
  1.  Q
  1.  ;-----
  1. PD13 ;PD1-3 variable - location
  1.  S INA("PD13",1)=$G(BYIM("PD13.1"))_CS_$G(BYIM("PD13.2"))_CS_$G(BYIM("PD13.3"))
  1.  Q
  1.  ;-----
  1. PD111 ;PD1-11 PUBLICITY
  1.  S INA("PD111",1)=$$PUB^BYIMIMM3(INDA)
  1.  Q
  1.  ;-----
  1. PD112 ;PD1-12
  1.  S INA("PD112",1)=$$PROT^BYIMIMM3(INDA)
  1.  Q
  1.  ;-----
  1. PD113 ;PD1-13
  1.  S INA("PD113",1)=$$PROTDT^BYIMIMM3(INDA)
  1.  S:INA("PD112",1)="" INA("PD113",1)=""
  1.  I INA("PD112",1)]"",INA("PD113",1)="" S INA("PD113",1)=DT+17000000
  1.  Q
  1.  ;-----
  1. PD116 ;PD1-16
  1.  ;PATCH 6 INCLUDE ACTIVE/INACTIVE STATUS
  1.  S X=$P($G(^BIP(INDA,0)),U,8)
  1.  S INA("PD116",1)=$S('X:"A",1:"I")
  1.  ;PATCH 6 INCLUDE ACTIVE/INACTIVE STATUS
  1.  Q
  1.  ;-----
  1. PD117 ;PD1-17
  1.  ;PATCH 6 INCLUDE ACTIVE/INACTIVE STATUS
  1.  S INA("PD117",1)=$$ACTDT^BYIMIMM3(INDA)
  1.  ;S:INA("PD117",1)="" INA("PD113",1)=DT+17000000
  1.  S:INA("PD117",1)="" INA("PD117",1)=DT+17000000
  1.  ;PATCH 6 INCLUDE ACTIVE/INACTIVE STATUS
  1.  Q
  1.  ;-----
  1. PD118 ;PD1-18
  1.  I INA("PD111",1)="" S INA("PD118",1)="" Q
  1.  S INA("PD118",1)=$$PUBDT^BYIMIMM3(INDA)
  1.  S:INA("PD118",1)="" INA("PD118",1)=DT+17000000
  1.  Q
  1.  ;-----
  1. PD1END Q