- 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 Apr 23, 2025@18:43:03 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
