IBCNRZPB.m

IBCNRZPB ;DAOU/DMK - Receive HL7 e-Pharmacy ZPB Segment ;23-OCT-2003

 ;;2.0;INTEGRATED BILLING;**251**;21-MAR-94

 ;;Per VHA Directive 10-93-142, this routine should not be modified.

 ;

 ; Description

 ;

 ; Receive HL7 e-Pharmacy ZPB Segment

 ; 366.02 PHARMACY BENEFITS MANAGER (PBM) File Update

 ;

 ; Called by IBCNRHLT

 ;

 ; Entry point

 ;

1000 ; Control ZPB Segment processing

 D INIT

 Q

 ;

INIT ; Initialize ZPB Segment variables

 ; 366.02 PHARMACY BENEFITS MANAGER (PBM) File

 ;

 N NAME

 ;

 ; .01 = NAME

 S DATA(.01)=$G(IBSEG(4))

 ;

 ; Error?

 ; V305 = Pharmacy Benefits Manager (PBM) Name Missing

 I $TR(DATA(.01)," ","")="" S ERROR="V305" Q

 ;

 ; .02 = DATE/TIME CREATED

 ; MAD = Add

 I IBCNACT="MAD",IEN=-1 S DATA(.02)=DATE("NOW")

 ;

 ; Initialize primary contact name variables

 S NAME=$G(IBSEG(5))

 D NAME

 ;

 ; 1.01 = PRIMARY CONTACT NAME

 S DATA(1.01)=NAME("NAME")

 ;

 ; 1.02 = PRIMARY CONTACT PREFIX

 S DATA(1.02)=NAME("PREFIX")

 ;

 ; 1.03 = PRIMARY CONTACT DEGREE

 S DATA(1.03)=NAME("DEGREE")

 ;

 ; Initialize alternate contact name variables

 S NAME=$G(IBSEG(6))

 D NAME

 ;

 ; 1.04 = ALTERNATE CONTACT NAME

 S DATA(1.04)=NAME("NAME")

 ;

 ; 1.05 = ALETRNATE CONTACT PREFIX

 S DATA(1.05)=NAME("PREFIX")

 ;

 ; 1.06 = ALTERNATE CONTACT DEGREE

 S DATA(1.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 ---IBCNRZPB   2026     printed  Apr 23, 2025@18:31:10                                                                                                                                                                                                    Page 2

IBCNRZPB  ;DAOU/DMK - Receive HL7 e-Pharmacy ZPB Segment ;23-OCT-2003

 +1       ;;2.0;INTEGRATED BILLING;**251**;21-MAR-94

 +2       ;;Per VHA Directive 10-93-142, this routine should not be modified.

 +3       ;

 +4       ; Description

 +5       ;

 +6       ; Receive HL7 e-Pharmacy ZPB Segment

 +7       ; 366.02 PHARMACY BENEFITS MANAGER (PBM) File Update

 +8       ;

 +9       ; Called by IBCNRHLT

 +10      ;

 +11      ; Entry point

 +12      ;

1000      ; Control ZPB Segment processing

 +1        DO INIT

 +2        QUIT 

 +3       ;

INIT      ; Initialize ZPB Segment variables

 +1       ; 366.02 PHARMACY BENEFITS MANAGER (PBM) File

 +2       ;

 +3        NEW NAME

 +4       ;

 +5       ; .01 = NAME

 +6        SET DATA(.01)=$GET(IBSEG(4))

 +7       ;

 +8       ; Error?

 +9       ; V305 = Pharmacy Benefits Manager (PBM) Name Missing

 +10       IF $TRANSLATE(DATA(.01)," ","")=""

               SET ERROR="V305"

               QUIT 

 +11      ;

 +12      ; .02 = DATE/TIME CREATED

 +13      ; MAD = Add

 +14       IF IBCNACT="MAD"

               IF IEN=-1

                   SET DATA(.02)=DATE("NOW")

 +15      ;

 +16      ; Initialize primary contact name variables

 +17       SET NAME=$GET(IBSEG(5))

 +18       DO NAME

 +19      ;

 +20      ; 1.01 = PRIMARY CONTACT NAME

 +21       SET DATA(1.01)=NAME("NAME")

 +22      ;

 +23      ; 1.02 = PRIMARY CONTACT PREFIX

 +24       SET DATA(1.02)=NAME("PREFIX")

 +25      ;

 +26      ; 1.03 = PRIMARY CONTACT DEGREE

 +27       SET DATA(1.03)=NAME("DEGREE")

 +28      ;

 +29      ; Initialize alternate contact name variables

 +30       SET NAME=$GET(IBSEG(6))

 +31       DO NAME

 +32      ;

 +33      ; 1.04 = ALTERNATE CONTACT NAME

 +34       SET DATA(1.04)=NAME("NAME")

 +35      ;

 +36      ; 1.05 = ALETRNATE CONTACT PREFIX

 +37       SET DATA(1.05)=NAME("PREFIX")

 +38      ;

 +39      ; 1.06 = ALTERNATE CONTACT DEGREE

 +40       SET DATA(1.06)=NAME("DEGREE")

 +41       QUIT 

 +42      ;

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