IBTRHLI3 ;ALB/JWS - Receive and store 278 Response message ;05-JUN-2014
;;2.0;INTEGRATED BILLING;**517**;21-MAR-94;Build 240
;;Per VA Directive 6402, this routine should not be modified.
;
;**Program Description**
; This pgm will process the indiv segments of the
; incoming 278 response msgs.
;
; * Each of these tags are called by IBTRHL2.
;
; This routine is based on IBCNEHL2 which was introduced with patch 300, and subsequently
; patched with patches 345, 416, and 438.
;
; Variables
; SEG = HL7 Seg Name
; IBSEG = Array of the segment
;
Q ; No direct calls
;
ZTP(IBSEG,RESIEN,ERROR,SLIEN) ; Process ZTP Subscriber date seg (X12 DTP segs)
; Input:
; IBSEG,RESIEN,SLIEN
;
; Output:
; ERROR
N FLD,LEV,IBFDA,RIEN,LEV1
I $G(IBSEG(4))="DTP 2000F" D D UP^IBTRHLI2("DTP","2000F") Q
.D SLCHECK^IBTRHLI1
.I $G(IBSEG(2))=472 S IBFDA(356.2216,LEV1,.11)=$P($G(IBSEG(3)),HLCMP),IBFDA(356.2216,LEV1,.17)=$P($G(IBSEG(3)),HLCMP,2) Q ;service date
.I $G(IBSEG(2))=102 S IBFDA(356.2216,LEV1,.12)=$P($G(IBSEG(3)),HLCMP) Q ;cert issue date
.I $G(IBSEG(2))="036" S IBFDA(356.2216,LEV1,.13)=$P($G(IBSEG(3)),HLCMP) Q ;cert expiration date
.I $G(IBSEG(2))="007" S IBFDA(356.2216,LEV1,.14)=$P($G(IBSEG(3)),HLCMP),IBFDA(356.2216,LEV1,.16)=$P($G(IBSEG(3)),HLCMP,2) Q ;cert effective date
S LEV="+2,"_RESIEN_","
I $G(IBSEG(2))=439 S FLD=2.18 G ZTP1 ;Accident Date
I $G(IBSEG(2))=484 S FLD=2.19 G ZTP1 ;Last Menstrual Period
I $G(IBSEG(2))="ABC" S FLD=2.2 G ZTP1 ;Estimated DOB
I $G(IBSEG(2))=431 S FLD=2.21 G ZTP1 ;Illness Date
I $G(IBSEG(2))="AAH"!($G(IBSEG(2)))=435 S FLD=".07" G ZTP1
I $G(IBSEG(2))="096" S FLD=2.22 G ZTP1 ;discharge date
I $G(IBSEG(2))=102 S FLD=2.23 G ZTP1 ;Cert Issue Date
I $G(IBSEG(2))="036" S FLD=2.24 G ZTP1 ;Cert Expiration Date
I $G(IBSEG(2))="007" S FLD=2.25,IBFDA(356.22,RESIEN_",",2.26)=$P($G(IBSEG(3)),HLCMP,2) G ZTP1 ;Cert Effective Date
Q
ZTP1 ;
S IBFDA(356.22,RESIEN_",",FLD)=$P($G(IBSEG(3)),HLCMP)
D UP^IBTRHLI2("DTP","2000E")
Q
;
RXE(IBSEG,RESIEN,ERROR) ;RXE Pharmacy/Treatment Encoded Order seg
; Input:
; IBSEG,RESIEN
;
; Output:
; ERROR
N LEV,IBFDA,RIEN
S LEV=RESIEN_","
S IBFDA(356.22,LEV,8.01)=$P($P($G(IBSEG(14)),HLREP),HLCMP) ;CR503 OXY EQUIP TYPE
S IBFDA(356.22,LEV,8.02)=$P($P($G(IBSEG(14)),HLREP,2),HLCMP) ;CR504 OXY EQUIP TYPE
S IBFDA(356.22,LEV,8.05)=$G(IBSEG(23)) ;CR506 OXY FLOW RATE
S IBFDA(356.22,LEV,8.06)=$P($G(IBSEG(19)),HLCMP) ;CR507 DAILY OXY USE CNT
S IBFDA(356.22,LEV,8.07)=$P($P($G(IBSEG(1)),HLCMP),HLSCMP) ;CR508 OXY USE PERIOD HR CNT
S IBFDA(356.22,LEV,8.08)=$P($G(IBSEG(1)),HLCMP,8) ;CR509 RESP THERAPIST TEXT
S IBFDA(356.22,LEV,9.07)=$G(IBSEG(16)) ;CR516 PORT OXY SYS FLOW
S IBFDA(356.22,LEV,9.08)=$P($G(IBSEG(29)),HLCMP) ;CR517 OXY DEL SYS CODE
S IBFDA(356.22,LEV,8.03)=$P($G(IBSEG(31)),HLCMP,1) ;CR518 OXY EQUIP TYPE
D UP^IBTRHLI2("CR5","2000E")
Q
ZHS(IBSEG,RESIEN,ERROR,SLIEN) ; ZHS Healthcare services delivery seg
; Input:
; IBSEG,RESIEN,SLIEN
;
; Output:
; ERROR
N CT,LEV,IBFDA,RIEN
I $G(IBSEG(1))="HSD 2000F" D D UP^IBTRHLI2("HSD","2000F") Q
.S LEV=SLIEN_","_RESIEN_","
.S IBFDA(356.2216,LEV,5.01)=$G(IBSEG(2)) ;HCSD Quantity Qualifier
.S IBFDA(356.2216,LEV,5.02)=$G(IBSEG(3)) ;HCSD Service Unit Count
.S IBFDA(356.2216,LEV,5.03)=$G(IBSEG(4)) ;HCSD Units of Measurement
.S IBFDA(356.2216,LEV,5.04)=$G(IBSEG(5)) ;HCSD Sample Selection Modulus
.S IBFDA(356.2216,LEV,5.05)=$G(IBSEG(6)) ;HCSD Time Period Qualifier
.S IBFDA(356.2216,LEV,5.06)=$G(IBSEG(7)) ;HCSD Period Count
.S IBFDA(356.2216,LEV,5.07)=$G(IBSEG(8)) ;HCSD Delivery Frequency
.S IBFDA(356.2216,LEV,5.08)=$G(IBSEG(9)) ;HCSD Delivery Time Pattern
.Q
S LEV=RESIEN_","
S IBFDA(356.22,LEV,4.01)=$G(IBSEG(2)) ; quantity qualifier
S IBFDA(356.22,LEV,4.02)=$G(IBSEG(3)) ; unit count
S IBFDA(356.22,LEV,4.03)=$G(IBSEG(4)) ;measurement code
S IBFDA(356.22,LEV,4.04)=$G(IBSEG(5)) ;selection modulus
S IBFDA(356.22,LEV,4.05)=$G(IBSEG(6)) ;period qualifier
S IBFDA(356.22,LEV,4.06)=$G(IBSEG(7)) ;period count
S IBFDA(356.22,LEV,4.07)=$G(IBSEG(8)) ;freq code
S IBFDA(356.22,LEV,4.08)=$G(IBSEG(9)) ;pattern
D UP^IBTRHLI2("HSD","2000E")
Q
;
CTD(IBSEG,RESIEN,ERROR,PEIEN,SLIEN,SLPIEN) ; CTD Contact Data seg
; Input:
; IBSEG,RESIEN,PEIEN,SLIEN,SLPIEN
;
; Output:
; ERROR
N RIEN,LEV
I $G(IBSEG(1))="PER 2010EB" D D UP^IBTRHLI2("PER","2010EB") Q
.S LEV=PEIEN_","_RESIEN_","
.S IBFDA(356.2213,LEV,.04)="2010EB"
.S IBFDA(356.2213,LEV,.05)="IC"
.S IBFDA(356.2213,LEV,.06)=$P($G(IBSEG(2)),HLCMP) ;CONTACT NAME
.S IBFDA(356.2213,LEV,.07)=$P($P($G(IBSEG(5)),HLREP),HLCMP,2) ;COMM NO QUAL1
.S IBFDA(356.2213,LEV,.08)=$P($P($G(IBSEG(5)),HLREP,2),HLCMP,2) ;COMM NO QUAL2
.S IBFDA(356.2213,LEV,.09)=$P($P($G(IBSEG(5)),HLREP,3),HLCMP,2) ;COMM NO QUAL3
.S IBFDA(356.2213,LEV,1)=$P($P($G(IBSEG(5)),HLREP),HLCMP,8) ;CONTACT COMM NUM1
.S IBFDA(356.2213,LEV,2)=$P($P($G(IBSEG(5)),HLREP,2),HLCMP,8) ;CONTACT COMM NUM2
.S IBFDA(356.2213,LEV,3)=$P($P($G(IBSEG(5)),HLREP,3),HLCMP,8) ;CONTACT COMM NUM3
.Q
I $G(IBSEG(1))="PER 2010FB" D D UP^IBTRHLI2("PER","2010FB") Q
.S LEV=SLPIEN_","_SLIEN_","_RESIEN_","
.S IBFDA(356.22168,LEV,.04)="2010FB" ;PER loop identifier
.S IBFDA(356.22168,LEV,.05)="IC" ;CONTACT FUNCTION CODE
.S IBFDA(356.22168,LEV,.06)=$P($G(IBSEG(2)),HLCMP) ;CONTACT NAME
.S IBFDA(356.22168,LEV,.07)=$P($P($G(IBSEG(5)),HLREP),HLCMP,2) ;COMM NO QUAL1
.S IBFDA(356.22168,LEV,.08)=$P($P($G(IBSEG(5)),HLREP,2),HLCMP,2) ;COMM NO QUAL2
.S IBFDA(356.22168,LEV,.09)=$P($P($G(IBSEG(5)),HLREP,3),HLCMP,2) ;COMM NO QUAL3
.S IBFDA(356.22168,LEV,1)=$P($P($G(IBSEG(5)),HLREP),HLCMP,8) ;CONTACT COMM NUM1
.S IBFDA(356.22168,LEV,2)=$P($P($G(IBSEG(5)),HLREP,2),HLCMP,8) ;CONTACT COMM NUM2
.S IBFDA(356.22168,LEV,3)=$P($P($G(IBSEG(5)),HLREP,3),HLCMP,8) ;CONTACT COMM NUM3
.Q
Q
NK1(IBSEG,RESIEN,ERROR,PEIEN) ;NK1 Next of Kin seg
; Input:
; IBSEG,RESIEN,PEIEN
;
; Output:
; ERROR
N LEV,IBFDA,RIEN
S LEV=PEIEN_","_RESIEN_","
S IBFDA(356.2213,LEV,4.01)="2010EB" ;NM1 loop ident
S IBFDA(356.2213,LEV,4.02)="L5" ;Entity ident
S IBFDA(356.2213,LEV,4.03)=$P($P($G(IBSEG(2)),HLCMP,9),HLSCMP) ;Entity type qual
S IBFDA(356.2213,LEV,4.04)=$P($G(IBSEG(2)),HLCMP) ;Contact last or company name
S IBFDA(356.2213,LEV,4.05)=$P($G(IBSEG(2)),HLCMP,2) ;contact first
S IBFDA(356.2213,LEV,4.06)=$P($G(IBSEG(2)),HLCMP,3) ;contact middle
S IBFDA(356.2213,LEV,4.07)=$P($G(IBSEG(2)),HLCMP,4) ;contact suffix
S IBFDA(356.2213,LEV,4.08)=$P($G(IBSEG(7)),HLCMP) ;ident code qualifier
S IBFDA(356.2213,LEV,4.09)=$P($G(IBSEG(7)),HLCMP,2) ;ident code
S IBFDA(356.2213,LEV,5)=$P($G(IBSEG(4)),HLCMP) ;contact addr line 1
S IBFDA(356.2213,LEV,5.01)=$P($G(IBSEG(4)),HLCMP,2) ;contact addr line 2
S IBFDA(356.2213,LEV,5.02)=$P($G(IBSEG(4)),HLCMP,3) ;contact city
S IBFDA(356.2213,LEV,5.03)=$P($G(IBSEG(4)),HLCMP,4) ;contact state
S IBFDA(356.2213,LEV,5.04)=$P($G(IBSEG(4)),HLCMP,5) ;contact zip
S IBFDA(356.2213,LEV,5.05)=$P($G(IBSEG(4)),HLCMP,6) ;contact country
S IBFDA(356.2213,LEV,5.06)=$P($G(IBSEG(4)),HLCMP,8) ;contact country subdivision
D UP^IBTRHLI2("NM1","2010EB")
Q
;
PSL(IBSEG,RESIEN,ERROR,SLIEN) ;PSL Product/Service Line Item seg
; Input:
; IBSEG,RESIEN,SLIEN
;
; Output:
; ERROR
N LEV,IBFDA,CT,RIEN,LEV1
I $G(IBSEG(1))="SV1 2000F" D D UP^IBTRHLI2("SV1","2000F"),PSL2("P") Q
.D SLCHECK^IBTRHLI1,PSL3("P")
.S IBFDA(356.2216,LEV1,1.01)=$P($G(IBSEG(7)),HLCMP) ;SV101-1
.S IBFDA(356.2216,LEV1,1.04)=$P($G(IBSEG(8)),HLCMP) ;SV101-3
.S IBFDA(356.2216,LEV1,1.05)=$P($G(IBSEG(8)),HLCMP,2) ;SV101-4
.S IBFDA(356.2216,LEV1,1.06)=$P($G(IBSEG(8)),HLCMP,4) ;SV101-5
.S IBFDA(356.2216,LEV1,1.07)=$P($G(IBSEG(8)),HLCMP,5) ;SV101-6
.S IBFDA(356.2216,LEV1,1.08)=$G(IBSEG(9)) ;SV101-7
.;S IBFDA(356.2216,LEV1,1.03)=$P($G(IBSEG(7)),HLCMP,5) ;SV101-8
.S IBFDA(356.2216,LEV1,1.09)=$G(IBSEG(15)) ;SV102
.;S IBFDA(356.2216,LEV1,1.1)=$P($G(IBSEG(12)),HLCMP,2) ;SV103
.S IBFDA(356.2216,LEV1,1.11)=$P($G(IBSEG(12)),HLCMP) ;SV104
.S IBFDA(356.2216,LEV1,2.05)=$G(IBSEG(47)) ;SV111
.S IBFDA(356.2216,LEV1,2.09)=$G(IBSEG(48)) ;SV120
.Q
I $G(IBSEG(1))="SV2 2000F" D D UP^IBTRHLI2("SV2","2000F"),PSL2("I") Q
.D SLCHECK^IBTRHLI1,PSL3("I")
.S IBFDA(356.2216,LEV1,2.06)=$G(IBSEG(17)) ;SV201
.S IBFDA(356.2216,LEV1,1.01)=$P($G(IBSEG(7)),HLCMP) ;SV202-1
.S IBFDA(356.2216,LEV1,1.04)=$P($G(IBSEG(8)),HLCMP) ;SV202-3
.S IBFDA(356.2216,LEV1,1.05)=$P($G(IBSEG(8)),HLCMP,2) ;SV202-4
.S IBFDA(356.2216,LEV1,1.06)=$P($G(IBSEG(8)),HLCMP,4) ;SV202-5
.S IBFDA(356.2216,LEV1,1.07)=$P($G(IBSEG(8)),HLCMP,5) ;SV202-6
.S IBFDA(356.2216,LEV1,1.08)=$G(IBSEG(9)) ;SV202-7
.;S IBFDA(356.2216,LEV1,1.03)=$P($G(IBSEG(7)),HLCMP,5) ;SV202-8
.S IBFDA(356.2216,LEV1,1.09)=$G(IBSEG(15)) ;SV203
.S IBFDA(356.2216,LEV1,1.11)=$P($G(IBSEG(12)),HLCMP) ;SV205
.S IBFDA(356.2216,LEV1,2.07)=$G(IBSEG(13)) ;SV206
.S IBFDA(356.2216,LEV1,2.09)=$G(IBSEG(48)) ;SV210
.Q
I $G(IBSEG(1))="SV3 2000F" D D UP^IBTRHLI2("SV3","2000F"),PSL2("D") Q
.D SLCHECK^IBTRHLI1,PSL3("D")
.S IBFDA(356.2216,LEV1,1.01)=$P($G(IBSEG(7)),HLCMP) ;SV301-1
.S IBFDA(356.2216,LEV1,1.04)=$P($G(IBSEG(8)),HLCMP) ;SV301-3
.S IBFDA(356.2216,LEV1,1.05)=$P($G(IBSEG(8)),HLCMP,2) ;SV301-4
.S IBFDA(356.2216,LEV1,1.06)=$P($G(IBSEG(8)),HLCMP,4) ;SV301-5
.S IBFDA(356.2216,LEV1,1.07)=$P($G(IBSEG(8)),HLCMP,5) ;SV301-6
.S IBFDA(356.2216,LEV1,1.08)=$G(IBSEG(9)) ;SV301-7
.;S IBFDA(356.2216,LEV1,1.03)=$P($G(IBSEG(7)),HLCMP,5) ;SV301-8
.S IBFDA(356.2216,LEV1,1.09)=$G(IBSEG(15)) ;SV302
.S IBFDA(356.2216,LEV1,1.11)=$P($G(IBSEG(12)),HLCMP) ;SV306
.S IBFDA(356.2216,LEV1,3.06)=$G(IBSEG(17)) ;SV305
.S IBFDA(356.2216,LEV1,3.01)=$P($G(IBSEG(33)),HLCMP) ;SV304-1
.S IBFDA(356.2216,LEV1,3.02)=$P($G(IBSEG(33)),HLCMP,2) ;SV304-2
.S IBFDA(356.2216,LEV1,3.03)=$P($G(IBSEG(33)),HLCMP,4) ;SV304-3
.S IBFDA(356.2216,LEV1,3.04)=$P($G(IBSEG(33)),HLCMP,5) ;SV304-4
.S IBFDA(356.2216,LEV1,3.05)=$P($G(IBSEG(33)),HLCMP,9) ;SV304-5
.Q
I $G(IBSEG(1))="TOO 2000F" D D UP^IBTRHLI2("TOO","2000F") Q
.S LEV="+3,"_SLIEN_","_RESIEN_","
.S IBFDA(356.22164,LEV,.01)=$P($G(IBSEG(7)),HLCMP,2) ;TOO02
.S IBFDA(356.22164,LEV,.02)=$P($G(IBSEG(33)),HLCMP) ;TOO03-1
.S IBFDA(356.22164,LEV,.03)=$P($G(IBSEG(33)),HLCMP,2) ;TOO03-2
.S IBFDA(356.22164,LEV,.04)=$P($G(IBSEG(33)),HLCMP,4) ;TOO03-3
.S IBFDA(356.22164,LEV,.05)=$P($G(IBSEG(33)),HLCMP,5) ;TOO03-4
.S IBFDA(356.22164,LEV,.06)=$P($G(IBSEG(33)),HLCMP,9) ;TOO03-5
.Q
I $G(IBSEG(1))="PWK 2000F" D D UP^IBTRHLI2("PWK","2000F") Q
.S LEV="+3,"_SLIEN_","_RESIEN_","
.S IBFDA(356.22166,LEV,.01)=$P($G(IBSEG(19)),HLCMP) ;PWK01
.S IBFDA(356.22166,LEV,.02)=$G(IBSEG(20)) ;PWK02
.S IBFDA(356.22166,LEV,.03)=$P($G(IBSEG(19)),HLCMP,2) ;PWK03
.S IBFDA(356.22166,LEV,.04)=$P($G(IBSEG(19)),HLCMP,3) ;PWK04
.Q
I $G(IBSEG(1))="PWK 2000E" D D UP^IBTRHLI2("PWK","2000E") Q
.S LEV="+2,"_RESIEN_","
.S CT=$O(^IBT(356.22,RESIEN,11,"A"),-1)+1
.S IBFDA(356.2211,LEV,.01)=$P($G(IBSEG(19)),HLCMP) ;RPT TYPE CODE
.S IBFDA(356.2211,LEV,.02)=$G(IBSEG(20)) ;RPT TRANS CODE
.S IBFDA(356.2211,LEV,.03)=$P($G(IBSEG(19)),HLCMP,2) ;ATTACHMENT CTL #
.S IBFDA(356.2211,LEV,.04)=$P($G(IBSEG(19)),HLCMP,3) ;ATTACHMENT DESC
Q
PSL2(TYPE) ;
N PTR
I $D(ERROR) Q
; I National Drug code type (5-4-2 format) set NDC Code #1
I $P($G(IBSEG(7)),HLCMP)="N4" D
.S IBFDA(356.2216,LEV1,12.01)=$P($G(IBSEG(7)),HLCMP,2)
S PTR=$$CODE($P($G(IBSEG(7)),HLCMP),$P($G(IBSEG(7)),HLCMP,2))
S IBFDA(356.2216,LEV1,1.02)=PTR ;SV101-2, SV201-2, SV301-2
I TYPE'="D" S IBFDA(356.2216,LEV1,1.1)=$P($G(IBSEG(12)),HLCMP,2) ;SV103, SV204
K ERROR
D FILE^DIE("","IBFDA","ERROR")
I $D(ERROR) D ERR^IBTRHLI2($P(IBSEG(1)," ")_" Loop "_$P(IBSEG(1)," ",2),$P(IBSEG(1)," ",2))
I $P($G(IBSEG(7)),HLCMP,5)="" Q
S PTR=$$CODE($P($G(IBSEG(7)),HLCMP),$P($G(IBSEG(7)),HLCMP,5)) ;SV101-8, SV202-8, SV301-8
S IBFDA(356.2216,LEV1,1.03)=PTR
; I National Drug code type (5-4-2 format) set NDC Code #2
I $P($G(IBSEG(7)),HLCMP)="N4" S IBFDA(356.2216,LEV1,12.02)=$P($G(IBSEG(7)),HLCMP,5)
K ERROR
D FILE^DIE("","IBFDA","ERROR")
I $D(ERROR) D ERR^IBTRHLI2($P(IBSEG(1)," ")_" Loop "_$P(IBSEG(1)," ",2),$P(IBSEG(1)," ",2))
Q
;
PSL3(TYPE) ;
; this is being created here due to file SCREENing on field 356.2216, 1.01 needs 1.12 set 1st
K ERROR
S IBFDA(356.2216,LEV1,1.12)=TYPE ;Set service line type
D FILE^DIE("","IBFDA","ERROR")
I $D(ERROR) D ERR^IBTRHLI2($P(IBSEG(1)," ")_" Loop "_$P(IBSEG(1)," ",2),$P(IBSEG(1)," ",2))
Q
;
CODE(TYPE,CODE) ; obtain Variable Procedure Code pointer
I $G(RIEN(2)),RIEN(2)'=$G(SLIEN) S SLIEN=RIEN(2),LEV=SLIEN_","_RESIEN_","
N SCRN,PTR
S (PTR,SCRN)=""
I TYPE="HC"!(TYPE="AD") D
.S PTR=$$FIND1^DIC(81,,"P",CODE,"B",SCRN)
.I PTR S PTR=PTR_";ICPT("
I TYPE="ID"!(PTR="ZZ") D
.S PTR=$$FIND1^DIC(80.1,,"P",CODE,"AB",SCRN)
.I PTR S PTR=PTR_";ICD0("
Q PTR
;
NTE(IBSEG,RESIEN,ERROR) ;NTE Notes seg
; Input:
; IBSEG,RESIEN
;
; Output:
; ERROR
N LEV,IBFDA,RIEN
I $G(IBSEG(4))="MSG 2000E" D Q
.S LEV=RESIEN_","
.S IBFDA(1)=$G(IBSEG(3))
.D WP^DIE(356.22,LEV,12,"","IBFDA","ERROR")
.I $D(ERROR) D ERR^IBTRHLI2("Problem loading MSG Loop 2000E segment data","2000E")
.Q
I $G(IBSEG(4))="MSG 2000F" D Q
.S LEV=SLIEN_","_RESIEN_","
.S IBFDA(1)=$G(IBSEG(3))
.D WP^DIE(356.2216,LEV,7,"","IBFDA","ERROR")
.I $D(ERROR) D ERR^IBTRHLI2("Problem loading MSG Loop 2000F segment data","2000F")
.Q
Q
;
DG1(IBSEG,RESIEN,ERROR,SLIEN) ;
; Input:
; IBSEG,RESIEN,SLIEN
;
; Output:
; ERROR
N CT,LEV,IBFDA,RIEN,LEV1,LEV2,PTR
I $G(IBSEG(11))="HI 2000F" D Q
.D SLCHECK^IBTRHLI1
.S LEV="+3,"_SLIEN_","_RESIEN_","
.S IBFDA(356.2316,LEV,.01)=$G(IBSEG(1)) ;HI sequence
.S IBFDA(356.2316,LEV,.02)=$G(IBSEG(17)) ;Code list qualifier
.D UP^IBTRHLI2("HI","2000F")
.I '$G(RIEN(3)) Q
.S LEV2=RIEN(3)_","_RESIEN_","
.S PTR=$$CODE1($G(IBSEG(17)),$P($G(IBSEG(3)),HLCMP))
.S IBFDA(356.2316,LEV2,.03)=PTR ;Code
.K ERROR
.D FILE^DIE("","IBFDA","ERROR")
.I $D(ERROR) D ERR^IBTRHLI2("HI Loop 2000F","2000F") Q
.Q
S LEV="+2,"_RESIEN_","
S IBFDA(356.223,LEV,.01)=$G(IBSEG(17)) ;Code list qualifier
S IBFDA(356.223,LEV,.03)=$G(IBSEG(5)) ;Date
D UP^IBTRHLI2("HI","2000E")
S LEV2=RIEN(2)_","_RESIEN_","
S PTR=$$CODE1($G(IBSEG(17)),$P($G(IBSEG(3)),HLCMP))
S IBFDA(356.223,LEV2,.02)=PTR ;Code
K ERROR
D FILE^DIE("","IBFDA","ERROR")
I $D(ERROR) D ERR^IBTRHLI2("HI Loop 2000E","2000E") Q
Q
CODE1(TYPE,CODE) ; obtain Variable Procedure Code pointer
N SCRN,PTR
S (PTR,SCRN)=""
I TYPE="DR" D
.S PTR=$$FIND1^DIC(80.2,,"P",CODE,"B",SCRN)
.I PTR S PTR=PTR_";ICD("
I TYPE="LOI" D
.S CODE=$P(CODE,"-")
.S PTR=$$FIND1^DIC(95.3,,"P",CODE,"B",SCRN)
E D
.S CODE=$E(CODE,1,3)_"."_$E(CODE,4,99) ;1/31/15 decimals stripped for transmitting
.S PTR=$$FIND1^DIC(80,,"P",CODE,"AB",SCRN)
.I PTR S PTR=PTR_";ICD9(" Q
.; IF xxx.xx is not found, try xxxx.xx if 1st char = 'E'
.I $E(CODE)'="E" Q
.S CODE=$E(CODE,1,4)_"."_$E(CODE,5,99) ; 2/5/15 there are some 4 char 1st dec half of ICD9 codes
.S PTR=$$FIND1^DIC(80,,"P",CODE,"AB",SCRN)
.I PTR S PTR=PTR_";ICD9(" Q
Q PTR
;
RXA(IBSEG,RESIEN,ERROR) ;RXA Pharmacy/Treatment Admin seg
; Input:
; IBSEG,RESIEN
;
; Output:
; ERROR
N LEV,IBFDA,RIEN
S LEV=RESIEN_","
S IBFDA(356.22,LEV,7.05)=$G(IBSEG(1)) ;TREATMENT SERIES #
S IBFDA(356.22,LEV,7.06)=$G(IBSEG(2)) ;TREATMENT COUNT
S IBFDA(356.22,LEV,7.07)=$P($G(IBSEG(9)),HLREP) ;SUBLUXATION LEVEL CODE#1
S IBFDA(356.22,LEV,7.08)=$P($G(IBSEG(9)),HLREP,2) ;SUBLUXATION LEVEL CODE#2
D UP^IBTRHLI2("CR2","2000E")
Q
;
FNDCT(DFN,EVNTDT,RESIEN) ; find matching CT entry in file 356
; DFN - file 2 ien
; EVNTDT - event date from 356.22/.07
; RESIEN - ien of the response in file 356.22
;
; returns file 356 ien of matching ct entry or null if no match found
;
N CTIEN,EDT,EVTYPE,INPAT,RES,STOPFLG
S RES=""
I +$G(DFN)>0,+$G(EVNTDT)>0,+$G(RESIEN)>0 D
.S EDT=$P(EVNTDT,"-")
.S INPAT=$S($P($G(^IBT(356.22,RESIEN,0)),U,4)="I":1,1:0)
.I INPAT S STOPFLG=0 F EVTYPE=1,5 D Q:STOPFLG
..S CTIEN=+$O(^IBT(356,"APTY",DFN,EVTYPE,EDT,"")) I CTIEN>0 S RES=CTIEN,STOPFLG=1
..Q
.I 'INPAT S EVTYPE=2,CTIEN=+$O(^IBT(356,"APTY",DFN,EVTYPE,EDT,"")) S:CTIEN>0 RES=CTIEN
.Q
Q RES
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBTRHLI3 16759 printed Dec 13, 2024@02:28:27 Page 2
IBTRHLI3 ;ALB/JWS - Receive and store 278 Response message ;05-JUN-2014
+1 ;;2.0;INTEGRATED BILLING;**517**;21-MAR-94;Build 240
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;**Program Description**
+5 ; This pgm will process the indiv segments of the
+6 ; incoming 278 response msgs.
+7 ;
+8 ; * Each of these tags are called by IBTRHL2.
+9 ;
+10 ; This routine is based on IBCNEHL2 which was introduced with patch 300, and subsequently
+11 ; patched with patches 345, 416, and 438.
+12 ;
+13 ; Variables
+14 ; SEG = HL7 Seg Name
+15 ; IBSEG = Array of the segment
+16 ;
+17 ; No direct calls
QUIT
+18 ;
ZTP(IBSEG,RESIEN,ERROR,SLIEN) ; Process ZTP Subscriber date seg (X12 DTP segs)
+1 ; Input:
+2 ; IBSEG,RESIEN,SLIEN
+3 ;
+4 ; Output:
+5 ; ERROR
+6 NEW FLD,LEV,IBFDA,RIEN,LEV1
+7 IF $GET(IBSEG(4))="DTP 2000F"
Begin DoDot:1
+8 DO SLCHECK^IBTRHLI1
+9 ;service date
IF $GET(IBSEG(2))=472
SET IBFDA(356.2216,LEV1,.11)=$PIECE($GET(IBSEG(3)),HLCMP)
SET IBFDA(356.2216,LEV1,.17)=$PIECE($GET(IBSEG(3)),HLCMP,2)
QUIT
+10 ;cert issue date
IF $GET(IBSEG(2))=102
SET IBFDA(356.2216,LEV1,.12)=$PIECE($GET(IBSEG(3)),HLCMP)
QUIT
+11 ;cert expiration date
IF $GET(IBSEG(2))="036"
SET IBFDA(356.2216,LEV1,.13)=$PIECE($GET(IBSEG(3)),HLCMP)
QUIT
+12 ;cert effective date
IF $GET(IBSEG(2))="007"
SET IBFDA(356.2216,LEV1,.14)=$PIECE($GET(IBSEG(3)),HLCMP)
SET IBFDA(356.2216,LEV1,.16)=$PIECE($GET(IBSEG(3)),HLCMP,2)
QUIT
End DoDot:1
DO UP^IBTRHLI2("DTP","2000F")
QUIT
+13 SET LEV="+2,"_RESIEN_","
+14 ;Accident Date
IF $GET(IBSEG(2))=439
SET FLD=2.18
GOTO ZTP1
+15 ;Last Menstrual Period
IF $GET(IBSEG(2))=484
SET FLD=2.19
GOTO ZTP1
+16 ;Estimated DOB
IF $GET(IBSEG(2))="ABC"
SET FLD=2.2
GOTO ZTP1
+17 ;Illness Date
IF $GET(IBSEG(2))=431
SET FLD=2.21
GOTO ZTP1
+18 IF $GET(IBSEG(2))="AAH"!($GET(IBSEG(2)))=435
SET FLD=".07"
GOTO ZTP1
+19 ;discharge date
IF $GET(IBSEG(2))="096"
SET FLD=2.22
GOTO ZTP1
+20 ;Cert Issue Date
IF $GET(IBSEG(2))=102
SET FLD=2.23
GOTO ZTP1
+21 ;Cert Expiration Date
IF $GET(IBSEG(2))="036"
SET FLD=2.24
GOTO ZTP1
+22 ;Cert Effective Date
IF $GET(IBSEG(2))="007"
SET FLD=2.25
SET IBFDA(356.22,RESIEN_",",2.26)=$PIECE($GET(IBSEG(3)),HLCMP,2)
GOTO ZTP1
+23 QUIT
ZTP1 ;
+1 SET IBFDA(356.22,RESIEN_",",FLD)=$PIECE($GET(IBSEG(3)),HLCMP)
+2 DO UP^IBTRHLI2("DTP","2000E")
+3 QUIT
+4 ;
RXE(IBSEG,RESIEN,ERROR) ;RXE Pharmacy/Treatment Encoded Order seg
+1 ; Input:
+2 ; IBSEG,RESIEN
+3 ;
+4 ; Output:
+5 ; ERROR
+6 NEW LEV,IBFDA,RIEN
+7 SET LEV=RESIEN_","
+8 ;CR503 OXY EQUIP TYPE
SET IBFDA(356.22,LEV,8.01)=$PIECE($PIECE($GET(IBSEG(14)),HLREP),HLCMP)
+9 ;CR504 OXY EQUIP TYPE
SET IBFDA(356.22,LEV,8.02)=$PIECE($PIECE($GET(IBSEG(14)),HLREP,2),HLCMP)
+10 ;CR506 OXY FLOW RATE
SET IBFDA(356.22,LEV,8.05)=$GET(IBSEG(23))
+11 ;CR507 DAILY OXY USE CNT
SET IBFDA(356.22,LEV,8.06)=$PIECE($GET(IBSEG(19)),HLCMP)
+12 ;CR508 OXY USE PERIOD HR CNT
SET IBFDA(356.22,LEV,8.07)=$PIECE($PIECE($GET(IBSEG(1)),HLCMP),HLSCMP)
+13 ;CR509 RESP THERAPIST TEXT
SET IBFDA(356.22,LEV,8.08)=$PIECE($GET(IBSEG(1)),HLCMP,8)
+14 ;CR516 PORT OXY SYS FLOW
SET IBFDA(356.22,LEV,9.07)=$GET(IBSEG(16))
+15 ;CR517 OXY DEL SYS CODE
SET IBFDA(356.22,LEV,9.08)=$PIECE($GET(IBSEG(29)),HLCMP)
+16 ;CR518 OXY EQUIP TYPE
SET IBFDA(356.22,LEV,8.03)=$PIECE($GET(IBSEG(31)),HLCMP,1)
+17 DO UP^IBTRHLI2("CR5","2000E")
+18 QUIT
ZHS(IBSEG,RESIEN,ERROR,SLIEN) ; ZHS Healthcare services delivery seg
+1 ; Input:
+2 ; IBSEG,RESIEN,SLIEN
+3 ;
+4 ; Output:
+5 ; ERROR
+6 NEW CT,LEV,IBFDA,RIEN
+7 IF $GET(IBSEG(1))="HSD 2000F"
Begin DoDot:1
+8 SET LEV=SLIEN_","_RESIEN_","
+9 ;HCSD Quantity Qualifier
SET IBFDA(356.2216,LEV,5.01)=$GET(IBSEG(2))
+10 ;HCSD Service Unit Count
SET IBFDA(356.2216,LEV,5.02)=$GET(IBSEG(3))
+11 ;HCSD Units of Measurement
SET IBFDA(356.2216,LEV,5.03)=$GET(IBSEG(4))
+12 ;HCSD Sample Selection Modulus
SET IBFDA(356.2216,LEV,5.04)=$GET(IBSEG(5))
+13 ;HCSD Time Period Qualifier
SET IBFDA(356.2216,LEV,5.05)=$GET(IBSEG(6))
+14 ;HCSD Period Count
SET IBFDA(356.2216,LEV,5.06)=$GET(IBSEG(7))
+15 ;HCSD Delivery Frequency
SET IBFDA(356.2216,LEV,5.07)=$GET(IBSEG(8))
+16 ;HCSD Delivery Time Pattern
SET IBFDA(356.2216,LEV,5.08)=$GET(IBSEG(9))
+17 QUIT
End DoDot:1
DO UP^IBTRHLI2("HSD","2000F")
QUIT
+18 SET LEV=RESIEN_","
+19 ; quantity qualifier
SET IBFDA(356.22,LEV,4.01)=$GET(IBSEG(2))
+20 ; unit count
SET IBFDA(356.22,LEV,4.02)=$GET(IBSEG(3))
+21 ;measurement code
SET IBFDA(356.22,LEV,4.03)=$GET(IBSEG(4))
+22 ;selection modulus
SET IBFDA(356.22,LEV,4.04)=$GET(IBSEG(5))
+23 ;period qualifier
SET IBFDA(356.22,LEV,4.05)=$GET(IBSEG(6))
+24 ;period count
SET IBFDA(356.22,LEV,4.06)=$GET(IBSEG(7))
+25 ;freq code
SET IBFDA(356.22,LEV,4.07)=$GET(IBSEG(8))
+26 ;pattern
SET IBFDA(356.22,LEV,4.08)=$GET(IBSEG(9))
+27 DO UP^IBTRHLI2("HSD","2000E")
+28 QUIT
+29 ;
CTD(IBSEG,RESIEN,ERROR,PEIEN,SLIEN,SLPIEN) ; CTD Contact Data seg
+1 ; Input:
+2 ; IBSEG,RESIEN,PEIEN,SLIEN,SLPIEN
+3 ;
+4 ; Output:
+5 ; ERROR
+6 NEW RIEN,LEV
+7 IF $GET(IBSEG(1))="PER 2010EB"
Begin DoDot:1
+8 SET LEV=PEIEN_","_RESIEN_","
+9 SET IBFDA(356.2213,LEV,.04)="2010EB"
+10 SET IBFDA(356.2213,LEV,.05)="IC"
+11 ;CONTACT NAME
SET IBFDA(356.2213,LEV,.06)=$PIECE($GET(IBSEG(2)),HLCMP)
+12 ;COMM NO QUAL1
SET IBFDA(356.2213,LEV,.07)=$PIECE($PIECE($GET(IBSEG(5)),HLREP),HLCMP,2)
+13 ;COMM NO QUAL2
SET IBFDA(356.2213,LEV,.08)=$PIECE($PIECE($GET(IBSEG(5)),HLREP,2),HLCMP,2)
+14 ;COMM NO QUAL3
SET IBFDA(356.2213,LEV,.09)=$PIECE($PIECE($GET(IBSEG(5)),HLREP,3),HLCMP,2)
+15 ;CONTACT COMM NUM1
SET IBFDA(356.2213,LEV,1)=$PIECE($PIECE($GET(IBSEG(5)),HLREP),HLCMP,8)
+16 ;CONTACT COMM NUM2
SET IBFDA(356.2213,LEV,2)=$PIECE($PIECE($GET(IBSEG(5)),HLREP,2),HLCMP,8)
+17 ;CONTACT COMM NUM3
SET IBFDA(356.2213,LEV,3)=$PIECE($PIECE($GET(IBSEG(5)),HLREP,3),HLCMP,8)
+18 QUIT
End DoDot:1
DO UP^IBTRHLI2("PER","2010EB")
QUIT
+19 IF $GET(IBSEG(1))="PER 2010FB"
Begin DoDot:1
+20 SET LEV=SLPIEN_","_SLIEN_","_RESIEN_","
+21 ;PER loop identifier
SET IBFDA(356.22168,LEV,.04)="2010FB"
+22 ;CONTACT FUNCTION CODE
SET IBFDA(356.22168,LEV,.05)="IC"
+23 ;CONTACT NAME
SET IBFDA(356.22168,LEV,.06)=$PIECE($GET(IBSEG(2)),HLCMP)
+24 ;COMM NO QUAL1
SET IBFDA(356.22168,LEV,.07)=$PIECE($PIECE($GET(IBSEG(5)),HLREP),HLCMP,2)
+25 ;COMM NO QUAL2
SET IBFDA(356.22168,LEV,.08)=$PIECE($PIECE($GET(IBSEG(5)),HLREP,2),HLCMP,2)
+26 ;COMM NO QUAL3
SET IBFDA(356.22168,LEV,.09)=$PIECE($PIECE($GET(IBSEG(5)),HLREP,3),HLCMP,2)
+27 ;CONTACT COMM NUM1
SET IBFDA(356.22168,LEV,1)=$PIECE($PIECE($GET(IBSEG(5)),HLREP),HLCMP,8)
+28 ;CONTACT COMM NUM2
SET IBFDA(356.22168,LEV,2)=$PIECE($PIECE($GET(IBSEG(5)),HLREP,2),HLCMP,8)
+29 ;CONTACT COMM NUM3
SET IBFDA(356.22168,LEV,3)=$PIECE($PIECE($GET(IBSEG(5)),HLREP,3),HLCMP,8)
+30 QUIT
End DoDot:1
DO UP^IBTRHLI2("PER","2010FB")
QUIT
+31 QUIT
NK1(IBSEG,RESIEN,ERROR,PEIEN) ;NK1 Next of Kin seg
+1 ; Input:
+2 ; IBSEG,RESIEN,PEIEN
+3 ;
+4 ; Output:
+5 ; ERROR
+6 NEW LEV,IBFDA,RIEN
+7 SET LEV=PEIEN_","_RESIEN_","
+8 ;NM1 loop ident
SET IBFDA(356.2213,LEV,4.01)="2010EB"
+9 ;Entity ident
SET IBFDA(356.2213,LEV,4.02)="L5"
+10 ;Entity type qual
SET IBFDA(356.2213,LEV,4.03)=$PIECE($PIECE($GET(IBSEG(2)),HLCMP,9),HLSCMP)
+11 ;Contact last or company name
SET IBFDA(356.2213,LEV,4.04)=$PIECE($GET(IBSEG(2)),HLCMP)
+12 ;contact first
SET IBFDA(356.2213,LEV,4.05)=$PIECE($GET(IBSEG(2)),HLCMP,2)
+13 ;contact middle
SET IBFDA(356.2213,LEV,4.06)=$PIECE($GET(IBSEG(2)),HLCMP,3)
+14 ;contact suffix
SET IBFDA(356.2213,LEV,4.07)=$PIECE($GET(IBSEG(2)),HLCMP,4)
+15 ;ident code qualifier
SET IBFDA(356.2213,LEV,4.08)=$PIECE($GET(IBSEG(7)),HLCMP)
+16 ;ident code
SET IBFDA(356.2213,LEV,4.09)=$PIECE($GET(IBSEG(7)),HLCMP,2)
+17 ;contact addr line 1
SET IBFDA(356.2213,LEV,5)=$PIECE($GET(IBSEG(4)),HLCMP)
+18 ;contact addr line 2
SET IBFDA(356.2213,LEV,5.01)=$PIECE($GET(IBSEG(4)),HLCMP,2)
+19 ;contact city
SET IBFDA(356.2213,LEV,5.02)=$PIECE($GET(IBSEG(4)),HLCMP,3)
+20 ;contact state
SET IBFDA(356.2213,LEV,5.03)=$PIECE($GET(IBSEG(4)),HLCMP,4)
+21 ;contact zip
SET IBFDA(356.2213,LEV,5.04)=$PIECE($GET(IBSEG(4)),HLCMP,5)
+22 ;contact country
SET IBFDA(356.2213,LEV,5.05)=$PIECE($GET(IBSEG(4)),HLCMP,6)
+23 ;contact country subdivision
SET IBFDA(356.2213,LEV,5.06)=$PIECE($GET(IBSEG(4)),HLCMP,8)
+24 DO UP^IBTRHLI2("NM1","2010EB")
+25 QUIT
+26 ;
PSL(IBSEG,RESIEN,ERROR,SLIEN) ;PSL Product/Service Line Item seg
+1 ; Input:
+2 ; IBSEG,RESIEN,SLIEN
+3 ;
+4 ; Output:
+5 ; ERROR
+6 NEW LEV,IBFDA,CT,RIEN,LEV1
+7 IF $GET(IBSEG(1))="SV1 2000F"
Begin DoDot:1
+8 DO SLCHECK^IBTRHLI1
DO PSL3("P")
+9 ;SV101-1
SET IBFDA(356.2216,LEV1,1.01)=$PIECE($GET(IBSEG(7)),HLCMP)
+10 ;SV101-3
SET IBFDA(356.2216,LEV1,1.04)=$PIECE($GET(IBSEG(8)),HLCMP)
+11 ;SV101-4
SET IBFDA(356.2216,LEV1,1.05)=$PIECE($GET(IBSEG(8)),HLCMP,2)
+12 ;SV101-5
SET IBFDA(356.2216,LEV1,1.06)=$PIECE($GET(IBSEG(8)),HLCMP,4)
+13 ;SV101-6
SET IBFDA(356.2216,LEV1,1.07)=$PIECE($GET(IBSEG(8)),HLCMP,5)
+14 ;SV101-7
SET IBFDA(356.2216,LEV1,1.08)=$GET(IBSEG(9))
+15 ;S IBFDA(356.2216,LEV1,1.03)=$P($G(IBSEG(7)),HLCMP,5) ;SV101-8
+16 ;SV102
SET IBFDA(356.2216,LEV1,1.09)=$GET(IBSEG(15))
+17 ;S IBFDA(356.2216,LEV1,1.1)=$P($G(IBSEG(12)),HLCMP,2) ;SV103
+18 ;SV104
SET IBFDA(356.2216,LEV1,1.11)=$PIECE($GET(IBSEG(12)),HLCMP)
+19 ;SV111
SET IBFDA(356.2216,LEV1,2.05)=$GET(IBSEG(47))
+20 ;SV120
SET IBFDA(356.2216,LEV1,2.09)=$GET(IBSEG(48))
+21 QUIT
End DoDot:1
DO UP^IBTRHLI2("SV1","2000F")
DO PSL2("P")
QUIT
+22 IF $GET(IBSEG(1))="SV2 2000F"
Begin DoDot:1
+23 DO SLCHECK^IBTRHLI1
DO PSL3("I")
+24 ;SV201
SET IBFDA(356.2216,LEV1,2.06)=$GET(IBSEG(17))
+25 ;SV202-1
SET IBFDA(356.2216,LEV1,1.01)=$PIECE($GET(IBSEG(7)),HLCMP)
+26 ;SV202-3
SET IBFDA(356.2216,LEV1,1.04)=$PIECE($GET(IBSEG(8)),HLCMP)
+27 ;SV202-4
SET IBFDA(356.2216,LEV1,1.05)=$PIECE($GET(IBSEG(8)),HLCMP,2)
+28 ;SV202-5
SET IBFDA(356.2216,LEV1,1.06)=$PIECE($GET(IBSEG(8)),HLCMP,4)
+29 ;SV202-6
SET IBFDA(356.2216,LEV1,1.07)=$PIECE($GET(IBSEG(8)),HLCMP,5)
+30 ;SV202-7
SET IBFDA(356.2216,LEV1,1.08)=$GET(IBSEG(9))
+31 ;S IBFDA(356.2216,LEV1,1.03)=$P($G(IBSEG(7)),HLCMP,5) ;SV202-8
+32 ;SV203
SET IBFDA(356.2216,LEV1,1.09)=$GET(IBSEG(15))
+33 ;SV205
SET IBFDA(356.2216,LEV1,1.11)=$PIECE($GET(IBSEG(12)),HLCMP)
+34 ;SV206
SET IBFDA(356.2216,LEV1,2.07)=$GET(IBSEG(13))
+35 ;SV210
SET IBFDA(356.2216,LEV1,2.09)=$GET(IBSEG(48))
+36 QUIT
End DoDot:1
DO UP^IBTRHLI2("SV2","2000F")
DO PSL2("I")
QUIT
+37 IF $GET(IBSEG(1))="SV3 2000F"
Begin DoDot:1
+38 DO SLCHECK^IBTRHLI1
DO PSL3("D")
+39 ;SV301-1
SET IBFDA(356.2216,LEV1,1.01)=$PIECE($GET(IBSEG(7)),HLCMP)
+40 ;SV301-3
SET IBFDA(356.2216,LEV1,1.04)=$PIECE($GET(IBSEG(8)),HLCMP)
+41 ;SV301-4
SET IBFDA(356.2216,LEV1,1.05)=$PIECE($GET(IBSEG(8)),HLCMP,2)
+42 ;SV301-5
SET IBFDA(356.2216,LEV1,1.06)=$PIECE($GET(IBSEG(8)),HLCMP,4)
+43 ;SV301-6
SET IBFDA(356.2216,LEV1,1.07)=$PIECE($GET(IBSEG(8)),HLCMP,5)
+44 ;SV301-7
SET IBFDA(356.2216,LEV1,1.08)=$GET(IBSEG(9))
+45 ;S IBFDA(356.2216,LEV1,1.03)=$P($G(IBSEG(7)),HLCMP,5) ;SV301-8
+46 ;SV302
SET IBFDA(356.2216,LEV1,1.09)=$GET(IBSEG(15))
+47 ;SV306
SET IBFDA(356.2216,LEV1,1.11)=$PIECE($GET(IBSEG(12)),HLCMP)
+48 ;SV305
SET IBFDA(356.2216,LEV1,3.06)=$GET(IBSEG(17))
+49 ;SV304-1
SET IBFDA(356.2216,LEV1,3.01)=$PIECE($GET(IBSEG(33)),HLCMP)
+50 ;SV304-2
SET IBFDA(356.2216,LEV1,3.02)=$PIECE($GET(IBSEG(33)),HLCMP,2)
+51 ;SV304-3
SET IBFDA(356.2216,LEV1,3.03)=$PIECE($GET(IBSEG(33)),HLCMP,4)
+52 ;SV304-4
SET IBFDA(356.2216,LEV1,3.04)=$PIECE($GET(IBSEG(33)),HLCMP,5)
+53 ;SV304-5
SET IBFDA(356.2216,LEV1,3.05)=$PIECE($GET(IBSEG(33)),HLCMP,9)
+54 QUIT
End DoDot:1
DO UP^IBTRHLI2("SV3","2000F")
DO PSL2("D")
QUIT
+55 IF $GET(IBSEG(1))="TOO 2000F"
Begin DoDot:1
+56 SET LEV="+3,"_SLIEN_","_RESIEN_","
+57 ;TOO02
SET IBFDA(356.22164,LEV,.01)=$PIECE($GET(IBSEG(7)),HLCMP,2)
+58 ;TOO03-1
SET IBFDA(356.22164,LEV,.02)=$PIECE($GET(IBSEG(33)),HLCMP)
+59 ;TOO03-2
SET IBFDA(356.22164,LEV,.03)=$PIECE($GET(IBSEG(33)),HLCMP,2)
+60 ;TOO03-3
SET IBFDA(356.22164,LEV,.04)=$PIECE($GET(IBSEG(33)),HLCMP,4)
+61 ;TOO03-4
SET IBFDA(356.22164,LEV,.05)=$PIECE($GET(IBSEG(33)),HLCMP,5)
+62 ;TOO03-5
SET IBFDA(356.22164,LEV,.06)=$PIECE($GET(IBSEG(33)),HLCMP,9)
+63 QUIT
End DoDot:1
DO UP^IBTRHLI2("TOO","2000F")
QUIT
+64 IF $GET(IBSEG(1))="PWK 2000F"
Begin DoDot:1
+65 SET LEV="+3,"_SLIEN_","_RESIEN_","
+66 ;PWK01
SET IBFDA(356.22166,LEV,.01)=$PIECE($GET(IBSEG(19)),HLCMP)
+67 ;PWK02
SET IBFDA(356.22166,LEV,.02)=$GET(IBSEG(20))
+68 ;PWK03
SET IBFDA(356.22166,LEV,.03)=$PIECE($GET(IBSEG(19)),HLCMP,2)
+69 ;PWK04
SET IBFDA(356.22166,LEV,.04)=$PIECE($GET(IBSEG(19)),HLCMP,3)
+70 QUIT
End DoDot:1
DO UP^IBTRHLI2("PWK","2000F")
QUIT
+71 IF $GET(IBSEG(1))="PWK 2000E"
Begin DoDot:1
+72 SET LEV="+2,"_RESIEN_","
+73 SET CT=$ORDER(^IBT(356.22,RESIEN,11,"A"),-1)+1
+74 ;RPT TYPE CODE
SET IBFDA(356.2211,LEV,.01)=$PIECE($GET(IBSEG(19)),HLCMP)
+75 ;RPT TRANS CODE
SET IBFDA(356.2211,LEV,.02)=$GET(IBSEG(20))
+76 ;ATTACHMENT CTL #
SET IBFDA(356.2211,LEV,.03)=$PIECE($GET(IBSEG(19)),HLCMP,2)
+77 ;ATTACHMENT DESC
SET IBFDA(356.2211,LEV,.04)=$PIECE($GET(IBSEG(19)),HLCMP,3)
End DoDot:1
DO UP^IBTRHLI2("PWK","2000E")
QUIT
+78 QUIT
PSL2(TYPE) ;
+1 NEW PTR
+2 IF $DATA(ERROR)
QUIT
+3 ; I National Drug code type (5-4-2 format) set NDC Code #1
+4 IF $PIECE($GET(IBSEG(7)),HLCMP)="N4"
Begin DoDot:1
+5 SET IBFDA(356.2216,LEV1,12.01)=$PIECE($GET(IBSEG(7)),HLCMP,2)
End DoDot:1
+6 SET PTR=$$CODE($PIECE($GET(IBSEG(7)),HLCMP),$PIECE($GET(IBSEG(7)),HLCMP,2))
+7 ;SV101-2, SV201-2, SV301-2
SET IBFDA(356.2216,LEV1,1.02)=PTR
+8 ;SV103, SV204
IF TYPE'="D"
SET IBFDA(356.2216,LEV1,1.1)=$PIECE($GET(IBSEG(12)),HLCMP,2)
+9 KILL ERROR
+10 DO FILE^DIE("","IBFDA","ERROR")
+11 IF $DATA(ERROR)
DO ERR^IBTRHLI2($PIECE(IBSEG(1)," ")_" Loop "_$PIECE(IBSEG(1)," ",2),$PIECE(IBSEG(1)," ",2))
+12 IF $PIECE($GET(IBSEG(7)),HLCMP,5)=""
QUIT
+13 ;SV101-8, SV202-8, SV301-8
SET PTR=$$CODE($PIECE($GET(IBSEG(7)),HLCMP),$PIECE($GET(IBSEG(7)),HLCMP,5))
+14 SET IBFDA(356.2216,LEV1,1.03)=PTR
+15 ; I National Drug code type (5-4-2 format) set NDC Code #2
+16 IF $PIECE($GET(IBSEG(7)),HLCMP)="N4"
SET IBFDA(356.2216,LEV1,12.02)=$PIECE($GET(IBSEG(7)),HLCMP,5)
+17 KILL ERROR
+18 DO FILE^DIE("","IBFDA","ERROR")
+19 IF $DATA(ERROR)
DO ERR^IBTRHLI2($PIECE(IBSEG(1)," ")_" Loop "_$PIECE(IBSEG(1)," ",2),$PIECE(IBSEG(1)," ",2))
+20 QUIT
+21 ;
PSL3(TYPE) ;
+1 ; this is being created here due to file SCREENing on field 356.2216, 1.01 needs 1.12 set 1st
+2 KILL ERROR
+3 ;Set service line type
SET IBFDA(356.2216,LEV1,1.12)=TYPE
+4 DO FILE^DIE("","IBFDA","ERROR")
+5 IF $DATA(ERROR)
DO ERR^IBTRHLI2($PIECE(IBSEG(1)," ")_" Loop "_$PIECE(IBSEG(1)," ",2),$PIECE(IBSEG(1)," ",2))
+6 QUIT
+7 ;
CODE(TYPE,CODE) ; obtain Variable Procedure Code pointer
+1 IF $GET(RIEN(2))
IF RIEN(2)'=$GET(SLIEN)
SET SLIEN=RIEN(2)
SET LEV=SLIEN_","_RESIEN_","
+2 NEW SCRN,PTR
+3 SET (PTR,SCRN)=""
+4 IF TYPE="HC"!(TYPE="AD")
Begin DoDot:1
+5 SET PTR=$$FIND1^DIC(81,,"P",CODE,"B",SCRN)
+6 IF PTR
SET PTR=PTR_";ICPT("
End DoDot:1
+7 IF TYPE="ID"!(PTR="ZZ")
Begin DoDot:1
+8 SET PTR=$$FIND1^DIC(80.1,,"P",CODE,"AB",SCRN)
+9 IF PTR
SET PTR=PTR_";ICD0("
End DoDot:1
+10 QUIT PTR
+11 ;
NTE(IBSEG,RESIEN,ERROR) ;NTE Notes seg
+1 ; Input:
+2 ; IBSEG,RESIEN
+3 ;
+4 ; Output:
+5 ; ERROR
+6 NEW LEV,IBFDA,RIEN
+7 IF $GET(IBSEG(4))="MSG 2000E"
Begin DoDot:1
+8 SET LEV=RESIEN_","
+9 SET IBFDA(1)=$GET(IBSEG(3))
+10 DO WP^DIE(356.22,LEV,12,"","IBFDA","ERROR")
+11 IF $DATA(ERROR)
DO ERR^IBTRHLI2("Problem loading MSG Loop 2000E segment data","2000E")
+12 QUIT
End DoDot:1
QUIT
+13 IF $GET(IBSEG(4))="MSG 2000F"
Begin DoDot:1
+14 SET LEV=SLIEN_","_RESIEN_","
+15 SET IBFDA(1)=$GET(IBSEG(3))
+16 DO WP^DIE(356.2216,LEV,7,"","IBFDA","ERROR")
+17 IF $DATA(ERROR)
DO ERR^IBTRHLI2("Problem loading MSG Loop 2000F segment data","2000F")
+18 QUIT
End DoDot:1
QUIT
+19 QUIT
+20 ;
DG1(IBSEG,RESIEN,ERROR,SLIEN) ;
+1 ; Input:
+2 ; IBSEG,RESIEN,SLIEN
+3 ;
+4 ; Output:
+5 ; ERROR
+6 NEW CT,LEV,IBFDA,RIEN,LEV1,LEV2,PTR
+7 IF $GET(IBSEG(11))="HI 2000F"
Begin DoDot:1
+8 DO SLCHECK^IBTRHLI1
+9 SET LEV="+3,"_SLIEN_","_RESIEN_","
+10 ;HI sequence
SET IBFDA(356.2316,LEV,.01)=$GET(IBSEG(1))
+11 ;Code list qualifier
SET IBFDA(356.2316,LEV,.02)=$GET(IBSEG(17))
+12 DO UP^IBTRHLI2("HI","2000F")
+13 IF '$GET(RIEN(3))
QUIT
+14 SET LEV2=RIEN(3)_","_RESIEN_","
+15 SET PTR=$$CODE1($GET(IBSEG(17)),$PIECE($GET(IBSEG(3)),HLCMP))
+16 ;Code
SET IBFDA(356.2316,LEV2,.03)=PTR
+17 KILL ERROR
+18 DO FILE^DIE("","IBFDA","ERROR")
+19 IF $DATA(ERROR)
DO ERR^IBTRHLI2("HI Loop 2000F","2000F")
QUIT
+20 QUIT
End DoDot:1
QUIT
+21 SET LEV="+2,"_RESIEN_","
+22 ;Code list qualifier
SET IBFDA(356.223,LEV,.01)=$GET(IBSEG(17))
+23 ;Date
SET IBFDA(356.223,LEV,.03)=$GET(IBSEG(5))
+24 DO UP^IBTRHLI2("HI","2000E")
+25 SET LEV2=RIEN(2)_","_RESIEN_","
+26 SET PTR=$$CODE1($GET(IBSEG(17)),$PIECE($GET(IBSEG(3)),HLCMP))
+27 ;Code
SET IBFDA(356.223,LEV2,.02)=PTR
+28 KILL ERROR
+29 DO FILE^DIE("","IBFDA","ERROR")
+30 IF $DATA(ERROR)
DO ERR^IBTRHLI2("HI Loop 2000E","2000E")
QUIT
+31 QUIT
CODE1(TYPE,CODE) ; obtain Variable Procedure Code pointer
+1 NEW SCRN,PTR
+2 SET (PTR,SCRN)=""
+3 IF TYPE="DR"
Begin DoDot:1
+4 SET PTR=$$FIND1^DIC(80.2,,"P",CODE,"B",SCRN)
+5 IF PTR
SET PTR=PTR_";ICD("
End DoDot:1
+6 IF TYPE="LOI"
Begin DoDot:1
+7 SET CODE=$PIECE(CODE,"-")
+8 SET PTR=$$FIND1^DIC(95.3,,"P",CODE,"B",SCRN)
End DoDot:1
+9 IF '$TEST
Begin DoDot:1
+10 ;1/31/15 decimals stripped for transmitting
SET CODE=$EXTRACT(CODE,1,3)_"."_$EXTRACT(CODE,4,99)
+11 SET PTR=$$FIND1^DIC(80,,"P",CODE,"AB",SCRN)
+12 IF PTR
SET PTR=PTR_";ICD9("
QUIT
+13 ; IF xxx.xx is not found, try xxxx.xx if 1st char = 'E'
+14 IF $EXTRACT(CODE)'="E"
QUIT
+15 ; 2/5/15 there are some 4 char 1st dec half of ICD9 codes
SET CODE=$EXTRACT(CODE,1,4)_"."_$EXTRACT(CODE,5,99)
+16 SET PTR=$$FIND1^DIC(80,,"P",CODE,"AB",SCRN)
+17 IF PTR
SET PTR=PTR_";ICD9("
QUIT
End DoDot:1
+18 QUIT PTR
+19 ;
RXA(IBSEG,RESIEN,ERROR) ;RXA Pharmacy/Treatment Admin seg
+1 ; Input:
+2 ; IBSEG,RESIEN
+3 ;
+4 ; Output:
+5 ; ERROR
+6 NEW LEV,IBFDA,RIEN
+7 SET LEV=RESIEN_","
+8 ;TREATMENT SERIES #
SET IBFDA(356.22,LEV,7.05)=$GET(IBSEG(1))
+9 ;TREATMENT COUNT
SET IBFDA(356.22,LEV,7.06)=$GET(IBSEG(2))
+10 ;SUBLUXATION LEVEL CODE#1
SET IBFDA(356.22,LEV,7.07)=$PIECE($GET(IBSEG(9)),HLREP)
+11 ;SUBLUXATION LEVEL CODE#2
SET IBFDA(356.22,LEV,7.08)=$PIECE($GET(IBSEG(9)),HLREP,2)
+12 DO UP^IBTRHLI2("CR2","2000E")
+13 QUIT
+14 ;
FNDCT(DFN,EVNTDT,RESIEN) ; find matching CT entry in file 356
+1 ; DFN - file 2 ien
+2 ; EVNTDT - event date from 356.22/.07
+3 ; RESIEN - ien of the response in file 356.22
+4 ;
+5 ; returns file 356 ien of matching ct entry or null if no match found
+6 ;
+7 NEW CTIEN,EDT,EVTYPE,INPAT,RES,STOPFLG
+8 SET RES=""
+9 IF +$GET(DFN)>0
IF +$GET(EVNTDT)>0
IF +$GET(RESIEN)>0
Begin DoDot:1
+10 SET EDT=$PIECE(EVNTDT,"-")
+11 SET INPAT=$SELECT($PIECE($GET(^IBT(356.22,RESIEN,0)),U,4)="I":1,1:0)
+12 IF INPAT
SET STOPFLG=0
FOR EVTYPE=1,5
Begin DoDot:2
+13 SET CTIEN=+$ORDER(^IBT(356,"APTY",DFN,EVTYPE,EDT,""))
IF CTIEN>0
SET RES=CTIEN
SET STOPFLG=1
+14 QUIT
End DoDot:2
if STOPFLG
QUIT
+15 IF 'INPAT
SET EVTYPE=2
SET CTIEN=+$ORDER(^IBT(356,"APTY",DFN,EVTYPE,EDT,""))
if CTIEN>0
SET RES=CTIEN
+16 QUIT
End DoDot:1
+17 QUIT RES
