IBCNRZPP ;DAOU/PHH - Receive HL7 e-Pharmacy ZPP Segment ;4-NOV-2015
;;2.0;INTEGRATED BILLING;**550**;21-MAR-94;Build 25
;;Per VA Directive 6402, this routine should not be modified.
;
; Description
;
; Receive HL7 e-Pharmacy ZPP Segment
; 366.03 PLAN File Update (Pharmacy)
;
; Called by IBCNRHLT
;
; Entry point
;
1000 ; Control ZPP Segment processing
D INIT
I $D(ERROR) Q
Q
;
INIT ; Initialize ZPP Segment variables
; 366.03 PLAN File
;
N NAME
;
; Error?
; V505 = Plan ID Missing
I $TR($G(IBSEG(3))," ","") S ERROR="V505" Q
;
; 10.01 = PHARMACY BENEFITS MANAGER NAME (pointer - 366.02)
S DATA(10.01)=$G(IBSEG(4))
I DATA(10.01)]"" S DATA(10.01)=$$LOOKUP1^IBCNRFM1(366.02,DATA(10.01))
;
; Error?
; V510 = Pharmacy Benefits Manager (PBM) Undefined
I DATA(10.01)=-1 S ERROR="V510" Q
;
; 10.02 = BANKING IDENTIFICATION NUMBER
S DATA(10.02)=$G(IBSEG(5))
;
; Error?
; V515 = Plan BIN Missing
I $TR(DATA(10.02)," ","")="" S ERROR="V515" Q
;
; 10.03 = PROCESSOR CONTROL NUMBER (PCN)
S DATA(10.03)=$G(IBSEG(6))
;
; 10.04 = NCPDP PROCESSOR NAME (pointer - 366.01)
S DATA(10.04)=$G(IBSEG(7))
I DATA(10.04)]"" S DATA(10.04)=$$LOOKUP1^IBCNRFM1(366.01,DATA(10.04))
;
; Error?
; V520 = NCPDP Processor Name Undefined
I DATA(10.04)=-1 S ERROR="V520" Q
;
; 10.05 = ENABLED?
S DATA(10.05)=$S($G(IBSEG(8))="Y":1,1:0)
;
; Error?
; V525 = Plan Enabled? Missing
I $TR(DATA(10.05)," ","")="" S ERROR="V525" Q
;
; 10.06 = SOFTWARE VENDOR ID
S DATA(10.06)=$G(IBSEG(9))
;
; 10.07 = BILLING PAYER SHEET NAME (pointer - 9002313.92)
S DATA(10.07)=$G(IBSEG(10))
I DATA(10.07)]"" S DATA(10.07)=$$LOOKUP1^IBCNRFM1(9002313.92,DATA(10.07))
;
; Error?
; V530 = Billing Payer Sheet Name Undefined
I DATA(10.07)=-1 S ERROR="V530" Q
;
; 10.08 = REVERSAL PAYER SHEET NAME (pointer - 9002313.92)
S DATA(10.08)=$G(IBSEG(11))
I DATA(10.08)]"" S DATA(10.08)=$$LOOKUP1^IBCNRFM1(9002313.92,DATA(10.08))
;
; Error?
; V535 = Reversal Payer Sheet Name Undefined
I DATA(10.08)=-1 S ERROR="V535" Q
;
; 10.09 = REBILL PAYER SHEET NAME (pointer - 9002313.92)
S DATA(10.09)=$G(IBSEG(12))
I DATA(10.09)]"" S DATA(10.09)=$$LOOKUP1^IBCNRFM1(9002313.92,DATA(10.09))
;
; Error?
; V540 = Rebill Payer Sheet Name Undefined
I DATA(10.09)=-1 S ERROR="V540" Q
;
; 10.1 = MAXIMUM NCPDP TRANSACTIONS
S DATA(10.1)=$G(IBSEG(13))
;
; 10.15 = ELIGIBILITY VERIFICATION PAYER SHEET NAME (pointer - 9002313.92)
S DATA(10.15)=$G(IBSEG(16))
I DATA(10.15)]"" S DATA(10.15)=$$LOOKUP1^IBCNRFM1(9002313.92,DATA(10.15))
;
; Error?
; V545 = Eligibility Verification Payer Sheet Name Undefined
I DATA(10.15)=-1 S ERROR="V545" Q
;
; Initialize RX primary contact name variables
S NAME=$G(IBSEG(14))
D NAME
;
; 11.01 = RX PRIMARY CONTACT NAME
S DATA(11.01)=NAME("NAME")
;
; 11.02 = RX PRIMARY CONTACT PREFIX
S DATA(11.02)=NAME("PREFIX")
;
; 11.03 = RX PRIMARY CONTACT DEGREE
S DATA(11.03)=NAME("DEGREE")
;
; Initialize RX alternate contact name variables
S NAME=$G(IBSEG(15))
D NAME
;
; 11.04 = RX ALTERNATE CONTACT NAME
S DATA(11.04)=NAME("NAME")
;
; 11.05 = RX ALETRNATE CONTACT PREFIX
S DATA(11.05)=NAME("PREFIX")
;
; 11.06 = RX ALTERNATE CONTACT DEGREE
S DATA(11.06)=NAME("DEGREE")
Q
;
NAME ; Initialize name variables from NAME string
S NAME("SURNAME")=$P($P(NAME,$E(HLECH,1),1),$E(HLECH,4),1)
S NAME("SURNAME PREFIX")=$P($P(NAME,$E(HLECH,1),1),$E(HLECH,4),2)
S NAME("FAMILY")=$S(NAME("SURNAME PREFIX")]"":NAME("SURNAME PREFIX")_" ",1:"")_NAME("SURNAME")
S NAME("GIVEN")=$P(NAME,$E(HLECH,1),2)
S NAME("MIDDLE")=$P(NAME,$E(HLECH,1),3)
S NAME("SUFFIX")=$P(NAME,$E(HLECH,1),4)
S NAME("NAME")=""
I NAME("FAMILY")]"" S NAME("NAME")=NAME("FAMILY")_","_NAME("GIVEN")_$S(NAME("MIDDLE")]"":" "_$E(NAME("MIDDLE"),1),1:"")_$S(NAME("SUFFIX")]"":" "_NAME("SUFFIX"),1:"")
S NAME("PREFIX")=$P(NAME,$E(HLECH,1),5)
S NAME("DEGREE")=$P(NAME,$E(HLECH,1),6)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNRZPP 4034 printed Sep 02, 2024@19:01:52 Page 2
IBCNRZPP ;DAOU/PHH - Receive HL7 e-Pharmacy ZPP Segment ;4-NOV-2015
+1 ;;2.0;INTEGRATED BILLING;**550**;21-MAR-94;Build 25
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; Description
+5 ;
+6 ; Receive HL7 e-Pharmacy ZPP Segment
+7 ; 366.03 PLAN File Update (Pharmacy)
+8 ;
+9 ; Called by IBCNRHLT
+10 ;
+11 ; Entry point
+12 ;
1000 ; Control ZPP Segment processing
+1 DO INIT
+2 IF $DATA(ERROR)
QUIT
+3 QUIT
+4 ;
INIT ; Initialize ZPP Segment variables
+1 ; 366.03 PLAN File
+2 ;
+3 NEW NAME
+4 ;
+5 ; Error?
+6 ; V505 = Plan ID Missing
+7 IF $TRANSLATE($GET(IBSEG(3))," ","")
SET ERROR="V505"
QUIT
+8 ;
+9 ; 10.01 = PHARMACY BENEFITS MANAGER NAME (pointer - 366.02)
+10 SET DATA(10.01)=$GET(IBSEG(4))
+11 IF DATA(10.01)]""
SET DATA(10.01)=$$LOOKUP1^IBCNRFM1(366.02,DATA(10.01))
+12 ;
+13 ; Error?
+14 ; V510 = Pharmacy Benefits Manager (PBM) Undefined
+15 IF DATA(10.01)=-1
SET ERROR="V510"
QUIT
+16 ;
+17 ; 10.02 = BANKING IDENTIFICATION NUMBER
+18 SET DATA(10.02)=$GET(IBSEG(5))
+19 ;
+20 ; Error?
+21 ; V515 = Plan BIN Missing
+22 IF $TRANSLATE(DATA(10.02)," ","")=""
SET ERROR="V515"
QUIT
+23 ;
+24 ; 10.03 = PROCESSOR CONTROL NUMBER (PCN)
+25 SET DATA(10.03)=$GET(IBSEG(6))
+26 ;
+27 ; 10.04 = NCPDP PROCESSOR NAME (pointer - 366.01)
+28 SET DATA(10.04)=$GET(IBSEG(7))
+29 IF DATA(10.04)]""
SET DATA(10.04)=$$LOOKUP1^IBCNRFM1(366.01,DATA(10.04))
+30 ;
+31 ; Error?
+32 ; V520 = NCPDP Processor Name Undefined
+33 IF DATA(10.04)=-1
SET ERROR="V520"
QUIT
+34 ;
+35 ; 10.05 = ENABLED?
+36 SET DATA(10.05)=$SELECT($GET(IBSEG(8))="Y":1,1:0)
+37 ;
+38 ; Error?
+39 ; V525 = Plan Enabled? Missing
+40 IF $TRANSLATE(DATA(10.05)," ","")=""
SET ERROR="V525"
QUIT
+41 ;
+42 ; 10.06 = SOFTWARE VENDOR ID
+43 SET DATA(10.06)=$GET(IBSEG(9))
+44 ;
+45 ; 10.07 = BILLING PAYER SHEET NAME (pointer - 9002313.92)
+46 SET DATA(10.07)=$GET(IBSEG(10))
+47 IF DATA(10.07)]""
SET DATA(10.07)=$$LOOKUP1^IBCNRFM1(9002313.92,DATA(10.07))
+48 ;
+49 ; Error?
+50 ; V530 = Billing Payer Sheet Name Undefined
+51 IF DATA(10.07)=-1
SET ERROR="V530"
QUIT
+52 ;
+53 ; 10.08 = REVERSAL PAYER SHEET NAME (pointer - 9002313.92)
+54 SET DATA(10.08)=$GET(IBSEG(11))
+55 IF DATA(10.08)]""
SET DATA(10.08)=$$LOOKUP1^IBCNRFM1(9002313.92,DATA(10.08))
+56 ;
+57 ; Error?
+58 ; V535 = Reversal Payer Sheet Name Undefined
+59 IF DATA(10.08)=-1
SET ERROR="V535"
QUIT
+60 ;
+61 ; 10.09 = REBILL PAYER SHEET NAME (pointer - 9002313.92)
+62 SET DATA(10.09)=$GET(IBSEG(12))
+63 IF DATA(10.09)]""
SET DATA(10.09)=$$LOOKUP1^IBCNRFM1(9002313.92,DATA(10.09))
+64 ;
+65 ; Error?
+66 ; V540 = Rebill Payer Sheet Name Undefined
+67 IF DATA(10.09)=-1
SET ERROR="V540"
QUIT
+68 ;
+69 ; 10.1 = MAXIMUM NCPDP TRANSACTIONS
+70 SET DATA(10.1)=$GET(IBSEG(13))
+71 ;
+72 ; 10.15 = ELIGIBILITY VERIFICATION PAYER SHEET NAME (pointer - 9002313.92)
+73 SET DATA(10.15)=$GET(IBSEG(16))
+74 IF DATA(10.15)]""
SET DATA(10.15)=$$LOOKUP1^IBCNRFM1(9002313.92,DATA(10.15))
+75 ;
+76 ; Error?
+77 ; V545 = Eligibility Verification Payer Sheet Name Undefined
+78 IF DATA(10.15)=-1
SET ERROR="V545"
QUIT
+79 ;
+80 ; Initialize RX primary contact name variables
+81 SET NAME=$GET(IBSEG(14))
+82 DO NAME
+83 ;
+84 ; 11.01 = RX PRIMARY CONTACT NAME
+85 SET DATA(11.01)=NAME("NAME")
+86 ;
+87 ; 11.02 = RX PRIMARY CONTACT PREFIX
+88 SET DATA(11.02)=NAME("PREFIX")
+89 ;
+90 ; 11.03 = RX PRIMARY CONTACT DEGREE
+91 SET DATA(11.03)=NAME("DEGREE")
+92 ;
+93 ; Initialize RX alternate contact name variables
+94 SET NAME=$GET(IBSEG(15))
+95 DO NAME
+96 ;
+97 ; 11.04 = RX ALTERNATE CONTACT NAME
+98 SET DATA(11.04)=NAME("NAME")
+99 ;
+100 ; 11.05 = RX ALETRNATE CONTACT PREFIX
+101 SET DATA(11.05)=NAME("PREFIX")
+102 ;
+103 ; 11.06 = RX ALTERNATE CONTACT DEGREE
+104 SET DATA(11.06)=NAME("DEGREE")
+105 QUIT
+106 ;
NAME ; Initialize name variables from NAME string
+1 SET NAME("SURNAME")=$PIECE($PIECE(NAME,$EXTRACT(HLECH,1),1),$EXTRACT(HLECH,4),1)
+2 SET NAME("SURNAME PREFIX")=$PIECE($PIECE(NAME,$EXTRACT(HLECH,1),1),$EXTRACT(HLECH,4),2)
+3 SET NAME("FAMILY")=$SELECT(NAME("SURNAME PREFIX")]"":NAME("SURNAME PREFIX")_" ",1:"")_NAME("SURNAME")
+4 SET NAME("GIVEN")=$PIECE(NAME,$EXTRACT(HLECH,1),2)
+5 SET NAME("MIDDLE")=$PIECE(NAME,$EXTRACT(HLECH,1),3)
+6 SET NAME("SUFFIX")=$PIECE(NAME,$EXTRACT(HLECH,1),4)
+7 SET NAME("NAME")=""
+8 IF NAME("FAMILY")]""
SET NAME("NAME")=NAME("FAMILY")_","_NAME("GIVEN")_$SELECT(NAME("MIDDLE")]"":" "_$EXTRACT(NAME("MIDDLE"),1),1:"")_$SELECT(NAME("SUFFIX")]"":" "_NAME("SUFFIX"),1:"")
+9 SET NAME("PREFIX")=$PIECE(NAME,$EXTRACT(HLECH,1),5)
+10 SET NAME("DEGREE")=$PIECE(NAME,$EXTRACT(HLECH,1),6)
+11 QUIT