IBTRH8 ;ALB/JWS - HCSR Worklist - view 278 message in X12 format ;24-AUG-2015
;;2.0;INTEGRATED BILLING;**517**;21-MAR-94;Build 240
;;Per VA Directive 6402, this routine should not be modified.
;;
Q
EN ; display message in X12 format
; IBTRIEN = ien of file 356.22
; MSGTYPE = 217 or 215
; RR = 0 for request / inquiry, 1 for response
N X,MSGTYPE,RR,TD,TT,HL1,HL2,ADDR1,ADDR2,ADDR3,REQDATA,SITEIEN
N NODE0,OMSG,DFN,IEN312,INSNODE0,INSNODE3,IEN3553,IEN36,GNUM,PREL
N NODE2,NODE4,NODE5,NODE6,NODE7,NODE8,NODE9,NODE10,NODE17,NODE18,NODE19
N REQCAT,CERT,INPAT,EVNT,HL1,HL2,PAYID,PAYER,PNODE0,IDTYPE,RELINFO
N REQIEN,RMSH10,HLECH,HLFS,HLQ
K ^TMP($J,"IBTRH8")
S SITEIEN=$P($$SITE^VASITE(),U) I SITEIEN'>0 D ERROR Q
S NODE0=$G(^IBT(356.22,IBTRIEN,0)) I NODE0="" D ERROR Q
I $P(NODE0,U,12)="" D ERROR Q
S MSGTYPE=+$P(NODE0,"^",20),RR=0
I MSGTYPE=2 D I +OMSG=0 D ERROR Q
. S RR=1
. S OMSG=$P(NODE0,U,13)
. I OMSG D
.. S REQIEN=IBTRIEN,IBTRIEN=OMSG
.. S NODE0=$G(^IBT(356.22,OMSG,0))
.. S MSGTYPE=+$P(NODE0,U,20),RR=0,RMSH10=$P(NODE0,"^",12)
. Q
S DFN=+$P(NODE0,U,2)
I DFN'>0 D ERROR Q
S IEN312=+$P(NODE0,U,3)
I IEN312'>0 D ERROR Q
S INSNODE0=$G(^DPT(DFN,.312,IEN312,0)) ; 0-node in file 2.312
S INSNODE3=$G(^DPT(DFN,.312,IEN312,3)) ; 3-node in file 2.312
S IEN3553=+$P(INSNODE0,U,18) ; file 355.3 ien
S IEN36=+$P(INSNODE0,U)
I IEN36'>0 D ERROR Q
S GNUM=$S(IEN3553>0:$$GET1^DIQ(355.3,IEN3553_",",.04),1:"") ; group number
S PREL=$P($G(^DPT(DFN,.312,IEN312,4)),U,3) ; pat. relationship to insured
S NODE2=$G(^IBT(356.22,IBTRIEN,2))
S NODE4=$G(^IBT(356.22,IBTRIEN,4))
S NODE5=$G(^IBT(356.22,IBTRIEN,5))
S NODE6=$G(^IBT(356.22,IBTRIEN,6))
S NODE7=$G(^IBT(356.22,IBTRIEN,7))
S NODE8=$G(^IBT(356.22,IBTRIEN,8))
S NODE9=$G(^IBT(356.22,IBTRIEN,9))
S NODE10=$G(^IBT(356.22,IBTRIEN,10))
S NODE17=$G(^IBT(356.22,IBTRIEN,17))
S NODE18=$G(^IBT(356.22,IBTRIEN,18))
S NODE19=$G(^IBT(356.22,IBTRIEN,19))
S HLECH="^~\&",HLFS="|",HLQ=""""
S X="ST*278*0001*005010X"_$S(MSGTYPE=0:217,1:215) D SAVE(X)
S REQCAT=$$GET1^DIQ(356.001,+$P(NODE2,U)_",",.01) ; request category
S CERT=$$GET1^DIQ(356.002,+$P(NODE2,U,2)_",",.01) ; certification type code
S INPAT=$S($P(NODE0,U,4)="I":1,1:0) ; 1 if inpatient, 0 if outpatient
; determine event reason code
I 'MSGTYPE D
. I REQCAT'="IN" S EVNT="13" Q ; request category = "HS" (Health Services), "AR" (Admission), or "SC" (Specialty Care) -> event code = 13 (Request)
. I CERT=3 S EVNT="01" Q ; request category = "IN" (Individual) and certification type = 3 (Cancel) -> event code = 01 (Cancel)
. S EVNT=36 ; request category = "IN" (Individual) and certification type '= 3 (other than Cancel) -> event code = 36 (Authority To Deduct)
. Q
I MSGTYPE=1 S EVNT=28 ; 28 for 215 message
I RR=1 S EVNT=11 ; 11 for response messages
S X=$P(NODE0,U,15),(TD,TT)=""
I X'="" D H^%DTC I %H D YX^%DTC S TD=$S($E(X)=3:20,1:19)_$E(X,2,7),Y=$P(NODE0,U,15) D DD^%DT S TT=$TR($P(Y,"@",2),":","")
S X="BHT*0007*"_EVNT_"*"_$S(RR=1:$G(RMSH10),1:$P(NODE0,U,12))_"*"_TD_"*"_TT_$S(EVNT=36:"*RU",1:"") D SAVE(X)
S HL1=$G(HL1)+1
S X="HL*"_HL1_"**20*1" D SAVE(X)
I RR=1 D AAA^IBTRH8A("2000A")
S PAYID=""
S PAYER=+$$GET1^DIQ(36,IEN36_",",3.1,"I") ; file 365.12 ien
I PAYER'>0 D ERROR Q
S PNODE0=$G(^IBE(365.12,PAYER,0)),IDTYPE="PI"
S PAYID=$P(PNODE0,U,2) ; VA national id
; if no VA national id, try to get CMS national id
I PAYID="" S PAYID=$P(PNODE0,U,3),IDTYPE="XV"
; if still no id, bail out
I PAYID="" D ERROR Q
S RELINFO=$P(NODE2,U,16) ;UM09 Release of Information Code
; get HPID, relies on patch IB*2.0*519
; S $P(TMP,HLECH,3)=$$HPD^IBCNHUT1(IEN36)
;
S X="NM1*X3*2*"_$$GET1^DIQ(36,IEN36_",",.01)_"*****"_IDTYPE_"*"_PAYID D SAVE(X)
I RR=1 D PERR,AAA^IBTRH8A("2010A")
; HL - Requester Level Loop 2000B
S HL2=HL1,HL1=HL1+1
S X="HL*"_HL1_"*"_HL2_"*21*1" D SAVE(X)
S REQDATA=$$PRVDATA^IBTRHLO2(SITEIEN,4)
I $TR(REQDATA,U)="" D ERROR Q
S X="NM1*FA*2*"_$P(REQDATA,U)_"*****XX*"_$P(REQDATA,U,7) D SAVE(X)
I RR=1 D AAA^IBTRH8A("2010B")
S ADDR1=$P(REQDATA,U,2,3),ADDR2=$P(REQDATA,U,4,6)
S ADDR3=$P($$HLADDR^HLFNC(ADDR1,ADDR2),U,1,5)
I 'RR S X="N3*"_$P(ADDR3,"^") S:$P(ADDR3,"^",2)'="" X=X_"*"_$P(ADDR3,"^",2) D SAVE(X)
I 'RR S X="N4*"_$P(ADDR3,"^",3)_"*"_$P(ADDR3,"^",4)_"*"_$P(ADDR3,"^",5) D SAVE(X)
I 'RR D PER
D PRV
S HL2=HL1,HL1=HL1+1
S X="HL*"_HL1_"*"_HL2_"*22*1" D SAVE(X)
D NM1
I PREL'="18" D
.S HL2=HL1,HL1=HL1+1
.S X="HL*"_HL1_"*"_HL2_"*23*1" D SAVE(X)
.D NM12010D
.Q
S HL2=HL1,HL1=HL1+1
S X="HL*"_HL1_"*"_HL2_"*EV*"_$S($O(^IBT(356.22,IBTRIEN,16,0)):1,1:0) D SAVE(X) ; if line level procedure code sub HL seg, otherwise 0
D EVENT
D DISPLAY^IBTRH8A
I $D(REQIEN) S IBTRIEN=REQIEN
Q
;
PER ; create PER segment in loop 2010B
N CTD,COMMSTR,IEN200,NAME,NODE19,QUAL,TMP,VALUE,Z
S IEN200=+$P(NODE0,U,11) I IEN200'>0 Q
S NAME=$$GET1^DIQ(200,IEN200_",",.01) I NAME="" Q
S NODE19=$G(^IBT(356.22,IBTRIEN,19))
S COMMSTR="" F Z="20^2^19.01","21^3^19.02","22^4^19.03" D
. S QUAL=$P(NODE19,U,$P(Z,U,2)) I QUAL="" Q
. S QUAL=$$EXTERNAL^DILFD(356.22,$P(Z,U,3),,QUAL)
. S VALUE=$G(^IBT(356.22,IBTRIEN,$P(Z,U))) I VALUE="" Q
. I "^FX^HP^TE^WP^"[(U_QUAL_U) S VALUE=$$NOPUNCT^IBCEF(VALUE,1) ; strip punctuation if phone #
. S $P(TMP,U)=QUAL,$P(TMP,U,2)=VALUE
. S COMMSTR=$S(COMMSTR="":TMP,1:COMMSTR_U_TMP)
. Q
S X="PER*IC*"_NAME_"*"_$P(COMMSTR,U)_"*"_$P(COMMSTR,U,2)
I $P(COMMSTR,U,3)'="" S X=X_"*"_$P(COMMSTR,U,3)_"*"_$P(COMMSTR,U,4)
I $P(COMMSTR,U,5)'="" S X=X_"*"_$P(COMMSTR,U,5)_"*"_$P(COMMSTR,U,6)
D SAVE(X)
Q
;
PRV ; create PRV segment (X12: PRV, 2010B)
N PRD,TXNM
S TXNM=$P($$TAXORG^XUSTAX(SITEIEN),U) I TXNM="" Q
S X="PRV*PE*PXC*"_TXNM D SAVE(X)
Q
;
NM1 ; create NM1 segment (X12: NM1, 2010C)
N ADDR1,ADDR2,GT1,SID1,SIDSTR,NAME
S SID1=$P(INSNODE0,U,2) I SID1="" Q
S NAME=$P(INSNODE0,U,17) I NAME="" Q
;;S SID2=GNUM ; secondary subscriber id is a group number
S NAME=$$HLNAME^HLFNC(NAME)
S X="NM1*IL*1*"_$P(NAME,"^")_"*"_$P(NAME,"^",2)_"*"_$P(NAME,"^",3)_"**"_$P(NAME,"^",4)_"*MI*"_SID1 D SAVE(X)
I GNUM'="" S X="REF*6P*"_GNUM D SAVE(X)
I 'MSGTYPE,$P(INSNODE3,U,6)'="",$P(INSNODE3,U,8)'="" D
. S ADDR1=$P(INSNODE3,U,6,7),ADDR2=$P(INSNODE3,U,8,10)
. S ADDR3=$$HLADDR^HLFNC(ADDR1,ADDR2) ; subscriber address
. S X="N3*"_$P(ADDR3,"^") S:$P(ADDR3,"^",2)'="" X=X_"*"_$P(ADDR3,"^",2) D SAVE(X)
. S X="N4*"_$P(ADDR3,"^",3)_"*"_$P(ADDR3,"^",4)_"*"_$P(ADDR3,"^",5) D SAVE(X)
. Q
I RR D AAA^IBTRH8A("2010C")
S X="DMG*D8*"_$$HLDATE^HLFNC($P(INSNODE3,U)) ; subscriber dob
I 'MSGTYPE S X=X_"*"_$P(INSNODE3,U,12) ; subscriber sex
D SAVE(X)
I MSGTYPE Q
I PREL'="18" S PREL=$S(PREL="01":"01",PREL=19:19,1:"G8") ; relationship to insured
S X="INS*Y*18" D SAVE(X)
Q
;
NM12010D ; create NM1 segment, loop 2010D
N IDSTR,PID,TMP,VAFSTR
I GNUM="" Q
S VAFSTR="7,8,11,"
S PID=$$EN^VAFHLPID(DFN,VAFSTR)
S TMP=$P(PID,"|",12)
I $P(TMP,U,2)="""""" S $P(TMP,U,2)="",$P(PID,"|",12)=TMP
S X="NM1*QC*1*"_$P($P(PID,"|",6),"^")_"*"_$P($P(PID,"|",6),"^",2) S:$P($P(PID,"|",6),"^",3)'="" X=X_"*"_$P($P(PID,"|",6),"^",3) D SAVE(X)
S X="REF*EJ*"_GNUM D SAVE(X)
I 'MSGTYPE!RR D
. S X="N3*"_$P(TMP,"^") S:$P(TMP,"^",2)'="" X=X_"*"_$P(TMP,"^",2) D SAVE(X)
. S X="N4*"_$P(TMP,"^",3)_"*"_$P(TMP,"^",4)_"*"_$P(TMP,"^",5) D SAVE(X)
. Q
I RR D AAA^IBTRH8A("2010D")
S X="DMG*D8*"_$P(PID,"|",8) S:'MSGTYPE X=X_"*"_$P(PID,"|",9) D SAVE(X)
I MSGTYPE Q
S X="INS*N*"_PREL D SAVE(X)
Q
;
EVENT ; 2000E loop
; create G2R.PRB segment (G2R segment group)
N PRB,Z,TOT
I RR D AAA^IBTRH8A("2000E")
I CERT="" Q ; missing certification type code
S X="UM*"_REQCAT_"*"_CERT_"*"_$$GET1^DIQ(365.013,+$P(NODE2,U,3)_",",.01)
I $P(NODE2,U,4)'="" S X=X_"*"_$S($P(NODE2,U,4)="A":($P(NODE2,U,6)_$P(NODE2,U,7)),1:$$GET1^DIQ(353.1,+$P(NODE2,U,5)_",",.01))_":"_$P(NODE2,U,4)
E D I MSGTYPE Q
. I MSGTYPE D SAVE(X) Q
. S X=X_"*"
S X=X_"*"_$P(NODE2,U,8)_":"_$P(NODE2,U,9)_":"_$P(NODE2,U,10)_":"_$$GET1^DIQ(5,+$P(NODE2,U,11)_",",1)
S Z=$$GET1^DIQ(779.004,+$P(NODE2,U,12)_",",.01) I Z'="",Z'="USA" S X=X_":"_Z
S X=X_"*"_$P(NODE2,U,13)_"*"_$$GET1^DIQ(356.003,+$P(NODE2,U,14)_",",.01)_"*"_$$GET1^DIQ(356.004,+$P(NODE2,U,15)_",",.01)_"*"_$P(NODE2,U,16)_"*"_$$GET1^DIQ(356.005,+$P(NODE2,U,17)_",",.01) D SAVE(X)
I RR D HCR
D REF
D DTP
D HI
; for 217 request only
I 'MSGTYPE D
. D HSD,CRC
. I $TR(NODE18,U)'="" D CR1
. D CR2,CR5^IBTRH8A,CR6^IBTRH8A,PWK,MSG
D NM1^IBTRH8A
;
I '$O(^IBT(356.22,IBTRIEN,16,0)) Q
S HL2=HL1,HL1=HL1+1
S X="HL*"_HL1_"*"_HL2_"*SS*0" D SAVE(X)
D DETAIL^IBTRH8A
S TOT=$G(^TMP($J,"IBTRH8"))+1
S X="SE*"_TOT_"*0001" D SAVE(X)
Q
;
REF ; REF segment
I $P(NODE17,U)'="" S X="REF*BB*"_$P(NODE17,U) D SAVE(X) Q
I $P(NODE17,U,2)'="" S X="REF*NT*"_$P(NODE17,U,2) D SAVE(X) Q
Q
;
DTP ; create DTP segments
N DATA,Z,Z1
S Z=$P(NODE0,U,7) I Z'="" D
. S Z1="AAH" I INPAT,REQCAT="AR" S Z1="435"
. S DATA(Z1)=$S(Z["-":$$HLDATE^HLFNC($P($P(Z,"-"),"."))_"-"_$$HLDATE^HLFNC($P($P(Z,"-",2),".")),1:$$HLDATE^HLFNC($P(Z,"."))) ; admission / appointment date
. Q
S Z=$P(NODE2,U,18) I Z'="" S DATA("439")=$$HLDATE^HLFNC($P(Z,".")) ; accident date
I 'MSGTYPE D
. S Z=$P(NODE2,U,19) I Z'="" S DATA("484")=$$HLDATE^HLFNC($P(Z,".")) ; last menstrual period date
. S Z=$P(NODE2,U,20) I Z'="" S DATA("ABC")=$$HLDATE^HLFNC(Z) ; estimated DOB
. S Z=$P(NODE2,U,21) I Z'="" S DATA("431")=$$HLDATE^HLFNC(Z) ; illness date
. Q
; the following date is for "Admission Review" request category only
I INPAT,REQCAT="AR" S Z=$P(NODE2,U,22) S:Z'="" DATA("096")=$$HLDATE^HLFNC($P(Z,".")) ; discharge date
S Z="" F S Z=$O(DATA(Z)) Q:Z="" D
. S X="DTP*"_Z_"*D8*"_DATA(Z) D SAVE(X)
. Q
Q
;
HI ; create HI segments
N DG1,DIAG,NODE0,SEQ,Z
S (SEQ,Z)=0 F S Z=$O(^IBT(356.22,IBTRIEN,3,Z)) Q:Z'=+Z D
. S NODE0=$G(^IBT(356.22,IBTRIEN,3,Z,0)) I NODE0="" Q ; 0-node of sub-file 356.223
. S SEQ=SEQ+1 I SEQ>12 Q ; only allow up to 12 DG1 segments
. I MSGTYPE,SEQ>1 Q ; only allow 1 DG1 segment in 215 message
. S DIAG=$TR($$EXTERNAL^DILFD(356.223,.02,,$P(NODE0,U,2)),".") I DIAG="" Q ; invalid diagnosis code
. S DG1(SEQ)="*"_$$GET1^DIQ(356.006,+$P(NODE0,U)_",",.01)_":"_DIAG I 'MSGTYPE,$P(NODE0,U,3)'="" S DG1(SEQ)=DG1(SEQ)_":D8:"_$$HLDATE^HLFNC($P(NODE0,U,3))
. ;S DG1="DG1"_HLFS_SEQ_HLFS_HLFS_$$ENCHL7^IBCNEHLQ(DIAG)_HLFS_HLFS_$S('MSGTYPE:$$HLDATE^HLFNC($P(NODE0,U,3)),1:"")_HLFS_"W"
. Q
I '$O(DG1("")) Q
S X="HI"
S Z=0 F S Z=$O(DG1(Z)) Q:Z="" S X=X_DG1(Z)
D SAVE(X)
Q
;
HSD ; create HSD segment
N QUAL,VALUE,HSD,I
S QUAL=$$GET1^DIQ(365.016,+$P(NODE4,U)_",",.01)
S VALUE=$P(NODE4,U,2)
I QUAL'="",VALUE'="" S HSD(1)=QUAL,HSD(2)=VALUE ;ZHS.2=4.01, ZHS.3=4.02
S QUAL=$P(NODE4,U,3)
S VALUE=$P(NODE4,U,4)
I QUAL'="",VALUE'="" S HSD(3)=QUAL ;ZHS.4=4.03
I VALUE'="" S HSD(4)=VALUE ;ZHS.5=4.04
S QUAL=$$GET1^DIQ(365.015,+$P(NODE4,U,5)_",",.01)
S VALUE=$P(NODE4,U,6)
I QUAL'="",VALUE'="" S HSD(5)=QUAL,HSD(6)=VALUE ;ZHS.6=4.05, ZHS.7=4.06
I +$P(NODE4,U,7) S HSD(7)=$$GET1^DIQ(365.025,+$P(NODE4,U,7)_",",.01) ;ZHS.8=4.07
I +$P(NODE4,U,8) S HSD(8)=$$GET1^DIQ(356.007,+$P(NODE4,U,8)_",",.01) ;ZHS.9=4.08
I '$D(HSD) Q
S X="HSD" F I=1:1:8 S X=X_"*"_$G(HSD(I))
D SAVE(X)
Q
;
CRC ; create CRC and CL1 segments in loop 2000E
N PC,Z
I +$P(NODE4,U,10) D ; at least one ambulance cert. condition exists
. S X="CRC*07*"_$P(NODE4,U,9)
. F PC=10:1:14 S Z=+$P(NODE4,U,PC) I Z S X=X_"*"_$$GET1^DIQ(356.008,Z_",",.01)
. D SAVE(X)
. Q
I +$P(NODE5,U,2) D ; at least one chiropractic cert. condition exists
. S X="CRC*08*"_$P(NODE5,U)
. F PC=2:1:6 S Z=+$P(NODE5,U,PC) I Z S X=X_"*"_$$GET1^DIQ(356.008,Z_",",.01)
. D SAVE(X)
. Q
I +$P(NODE5,U,8) D ; at least one DME cert. condition exists
. S X="CRC*09*"_$P(NODE5,U,7)
. F PC=8:1:12 S Z=+$P(NODE5,U,PC) I Z S X=X_"*"_$$GET1^DIQ(356.008,Z_",",.01)
. D SAVE(X)
. Q
I +$P(NODE5,U,14) D ; at least one oxygen cert. condition exists
. S X="CRC*11*"_$P(NODE5,U,13)
. F PC=14:1:18 S Z=+$P(NODE5,U,PC) I Z S X=X_"*"_$$GET1^DIQ(356.008,Z_",",.01)
. D SAVE(X)
. Q
I +$P(NODE6,U,2) D ; at least one functional limit cert. condition exists
. S X="CRC*75*"_$P(NODE6,U)
. F PC=2:1:6 S Z=+$P(NODE6,U,PC) I Z S X=X_"*"_$$GET1^DIQ(356.008,Z_",",.01)
. D SAVE(X)
. Q
I +$P(NODE6,U,8) D ; at least one activities cert. condition exists
. S X="CRC*76*"_$P(NODE6,U,7)
. F PC=8:1:12 S Z=+$P(NODE6,U,PC) I Z S X=X_"*"_$$GET1^DIQ(356.008,Z_",",.01)
. D SAVE(X)
. Q
I +$P(NODE6,U,14) D ; at least one mental status cert. condition exists
. S X="CRC*77*"_$P(NODE6,U,13)
. F PC=14:1:18 S Z=+$P(NODE6,U,PC) I Z S X=X_"*"_$$GET1^DIQ(356.008,Z_",",.01)
. D SAVE(X)
. Q
I INPAT,$TR($P(NODE7,U,1,4),U)'="" D ; inpatient, admission data exists
. S X="CL1*"_$P(NODE7,U)
. S Z=+$P(NODE7,U,2) I Z S $P(X,"*",3)=$$GET1^DIQ(356.009,Z_",",.01)
. S Z=+$P(NODE7,U,3) I Z S $P(X,"*",4)=$$GET1^DIQ(356.01,Z_",",.01)
. S Z=+$P(NODE7,U,4) I Z S $P(X,"*",5)=$$GET1^DIQ(356.011,Z_",",.01)
. D SAVE(X)
. Q
Q
;
CR1 ; create CR1 segment
N Z,Z1
S X="CR1*"
S $P(X,"*",5)=$P(NODE18,U,4)
S $P(X,"*",10)=$P(NODE18,U,9)
S $P(X,"*",11)=$P(NODE18,U,10)
S Z=$P(NODE18,U,2) I Z'="" S $P(X,"*",2)=$P(NODE18,U),$P(X,"*",3)=Z
S Z=$P(NODE18,U,6) I Z'="" S $P(X,"*",6)=$P(NODE18,U,5),$P(X,"*",7)=Z
S $P(X,"*",4)=$P(NODE18,U,3)
D SAVE(X)
Q
;
CR2 ; create CR2 segment
N TXNUM,TXCNT,Z
S TXNUM=$P(NODE7,U,5) I TXNUM="" Q ; missing treatment series number
S TXCNT=$P(NODE7,U,6) I TXCNT="" Q ; missing treatment count
S TXNUM=+TXNUM,TXCNT=+TXCNT
S X="CR2*"_TXNUM_"*"_TXCNT
S Z=+$P(NODE7,U,7) I Z>0 S $P(X,"*",4)=$$GET1^DIQ(356.012,Z_",",.01)
S Z=+$P(NODE7,U,8) I Z>0 S $P(X,"*",5)=$$GET1^DIQ(356.012,Z_",",.01)
S $P(X,"*",9)=$P(NODE7,U,9)
I $P(NODE7,U,10)'="" S $P(X,"*",10)=$P(NODE7,U,10)
S $P(X,"*",13)=$P(NODE7,U,13)
S $P(X,"*",11)=$P(NODE7,U,11)
S $P(X,"*",12)=$P(NODE7,U,12)
D SAVE(X)
Q
;
PWK ; create the PWK segment loop 2000E
N NODE0,SEQ,Z,Z1
S SEQ=0,Z="" F S Z=$O(^IBT(356.22,IBTRIEN,11,"B",Z)) Q:Z="" D
. S Z1=+$O(^IBT(356.22,IBTRIEN,11,"B",Z,"")) I 'Z1 Q
. S NODE0=$G(^IBT(356.22,IBTRIEN,11,Z1,0)) I NODE0="" Q ; 0-node of sub-file 356.2211
. S SEQ=SEQ+1 I SEQ>10 Q
. S X="PWK*"
. S $P(X,"*",2)=$$GET1^DIQ(356.018,+$P(NODE0,U)_",",.01)
. I $P(NODE0,U,3)'="" S $P(X,"*",7)=$P(NODE0,U,3),$P(X,"*",6)="AC"
. S $P(X,"*",8)=$P(NODE0,U,4)
. S $P(X,"*",3)=$P(NODE0,U,2)
. D SAVE(X)
. Q
Q
;
MSG ; create the MSG segment loop 2000E
N MSG,NTE
S MSG=$$WP2STR^IBTRHLO2(356.22,12,IBTRIEN_",",264)
I MSG="" Q
S X="MSG*"_MSG
D SAVE(X)
Q
;
SAVE(X) ;
N XCT
S (^TMP($J,"IBTRH8"),XCT)=$G(^TMP($J,"IBTRH8"))+1
S ^TMP($J,"IBTRH8",XCT)=X
Q
;
ERROR ;
D CLEAR^VALM1
I $P(NODE0,"^",12)="" W !!,"Unable to display the 278 request. The request for this entry has not been sent.",!!
I $P(NODE0,"^",12)'="" W !!,"INSUFFICIENT DATA TO DISPLAY X12 TRANSACTION.",!!
D PAUSE^VALM1
S VALMBCK="R"
D RE^VALM4
I $D(REQIEN) S IBTRIEN=REQIEN
Q
;
PERR ; PER segment for response loop 2010A
N X
S X="PER*IC"
S $P(X,"*",3)=$P(NODE19,"^")
S $P(X,"*",4)=$P(NODE19,"^",2)
S $P(X,"*",5)=$$NOPUNCT^IBCEF($P($G(^IBT(356.22,IBTRIEN,20)),"^"),1)
S $P(X,"*",6)=$P(NODE19,"^",3)
S $P(X,"*",7)=$$NOPUNCT^IBCEF($P($G(^IBT(356.22,IBTRIEN,21)),"^"),1)
S $P(X,"*",8)=$P(NODE19,"^",4)
S $P(X,"*",9)=$$NOPUNCT^IBCEF($P($G(^IBT(356.22,IBTRIEN,22)),"^"),1)
D SAVE(X)
Q
;
HCR ; HCR segment for response loop 2000E
N X,NODE103
I '$D(^IBT(356.22,IBTRIEN,103)) Q
S NODE103=$G(^IBT(356.22,IBTRIEN,103))
S X="HCR*"
S $P(X,"*",2)=$$GET1^DIQ(356.02,$P(NODE103,"^")_",",.01)
S $P(X,"*",3)=$P(NODE103,"^",2)
S $P(X,"*",4)=$$GET1^DIQ(356.021,$P(NODE103,"^",3)_",",.01)
S $P(X,"*",5)=$P(NODE103,"^",4)
D SAVE(X)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBTRH8 15993 printed Sep 23, 2025@20:04:42 Page 2
IBTRH8 ;ALB/JWS - HCSR Worklist - view 278 message in X12 format ;24-AUG-2015
+1 ;;2.0;INTEGRATED BILLING;**517**;21-MAR-94;Build 240
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;;
+4 QUIT
EN ; display message in X12 format
+1 ; IBTRIEN = ien of file 356.22
+2 ; MSGTYPE = 217 or 215
+3 ; RR = 0 for request / inquiry, 1 for response
+4 NEW X,MSGTYPE,RR,TD,TT,HL1,HL2,ADDR1,ADDR2,ADDR3,REQDATA,SITEIEN
+5 NEW NODE0,OMSG,DFN,IEN312,INSNODE0,INSNODE3,IEN3553,IEN36,GNUM,PREL
+6 NEW NODE2,NODE4,NODE5,NODE6,NODE7,NODE8,NODE9,NODE10,NODE17,NODE18,NODE19
+7 NEW REQCAT,CERT,INPAT,EVNT,HL1,HL2,PAYID,PAYER,PNODE0,IDTYPE,RELINFO
+8 NEW REQIEN,RMSH10,HLECH,HLFS,HLQ
+9 KILL ^TMP($JOB,"IBTRH8")
+10 SET SITEIEN=$PIECE($$SITE^VASITE(),U)
IF SITEIEN'>0
DO ERROR
QUIT
+11 SET NODE0=$GET(^IBT(356.22,IBTRIEN,0))
IF NODE0=""
DO ERROR
QUIT
+12 IF $PIECE(NODE0,U,12)=""
DO ERROR
QUIT
+13 SET MSGTYPE=+$PIECE(NODE0,"^",20)
SET RR=0
+14 IF MSGTYPE=2
Begin DoDot:1
+15 SET RR=1
+16 SET OMSG=$PIECE(NODE0,U,13)
+17 IF OMSG
Begin DoDot:2
+18 SET REQIEN=IBTRIEN
SET IBTRIEN=OMSG
+19 SET NODE0=$GET(^IBT(356.22,OMSG,0))
+20 SET MSGTYPE=+$PIECE(NODE0,U,20)
SET RR=0
SET RMSH10=$PIECE(NODE0,"^",12)
End DoDot:2
+21 QUIT
End DoDot:1
IF +OMSG=0
DO ERROR
QUIT
+22 SET DFN=+$PIECE(NODE0,U,2)
+23 IF DFN'>0
DO ERROR
QUIT
+24 SET IEN312=+$PIECE(NODE0,U,3)
+25 IF IEN312'>0
DO ERROR
QUIT
+26 ; 0-node in file 2.312
SET INSNODE0=$GET(^DPT(DFN,.312,IEN312,0))
+27 ; 3-node in file 2.312
SET INSNODE3=$GET(^DPT(DFN,.312,IEN312,3))
+28 ; file 355.3 ien
SET IEN3553=+$PIECE(INSNODE0,U,18)
+29 SET IEN36=+$PIECE(INSNODE0,U)
+30 IF IEN36'>0
DO ERROR
QUIT
+31 ; group number
SET GNUM=$SELECT(IEN3553>0:$$GET1^DIQ(355.3,IEN3553_",",.04),1:"")
+32 ; pat. relationship to insured
SET PREL=$PIECE($GET(^DPT(DFN,.312,IEN312,4)),U,3)
+33 SET NODE2=$GET(^IBT(356.22,IBTRIEN,2))
+34 SET NODE4=$GET(^IBT(356.22,IBTRIEN,4))
+35 SET NODE5=$GET(^IBT(356.22,IBTRIEN,5))
+36 SET NODE6=$GET(^IBT(356.22,IBTRIEN,6))
+37 SET NODE7=$GET(^IBT(356.22,IBTRIEN,7))
+38 SET NODE8=$GET(^IBT(356.22,IBTRIEN,8))
+39 SET NODE9=$GET(^IBT(356.22,IBTRIEN,9))
+40 SET NODE10=$GET(^IBT(356.22,IBTRIEN,10))
+41 SET NODE17=$GET(^IBT(356.22,IBTRIEN,17))
+42 SET NODE18=$GET(^IBT(356.22,IBTRIEN,18))
+43 SET NODE19=$GET(^IBT(356.22,IBTRIEN,19))
+44 SET HLECH="^~\&"
SET HLFS="|"
SET HLQ=""""
+45 SET X="ST*278*0001*005010X"_$SELECT(MSGTYPE=0:217,1:215)
DO SAVE(X)
+46 ; request category
SET REQCAT=$$GET1^DIQ(356.001,+$PIECE(NODE2,U)_",",.01)
+47 ; certification type code
SET CERT=$$GET1^DIQ(356.002,+$PIECE(NODE2,U,2)_",",.01)
+48 ; 1 if inpatient, 0 if outpatient
SET INPAT=$SELECT($PIECE(NODE0,U,4)="I":1,1:0)
+49 ; determine event reason code
+50 IF 'MSGTYPE
Begin DoDot:1
+51 ; request category = "HS" (Health Services), "AR" (Admission), or "SC" (Specialty Care) -> event code = 13 (Request)
IF REQCAT'="IN"
SET EVNT="13"
QUIT
+52 ; request category = "IN" (Individual) and certification type = 3 (Cancel) -> event code = 01 (Cancel)
IF CERT=3
SET EVNT="01"
QUIT
+53 ; request category = "IN" (Individual) and certification type '= 3 (other than Cancel) -> event code = 36 (Authority To Deduct)
SET EVNT=36
+54 QUIT
End DoDot:1
+55 ; 28 for 215 message
IF MSGTYPE=1
SET EVNT=28
+56 ; 11 for response messages
IF RR=1
SET EVNT=11
+57 SET X=$PIECE(NODE0,U,15)
SET (TD,TT)=""
+58 IF X'=""
DO H^%DTC
IF %H
DO YX^%DTC
SET TD=$SELECT($EXTRACT(X)=3:20,1:19)_$EXTRACT(X,2,7)
SET Y=$PIECE(NODE0,U,15)
DO DD^%DT
SET TT=$TRANSLATE($PIECE(Y,"@",2),":","")
+59 SET X="BHT*0007*"_EVNT_"*"_$SELECT(RR=1:$GET(RMSH10),1:$PIECE(NODE0,U,12))_"*"_TD_"*"_TT_$SELECT(EVNT=36:"*RU",1:"")
DO SAVE(X)
+60 SET HL1=$GET(HL1)+1
+61 SET X="HL*"_HL1_"**20*1"
DO SAVE(X)
+62 IF RR=1
DO AAA^IBTRH8A("2000A")
+63 SET PAYID=""
+64 ; file 365.12 ien
SET PAYER=+$$GET1^DIQ(36,IEN36_",",3.1,"I")
+65 IF PAYER'>0
DO ERROR
QUIT
+66 SET PNODE0=$GET(^IBE(365.12,PAYER,0))
SET IDTYPE="PI"
+67 ; VA national id
SET PAYID=$PIECE(PNODE0,U,2)
+68 ; if no VA national id, try to get CMS national id
+69 IF PAYID=""
SET PAYID=$PIECE(PNODE0,U,3)
SET IDTYPE="XV"
+70 ; if still no id, bail out
+71 IF PAYID=""
DO ERROR
QUIT
+72 ;UM09 Release of Information Code
SET RELINFO=$PIECE(NODE2,U,16)
+73 ; get HPID, relies on patch IB*2.0*519
+74 ; S $P(TMP,HLECH,3)=$$HPD^IBCNHUT1(IEN36)
+75 ;
+76 SET X="NM1*X3*2*"_$$GET1^DIQ(36,IEN36_",",.01)_"*****"_IDTYPE_"*"_PAYID
DO SAVE(X)
+77 IF RR=1
DO PERR
DO AAA^IBTRH8A("2010A")
+78 ; HL - Requester Level Loop 2000B
+79 SET HL2=HL1
SET HL1=HL1+1
+80 SET X="HL*"_HL1_"*"_HL2_"*21*1"
DO SAVE(X)
+81 SET REQDATA=$$PRVDATA^IBTRHLO2(SITEIEN,4)
+82 IF $TRANSLATE(REQDATA,U)=""
DO ERROR
QUIT
+83 SET X="NM1*FA*2*"_$PIECE(REQDATA,U)_"*****XX*"_$PIECE(REQDATA,U,7)
DO SAVE(X)
+84 IF RR=1
DO AAA^IBTRH8A("2010B")
+85 SET ADDR1=$PIECE(REQDATA,U,2,3)
SET ADDR2=$PIECE(REQDATA,U,4,6)
+86 SET ADDR3=$PIECE($$HLADDR^HLFNC(ADDR1,ADDR2),U,1,5)
+87 IF 'RR
SET X="N3*"_$PIECE(ADDR3,"^")
if $PIECE(ADDR3,"^",2)'=""
SET X=X_"*"_$PIECE(ADDR3,"^",2)
DO SAVE(X)
+88 IF 'RR
SET X="N4*"_$PIECE(ADDR3,"^",3)_"*"_$PIECE(ADDR3,"^",4)_"*"_$PIECE(ADDR3,"^",5)
DO SAVE(X)
+89 IF 'RR
DO PER
+90 DO PRV
+91 SET HL2=HL1
SET HL1=HL1+1
+92 SET X="HL*"_HL1_"*"_HL2_"*22*1"
DO SAVE(X)
+93 DO NM1
+94 IF PREL'="18"
Begin DoDot:1
+95 SET HL2=HL1
SET HL1=HL1+1
+96 SET X="HL*"_HL1_"*"_HL2_"*23*1"
DO SAVE(X)
+97 DO NM12010D
+98 QUIT
End DoDot:1
+99 SET HL2=HL1
SET HL1=HL1+1
+100 ; if line level procedure code sub HL seg, otherwise 0
SET X="HL*"_HL1_"*"_HL2_"*EV*"_$SELECT($ORDER(^IBT(356.22,IBTRIEN,16,0)):1,1:0)
DO SAVE(X)
+101 DO EVENT
+102 DO DISPLAY^IBTRH8A
+103 IF $DATA(REQIEN)
SET IBTRIEN=REQIEN
+104 QUIT
+105 ;
PER ; create PER segment in loop 2010B
+1 NEW CTD,COMMSTR,IEN200,NAME,NODE19,QUAL,TMP,VALUE,Z
+2 SET IEN200=+$PIECE(NODE0,U,11)
IF IEN200'>0
QUIT
+3 SET NAME=$$GET1^DIQ(200,IEN200_",",.01)
IF NAME=""
QUIT
+4 SET NODE19=$GET(^IBT(356.22,IBTRIEN,19))
+5 SET COMMSTR=""
FOR Z="20^2^19.01","21^3^19.02","22^4^19.03"
Begin DoDot:1
+6 SET QUAL=$PIECE(NODE19,U,$PIECE(Z,U,2))
IF QUAL=""
QUIT
+7 SET QUAL=$$EXTERNAL^DILFD(356.22,$PIECE(Z,U,3),,QUAL)
+8 SET VALUE=$GET(^IBT(356.22,IBTRIEN,$PIECE(Z,U)))
IF VALUE=""
QUIT
+9 ; strip punctuation if phone #
IF "^FX^HP^TE^WP^"[(U_QUAL_U)
SET VALUE=$$NOPUNCT^IBCEF(VALUE,1)
+10 SET $PIECE(TMP,U)=QUAL
SET $PIECE(TMP,U,2)=VALUE
+11 SET COMMSTR=$SELECT(COMMSTR="":TMP,1:COMMSTR_U_TMP)
+12 QUIT
End DoDot:1
+13 SET X="PER*IC*"_NAME_"*"_$PIECE(COMMSTR,U)_"*"_$PIECE(COMMSTR,U,2)
+14 IF $PIECE(COMMSTR,U,3)'=""
SET X=X_"*"_$PIECE(COMMSTR,U,3)_"*"_$PIECE(COMMSTR,U,4)
+15 IF $PIECE(COMMSTR,U,5)'=""
SET X=X_"*"_$PIECE(COMMSTR,U,5)_"*"_$PIECE(COMMSTR,U,6)
+16 DO SAVE(X)
+17 QUIT
+18 ;
PRV ; create PRV segment (X12: PRV, 2010B)
+1 NEW PRD,TXNM
+2 SET TXNM=$PIECE($$TAXORG^XUSTAX(SITEIEN),U)
IF TXNM=""
QUIT
+3 SET X="PRV*PE*PXC*"_TXNM
DO SAVE(X)
+4 QUIT
+5 ;
NM1 ; create NM1 segment (X12: NM1, 2010C)
+1 NEW ADDR1,ADDR2,GT1,SID1,SIDSTR,NAME
+2 SET SID1=$PIECE(INSNODE0,U,2)
IF SID1=""
QUIT
+3 SET NAME=$PIECE(INSNODE0,U,17)
IF NAME=""
QUIT
+4 ;;S SID2=GNUM ; secondary subscriber id is a group number
+5 SET NAME=$$HLNAME^HLFNC(NAME)
+6 SET X="NM1*IL*1*"_$PIECE(NAME,"^")_"*"_$PIECE(NAME,"^",2)_"*"_$PIECE(NAME,"^",3)_"**"_$PIECE(NAME,"^",4)_"*MI*"_SID1
DO SAVE(X)
+7 IF GNUM'=""
SET X="REF*6P*"_GNUM
DO SAVE(X)
+8 IF 'MSGTYPE
IF $PIECE(INSNODE3,U,6)'=""
IF $PIECE(INSNODE3,U,8)'=""
Begin DoDot:1
+9 SET ADDR1=$PIECE(INSNODE3,U,6,7)
SET ADDR2=$PIECE(INSNODE3,U,8,10)
+10 ; subscriber address
SET ADDR3=$$HLADDR^HLFNC(ADDR1,ADDR2)
+11 SET X="N3*"_$PIECE(ADDR3,"^")
if $PIECE(ADDR3,"^",2)'=""
SET X=X_"*"_$PIECE(ADDR3,"^",2)
DO SAVE(X)
+12 SET X="N4*"_$PIECE(ADDR3,"^",3)_"*"_$PIECE(ADDR3,"^",4)_"*"_$PIECE(ADDR3,"^",5)
DO SAVE(X)
+13 QUIT
End DoDot:1
+14 IF RR
DO AAA^IBTRH8A("2010C")
+15 ; subscriber dob
SET X="DMG*D8*"_$$HLDATE^HLFNC($PIECE(INSNODE3,U))
+16 ; subscriber sex
IF 'MSGTYPE
SET X=X_"*"_$PIECE(INSNODE3,U,12)
+17 DO SAVE(X)
+18 IF MSGTYPE
QUIT
+19 ; relationship to insured
IF PREL'="18"
SET PREL=$SELECT(PREL="01":"01",PREL=19:19,1:"G8")
+20 SET X="INS*Y*18"
DO SAVE(X)
+21 QUIT
+22 ;
NM12010D ; create NM1 segment, loop 2010D
+1 NEW IDSTR,PID,TMP,VAFSTR
+2 IF GNUM=""
QUIT
+3 SET VAFSTR="7,8,11,"
+4 SET PID=$$EN^VAFHLPID(DFN,VAFSTR)
+5 SET TMP=$PIECE(PID,"|",12)
+6 IF $PIECE(TMP,U,2)=""""""
SET $PIECE(TMP,U,2)=""
SET $PIECE(PID,"|",12)=TMP
+7 SET X="NM1*QC*1*"_$PIECE($PIECE(PID,"|",6),"^")_"*"_$PIECE($PIECE(PID,"|",6),"^",2)
if $PIECE($PIECE(PID,"|",6),"^",3)'=""
SET X=X_"*"_$PIECE($PIECE(PID,"|",6),"^",3)
DO SAVE(X)
+8 SET X="REF*EJ*"_GNUM
DO SAVE(X)
+9 IF 'MSGTYPE!RR
Begin DoDot:1
+10 SET X="N3*"_$PIECE(TMP,"^")
if $PIECE(TMP,"^",2)'=""
SET X=X_"*"_$PIECE(TMP,"^",2)
DO SAVE(X)
+11 SET X="N4*"_$PIECE(TMP,"^",3)_"*"_$PIECE(TMP,"^",4)_"*"_$PIECE(TMP,"^",5)
DO SAVE(X)
+12 QUIT
End DoDot:1
+13 IF RR
DO AAA^IBTRH8A("2010D")
+14 SET X="DMG*D8*"_$PIECE(PID,"|",8)
if 'MSGTYPE
SET X=X_"*"_$PIECE(PID,"|",9)
DO SAVE(X)
+15 IF MSGTYPE
QUIT
+16 SET X="INS*N*"_PREL
DO SAVE(X)
+17 QUIT
+18 ;
EVENT ; 2000E loop
+1 ; create G2R.PRB segment (G2R segment group)
+2 NEW PRB,Z,TOT
+3 IF RR
DO AAA^IBTRH8A("2000E")
+4 ; missing certification type code
IF CERT=""
QUIT
+5 SET X="UM*"_REQCAT_"*"_CERT_"*"_$$GET1^DIQ(365.013,+$PIECE(NODE2,U,3)_",",.01)
+6 IF $PIECE(NODE2,U,4)'=""
SET X=X_"*"_$SELECT($PIECE(NODE2,U,4)="A":($PIECE(NODE2,U,6)_$PIECE(NODE2,U,7)),1:$$GET1^DIQ(353.1,+$PIECE(NODE2,U,5)_",",.01))_":"_$PIECE(NODE2,U,4)
+7 IF '$TEST
Begin DoDot:1
+8 IF MSGTYPE
DO SAVE(X)
QUIT
+9 SET X=X_"*"
End DoDot:1
IF MSGTYPE
QUIT
+10 SET X=X_"*"_$PIECE(NODE2,U,8)_":"_$PIECE(NODE2,U,9)_":"_$PIECE(NODE2,U,10)_":"_$$GET1^DIQ(5,+$PIECE(NODE2,U,11)_",",1)
+11 SET Z=$$GET1^DIQ(779.004,+$PIECE(NODE2,U,12)_",",.01)
IF Z'=""
IF Z'="USA"
SET X=X_":"_Z
+12 SET X=X_"*"_$PIECE(NODE2,U,13)_"*"_$$GET1^DIQ(356.003,+$PIECE(NODE2,U,14)_",",.01)_"*"_$$GET1^DIQ(356.004,+$PIECE(NODE2,U,15)_",",.01)_"*"_$PIECE(NODE2,U,16)_"*"_$$GET1^DIQ(356.005,+$PIECE(NODE2,U,17)_",",.01)
DO SAVE(X)
+13 IF RR
DO HCR
+14 DO REF
+15 DO DTP
+16 DO HI
+17 ; for 217 request only
+18 IF 'MSGTYPE
Begin DoDot:1
+19 DO HSD
DO CRC
+20 IF $TRANSLATE(NODE18,U)'=""
DO CR1
+21 DO CR2
DO CR5^IBTRH8A
DO CR6^IBTRH8A
DO PWK
DO MSG
End DoDot:1
+22 DO NM1^IBTRH8A
+23 ;
+24 IF '$ORDER(^IBT(356.22,IBTRIEN,16,0))
QUIT
+25 SET HL2=HL1
SET HL1=HL1+1
+26 SET X="HL*"_HL1_"*"_HL2_"*SS*0"
DO SAVE(X)
+27 DO DETAIL^IBTRH8A
+28 SET TOT=$GET(^TMP($JOB,"IBTRH8"))+1
+29 SET X="SE*"_TOT_"*0001"
DO SAVE(X)
+30 QUIT
+31 ;
REF ; REF segment
+1 IF $PIECE(NODE17,U)'=""
SET X="REF*BB*"_$PIECE(NODE17,U)
DO SAVE(X)
QUIT
+2 IF $PIECE(NODE17,U,2)'=""
SET X="REF*NT*"_$PIECE(NODE17,U,2)
DO SAVE(X)
QUIT
+3 QUIT
+4 ;
DTP ; create DTP segments
+1 NEW DATA,Z,Z1
+2 SET Z=$PIECE(NODE0,U,7)
IF Z'=""
Begin DoDot:1
+3 SET Z1="AAH"
IF INPAT
IF REQCAT="AR"
SET Z1="435"
+4 ; admission / appointment date
SET DATA(Z1)=$SELECT(Z["-":$$HLDATE^HLFNC($PIECE($PIECE(Z,"-"),"."))_"-"_$$HLDATE^HLFNC($PIECE($PIECE(Z,"-",2),".")),1:$$HLDATE^HLFNC($PIECE(Z,".")))
+5 QUIT
End DoDot:1
+6 ; accident date
SET Z=$PIECE(NODE2,U,18)
IF Z'=""
SET DATA("439")=$$HLDATE^HLFNC($PIECE(Z,"."))
+7 IF 'MSGTYPE
Begin DoDot:1
+8 ; last menstrual period date
SET Z=$PIECE(NODE2,U,19)
IF Z'=""
SET DATA("484")=$$HLDATE^HLFNC($PIECE(Z,"."))
+9 ; estimated DOB
SET Z=$PIECE(NODE2,U,20)
IF Z'=""
SET DATA("ABC")=$$HLDATE^HLFNC(Z)
+10 ; illness date
SET Z=$PIECE(NODE2,U,21)
IF Z'=""
SET DATA("431")=$$HLDATE^HLFNC(Z)
+11 QUIT
End DoDot:1
+12 ; the following date is for "Admission Review" request category only
+13 ; discharge date
IF INPAT
IF REQCAT="AR"
SET Z=$PIECE(NODE2,U,22)
if Z'=""
SET DATA("096")=$$HLDATE^HLFNC($PIECE(Z,"."))
+14 SET Z=""
FOR
SET Z=$ORDER(DATA(Z))
if Z=""
QUIT
Begin DoDot:1
+15 SET X="DTP*"_Z_"*D8*"_DATA(Z)
DO SAVE(X)
+16 QUIT
End DoDot:1
+17 QUIT
+18 ;
HI ; create HI segments
+1 NEW DG1,DIAG,NODE0,SEQ,Z
+2 SET (SEQ,Z)=0
FOR
SET Z=$ORDER(^IBT(356.22,IBTRIEN,3,Z))
if Z'=+Z
QUIT
Begin DoDot:1
+3 ; 0-node of sub-file 356.223
SET NODE0=$GET(^IBT(356.22,IBTRIEN,3,Z,0))
IF NODE0=""
QUIT
+4 ; only allow up to 12 DG1 segments
SET SEQ=SEQ+1
IF SEQ>12
QUIT
+5 ; only allow 1 DG1 segment in 215 message
IF MSGTYPE
IF SEQ>1
QUIT
+6 ; invalid diagnosis code
SET DIAG=$TRANSLATE($$EXTERNAL^DILFD(356.223,.02,,$PIECE(NODE0,U,2)),".")
IF DIAG=""
QUIT
+7 SET DG1(SEQ)="*"_$$GET1^DIQ(356.006,+$PIECE(NODE0,U)_",",.01)_":"_DIAG
IF 'MSGTYPE
IF $PIECE(NODE0,U,3)'=""
SET DG1(SEQ)=DG1(SEQ)_":D8:"_$$HLDATE^HLFNC($PIECE(NODE0,U,3))
+8 ;S DG1="DG1"_HLFS_SEQ_HLFS_HLFS_$$ENCHL7^IBCNEHLQ(DIAG)_HLFS_HLFS_$S('MSGTYPE:$$HLDATE^HLFNC($P(NODE0,U,3)),1:"")_HLFS_"W"
+9 QUIT
End DoDot:1
+10 IF '$ORDER(DG1(""))
QUIT
+11 SET X="HI"
+12 SET Z=0
FOR
SET Z=$ORDER(DG1(Z))
if Z=""
QUIT
SET X=X_DG1(Z)
+13 DO SAVE(X)
+14 QUIT
+15 ;
HSD ; create HSD segment
+1 NEW QUAL,VALUE,HSD,I
+2 SET QUAL=$$GET1^DIQ(365.016,+$PIECE(NODE4,U)_",",.01)
+3 SET VALUE=$PIECE(NODE4,U,2)
+4 ;ZHS.2=4.01, ZHS.3=4.02
IF QUAL'=""
IF VALUE'=""
SET HSD(1)=QUAL
SET HSD(2)=VALUE
+5 SET QUAL=$PIECE(NODE4,U,3)
+6 SET VALUE=$PIECE(NODE4,U,4)
+7 ;ZHS.4=4.03
IF QUAL'=""
IF VALUE'=""
SET HSD(3)=QUAL
+8 ;ZHS.5=4.04
IF VALUE'=""
SET HSD(4)=VALUE
+9 SET QUAL=$$GET1^DIQ(365.015,+$PIECE(NODE4,U,5)_",",.01)
+10 SET VALUE=$PIECE(NODE4,U,6)
+11 ;ZHS.6=4.05, ZHS.7=4.06
IF QUAL'=""
IF VALUE'=""
SET HSD(5)=QUAL
SET HSD(6)=VALUE
+12 ;ZHS.8=4.07
IF +$PIECE(NODE4,U,7)
SET HSD(7)=$$GET1^DIQ(365.025,+$PIECE(NODE4,U,7)_",",.01)
+13 ;ZHS.9=4.08
IF +$PIECE(NODE4,U,8)
SET HSD(8)=$$GET1^DIQ(356.007,+$PIECE(NODE4,U,8)_",",.01)
+14 IF '$DATA(HSD)
QUIT
+15 SET X="HSD"
FOR I=1:1:8
SET X=X_"*"_$GET(HSD(I))
+16 DO SAVE(X)
+17 QUIT
+18 ;
CRC ; create CRC and CL1 segments in loop 2000E
+1 NEW PC,Z
+2 ; at least one ambulance cert. condition exists
IF +$PIECE(NODE4,U,10)
Begin DoDot:1
+3 SET X="CRC*07*"_$PIECE(NODE4,U,9)
+4 FOR PC=10:1:14
SET Z=+$PIECE(NODE4,U,PC)
IF Z
SET X=X_"*"_$$GET1^DIQ(356.008,Z_",",.01)
+5 DO SAVE(X)
+6 QUIT
End DoDot:1
+7 ; at least one chiropractic cert. condition exists
IF +$PIECE(NODE5,U,2)
Begin DoDot:1
+8 SET X="CRC*08*"_$PIECE(NODE5,U)
+9 FOR PC=2:1:6
SET Z=+$PIECE(NODE5,U,PC)
IF Z
SET X=X_"*"_$$GET1^DIQ(356.008,Z_",",.01)
+10 DO SAVE(X)
+11 QUIT
End DoDot:1
+12 ; at least one DME cert. condition exists
IF +$PIECE(NODE5,U,8)
Begin DoDot:1
+13 SET X="CRC*09*"_$PIECE(NODE5,U,7)
+14 FOR PC=8:1:12
SET Z=+$PIECE(NODE5,U,PC)
IF Z
SET X=X_"*"_$$GET1^DIQ(356.008,Z_",",.01)
+15 DO SAVE(X)
+16 QUIT
End DoDot:1
+17 ; at least one oxygen cert. condition exists
IF +$PIECE(NODE5,U,14)
Begin DoDot:1
+18 SET X="CRC*11*"_$PIECE(NODE5,U,13)
+19 FOR PC=14:1:18
SET Z=+$PIECE(NODE5,U,PC)
IF Z
SET X=X_"*"_$$GET1^DIQ(356.008,Z_",",.01)
+20 DO SAVE(X)
+21 QUIT
End DoDot:1
+22 ; at least one functional limit cert. condition exists
IF +$PIECE(NODE6,U,2)
Begin DoDot:1
+23 SET X="CRC*75*"_$PIECE(NODE6,U)
+24 FOR PC=2:1:6
SET Z=+$PIECE(NODE6,U,PC)
IF Z
SET X=X_"*"_$$GET1^DIQ(356.008,Z_",",.01)
+25 DO SAVE(X)
+26 QUIT
End DoDot:1
+27 ; at least one activities cert. condition exists
IF +$PIECE(NODE6,U,8)
Begin DoDot:1
+28 SET X="CRC*76*"_$PIECE(NODE6,U,7)
+29 FOR PC=8:1:12
SET Z=+$PIECE(NODE6,U,PC)
IF Z
SET X=X_"*"_$$GET1^DIQ(356.008,Z_",",.01)
+30 DO SAVE(X)
+31 QUIT
End DoDot:1
+32 ; at least one mental status cert. condition exists
IF +$PIECE(NODE6,U,14)
Begin DoDot:1
+33 SET X="CRC*77*"_$PIECE(NODE6,U,13)
+34 FOR PC=14:1:18
SET Z=+$PIECE(NODE6,U,PC)
IF Z
SET X=X_"*"_$$GET1^DIQ(356.008,Z_",",.01)
+35 DO SAVE(X)
+36 QUIT
End DoDot:1
+37 ; inpatient, admission data exists
IF INPAT
IF $TRANSLATE($PIECE(NODE7,U,1,4),U)'=""
Begin DoDot:1
+38 SET X="CL1*"_$PIECE(NODE7,U)
+39 SET Z=+$PIECE(NODE7,U,2)
IF Z
SET $PIECE(X,"*",3)=$$GET1^DIQ(356.009,Z_",",.01)
+40 SET Z=+$PIECE(NODE7,U,3)
IF Z
SET $PIECE(X,"*",4)=$$GET1^DIQ(356.01,Z_",",.01)
+41 SET Z=+$PIECE(NODE7,U,4)
IF Z
SET $PIECE(X,"*",5)=$$GET1^DIQ(356.011,Z_",",.01)
+42 DO SAVE(X)
+43 QUIT
End DoDot:1
+44 QUIT
+45 ;
CR1 ; create CR1 segment
+1 NEW Z,Z1
+2 SET X="CR1*"
+3 SET $PIECE(X,"*",5)=$PIECE(NODE18,U,4)
+4 SET $PIECE(X,"*",10)=$PIECE(NODE18,U,9)
+5 SET $PIECE(X,"*",11)=$PIECE(NODE18,U,10)
+6 SET Z=$PIECE(NODE18,U,2)
IF Z'=""
SET $PIECE(X,"*",2)=$PIECE(NODE18,U)
SET $PIECE(X,"*",3)=Z
+7 SET Z=$PIECE(NODE18,U,6)
IF Z'=""
SET $PIECE(X,"*",6)=$PIECE(NODE18,U,5)
SET $PIECE(X,"*",7)=Z
+8 SET $PIECE(X,"*",4)=$PIECE(NODE18,U,3)
+9 DO SAVE(X)
+10 QUIT
+11 ;
CR2 ; create CR2 segment
+1 NEW TXNUM,TXCNT,Z
+2 ; missing treatment series number
SET TXNUM=$PIECE(NODE7,U,5)
IF TXNUM=""
QUIT
+3 ; missing treatment count
SET TXCNT=$PIECE(NODE7,U,6)
IF TXCNT=""
QUIT
+4 SET TXNUM=+TXNUM
SET TXCNT=+TXCNT
+5 SET X="CR2*"_TXNUM_"*"_TXCNT
+6 SET Z=+$PIECE(NODE7,U,7)
IF Z>0
SET $PIECE(X,"*",4)=$$GET1^DIQ(356.012,Z_",",.01)
+7 SET Z=+$PIECE(NODE7,U,8)
IF Z>0
SET $PIECE(X,"*",5)=$$GET1^DIQ(356.012,Z_",",.01)
+8 SET $PIECE(X,"*",9)=$PIECE(NODE7,U,9)
+9 IF $PIECE(NODE7,U,10)'=""
SET $PIECE(X,"*",10)=$PIECE(NODE7,U,10)
+10 SET $PIECE(X,"*",13)=$PIECE(NODE7,U,13)
+11 SET $PIECE(X,"*",11)=$PIECE(NODE7,U,11)
+12 SET $PIECE(X,"*",12)=$PIECE(NODE7,U,12)
+13 DO SAVE(X)
+14 QUIT
+15 ;
PWK ; create the PWK segment loop 2000E
+1 NEW NODE0,SEQ,Z,Z1
+2 SET SEQ=0
SET Z=""
FOR
SET Z=$ORDER(^IBT(356.22,IBTRIEN,11,"B",Z))
if Z=""
QUIT
Begin DoDot:1
+3 SET Z1=+$ORDER(^IBT(356.22,IBTRIEN,11,"B",Z,""))
IF 'Z1
QUIT
+4 ; 0-node of sub-file 356.2211
SET NODE0=$GET(^IBT(356.22,IBTRIEN,11,Z1,0))
IF NODE0=""
QUIT
+5 SET SEQ=SEQ+1
IF SEQ>10
QUIT
+6 SET X="PWK*"
+7 SET $PIECE(X,"*",2)=$$GET1^DIQ(356.018,+$PIECE(NODE0,U)_",",.01)
+8 IF $PIECE(NODE0,U,3)'=""
SET $PIECE(X,"*",7)=$PIECE(NODE0,U,3)
SET $PIECE(X,"*",6)="AC"
+9 SET $PIECE(X,"*",8)=$PIECE(NODE0,U,4)
+10 SET $PIECE(X,"*",3)=$PIECE(NODE0,U,2)
+11 DO SAVE(X)
+12 QUIT
End DoDot:1
+13 QUIT
+14 ;
MSG ; create the MSG segment loop 2000E
+1 NEW MSG,NTE
+2 SET MSG=$$WP2STR^IBTRHLO2(356.22,12,IBTRIEN_",",264)
+3 IF MSG=""
QUIT
+4 SET X="MSG*"_MSG
+5 DO SAVE(X)
+6 QUIT
+7 ;
SAVE(X) ;
+1 NEW XCT
+2 SET (^TMP($JOB,"IBTRH8"),XCT)=$GET(^TMP($JOB,"IBTRH8"))+1
+3 SET ^TMP($JOB,"IBTRH8",XCT)=X
+4 QUIT
+5 ;
ERROR ;
+1 DO CLEAR^VALM1
+2 IF $PIECE(NODE0,"^",12)=""
WRITE !!,"Unable to display the 278 request. The request for this entry has not been sent.",!!
+3 IF $PIECE(NODE0,"^",12)'=""
WRITE !!,"INSUFFICIENT DATA TO DISPLAY X12 TRANSACTION.",!!
+4 DO PAUSE^VALM1
+5 SET VALMBCK="R"
+6 DO RE^VALM4
+7 IF $DATA(REQIEN)
SET IBTRIEN=REQIEN
+8 QUIT
+9 ;
PERR ; PER segment for response loop 2010A
+1 NEW X
+2 SET X="PER*IC"
+3 SET $PIECE(X,"*",3)=$PIECE(NODE19,"^")
+4 SET $PIECE(X,"*",4)=$PIECE(NODE19,"^",2)
+5 SET $PIECE(X,"*",5)=$$NOPUNCT^IBCEF($PIECE($GET(^IBT(356.22,IBTRIEN,20)),"^"),1)
+6 SET $PIECE(X,"*",6)=$PIECE(NODE19,"^",3)
+7 SET $PIECE(X,"*",7)=$$NOPUNCT^IBCEF($PIECE($GET(^IBT(356.22,IBTRIEN,21)),"^"),1)
+8 SET $PIECE(X,"*",8)=$PIECE(NODE19,"^",4)
+9 SET $PIECE(X,"*",9)=$$NOPUNCT^IBCEF($PIECE($GET(^IBT(356.22,IBTRIEN,22)),"^"),1)
+10 DO SAVE(X)
+11 QUIT
+12 ;
HCR ; HCR segment for response loop 2000E
+1 NEW X,NODE103
+2 IF '$DATA(^IBT(356.22,IBTRIEN,103))
QUIT
+3 SET NODE103=$GET(^IBT(356.22,IBTRIEN,103))
+4 SET X="HCR*"
+5 SET $PIECE(X,"*",2)=$$GET1^DIQ(356.02,$PIECE(NODE103,"^")_",",.01)
+6 SET $PIECE(X,"*",3)=$PIECE(NODE103,"^",2)
+7 SET $PIECE(X,"*",4)=$$GET1^DIQ(356.021,$PIECE(NODE103,"^",3)_",",.01)
+8 SET $PIECE(X,"*",5)=$PIECE(NODE103,"^",4)
+9 DO SAVE(X)
+10 QUIT
