Routine: IBCNRZPP

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

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")

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)

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNRZPP   4034     printed  Mar 13, 2025@21:21:38                                                                                                                                                                                                    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

IBCNRZPP.m