| 1 | IBCNRZPL ;DAOU/DMK - Receive HL7 e-Pharmacy ZPL Segment ;23-OCT-2003
|
|---|
| 2 | ;;2.0;INTEGRATED BILLING;**251**;21-MAR-94
|
|---|
| 3 | ;;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | ;
|
|---|
| 5 | ; Description
|
|---|
| 6 | ;
|
|---|
| 7 | ; Receive HL7 e-Pharmacy ZPL Segment
|
|---|
| 8 | ; 366.03 PLAN File Update
|
|---|
| 9 | ;
|
|---|
| 10 | ; Called by IBCNRHLT
|
|---|
| 11 | ;
|
|---|
| 12 | ; Entry point
|
|---|
| 13 | ;
|
|---|
| 14 | 1000 ; Control ZPL Segment processing
|
|---|
| 15 | D INIT
|
|---|
| 16 | Q
|
|---|
| 17 | ;
|
|---|
| 18 | INIT ; Initialize ZPL Segment variables
|
|---|
| 19 | ; 366.03 PLAN File
|
|---|
| 20 | ;
|
|---|
| 21 | N NAME
|
|---|
| 22 | ;
|
|---|
| 23 | ; .01 = ID
|
|---|
| 24 | S DATA(.01)=$G(IBSEG(4))
|
|---|
| 25 | ;
|
|---|
| 26 | ; Error?
|
|---|
| 27 | ; V405 = Plan ID Missing
|
|---|
| 28 | I $TR(DATA(.01)," ","")="" S ERROR="V405" Q
|
|---|
| 29 | ;
|
|---|
| 30 | ; .02 = NAME
|
|---|
| 31 | S DATA(.02)=$G(IBSEG(5))
|
|---|
| 32 | ;
|
|---|
| 33 | ; Error?
|
|---|
| 34 | ; V410 = Plan Name Missing
|
|---|
| 35 | I $TR(DATA(.02)," ","")="" S ERROR="V410" Q
|
|---|
| 36 | ;
|
|---|
| 37 | ; .03 = PAYER NAME (pointer - 365.12)
|
|---|
| 38 | S DATA(.03)=$G(IBSEG(6))
|
|---|
| 39 | I DATA(.03)]"" S DATA(.03)=$$LOOKUP3^IBCNRFM1(365.12,"C",DATA(.03))
|
|---|
| 40 | ;
|
|---|
| 41 | ; Error?
|
|---|
| 42 | ; V415 = Payer ID Undefined
|
|---|
| 43 | I DATA(.03)=-1 S ERROR="V415" Q
|
|---|
| 44 | ;
|
|---|
| 45 | ; .04 = NAME - SHORT
|
|---|
| 46 | S DATA(.04)=$G(IBSEG(7))
|
|---|
| 47 | ;
|
|---|
| 48 | ; .05 = TYPE
|
|---|
| 49 | S DATA(.05)=$G(IBSEG(8))
|
|---|
| 50 | ;
|
|---|
| 51 | ; .06 = REGION
|
|---|
| 52 | S DATA(.06)=$G(IBSEG(9))
|
|---|
| 53 | ;
|
|---|
| 54 | ; .07 = DATE/TIME CREATED
|
|---|
| 55 | ; MAD = Add
|
|---|
| 56 | I IBCNACT="MAD",IEN=-1 S DATA(.07)=DATE("NOW")
|
|---|
| 57 | ;
|
|---|
| 58 | ; Initialize primary contact name variables
|
|---|
| 59 | S NAME=$G(IBSEG(10))
|
|---|
| 60 | D NAME
|
|---|
| 61 | ;
|
|---|
| 62 | ; 1.01 = PRIMARY CONTACT NAME
|
|---|
| 63 | S DATA(1.01)=NAME("NAME")
|
|---|
| 64 | ;
|
|---|
| 65 | ; 1.02 = PRIMARY CONTACT PREFIX
|
|---|
| 66 | S DATA(1.02)=NAME("PREFIX")
|
|---|
| 67 | ;
|
|---|
| 68 | ; 1.03 = PRIMARY CONTACT DEGREE
|
|---|
| 69 | S DATA(1.03)=NAME("DEGREE")
|
|---|
| 70 | ;
|
|---|
| 71 | ; Initialize alternate contact name variables
|
|---|
| 72 | S NAME=$G(IBSEG(11))
|
|---|
| 73 | D NAME
|
|---|
| 74 | ;
|
|---|
| 75 | ; 1.04 = ALTERNATE CONTACT NAME
|
|---|
| 76 | S DATA(1.04)=NAME("NAME")
|
|---|
| 77 | ;
|
|---|
| 78 | ; 1.05 = ALETRNATE CONTACT PREFIX
|
|---|
| 79 | S DATA(1.05)=NAME("PREFIX")
|
|---|
| 80 | ;
|
|---|
| 81 | ; 1.06 = ALTERNATE CONTACT DEGREE
|
|---|
| 82 | S DATA(1.06)=NAME("DEGREE")
|
|---|
| 83 | Q
|
|---|
| 84 | ;
|
|---|
| 85 | NAME ; Initialize name variables from NAME string
|
|---|
| 86 | S NAME("SURNAME")=$P($P(NAME,$E(HLECH,1),1),$E(HLECH,4),1)
|
|---|
| 87 | S NAME("SURNAME PREFIX")=$P($P(NAME,$E(HLECH,1),1),$E(HLECH,4),2)
|
|---|
| 88 | S NAME("FAMILY")=$S(NAME("SURNAME PREFIX")]"":NAME("SURNAME PREFIX")_" ",1:"")_NAME("SURNAME")
|
|---|
| 89 | S NAME("GIVEN")=$P(NAME,$E(HLECH,1),2)
|
|---|
| 90 | S NAME("MIDDLE")=$P(NAME,$E(HLECH,1),3)
|
|---|
| 91 | S NAME("SUFFIX")=$P(NAME,$E(HLECH,1),4)
|
|---|
| 92 | S NAME("NAME")=""
|
|---|
| 93 | I NAME("FAMILY")]"" S NAME("NAME")=NAME("FAMILY")_","_NAME("GIVEN")_$S(NAME("MIDDLE")]"":" "_$E(NAME("MIDDLE"),1),1:"")_$S(NAME("SUFFIX")]"":" "_NAME("SUFFIX"),1:"")
|
|---|
| 94 | S NAME("PREFIX")=$P(NAME,$E(HLECH,1),5)
|
|---|
| 95 | S NAME("DEGREE")=$P(NAME,$E(HLECH,1),6)
|
|---|
| 96 | Q
|
|---|
