Routine: IBCNRZPL

IBCNRZPL ;DAOU/DMK - Receive HL7 e-Pharmacy ZPL Segment ;23-OCT-2003

 ;;2.0;INTEGRATED BILLING;**251,550**;21-MAR-94;Build 25

 ;;Per VA Directive 6402, this routine should not be modified.

 ; Description

 ; Receive HL7 e-Pharmacy ZPL Segment

 ; 366.03 PLAN File Update

 ; Called by IBCNRHLT

 ; Entry point

1000 ; Control ZPL Segment processing

 D INIT

INIT ; Initialize ZPL Segment variables

 ; 366.03 PLAN File

 N NAME

 ; .01 = ID

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

 ; Error?

 ; V405 = Plan ID Missing

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

 ; .02 = NAME

 S DATA(.02)=$G(IBSEG(5))

 ; Error?

 ; V410 = Plan Name Missing

 I $TR(DATA(.02)," ","")="" S ERROR="V410" Q

 ; .04 = NAME - SHORT

 S DATA(.04)=$G(IBSEG(7))

 ; .05 = TYPE

 S DATA(.05)=$G(IBSEG(8))

 ; .06 = REGION

 S DATA(.06)=$G(IBSEG(9))

 ; .07 = DATE/TIME CREATED

 ; MAD = Add

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

 ; Initialize primary contact name variables

 S NAME=$G(IBSEG(10))

 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(11))

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

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[HIBCNRZPL   2234     printed  Apr 23, 2025@18:31:11                                                                                                                                                                                                    Page 2

IBCNRZPL  ;DAOU/DMK - Receive HL7 e-Pharmacy ZPL Segment ;23-OCT-2003

 +1       ;;2.0;INTEGRATED BILLING;**251,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 ZPL Segment

 +7       ; 366.03 PLAN File Update

 +8       ;

 +9       ; Called by IBCNRHLT

 +10      ;

 +11      ; Entry point

 +12      ;

1000      ; Control ZPL Segment processing

 +1        DO INIT

 +2        QUIT

 +3       ;

INIT      ; Initialize ZPL Segment variables

 +1       ; 366.03 PLAN File

 +2       ;

 +3        NEW NAME

 +4       ;

 +5       ; .01 = ID

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

 +7       ;

 +8       ; Error?

 +9       ; V405 = Plan ID Missing

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

               SET ERROR="V405"

               QUIT

 +11      ;

 +12      ; .02 = NAME

 +13       SET DATA(.02)=$GET(IBSEG(5))

 +14      ;

 +15      ; Error?

 +16      ; V410 = Plan Name Missing

 +17       IF $TRANSLATE(DATA(.02)," ","")=""

               SET ERROR="V410"

               QUIT

 +18      ;

 +19      ; .04 = NAME - SHORT

 +20       SET DATA(.04)=$GET(IBSEG(7))

 +21      ;

 +22      ; .05 = TYPE

 +23       SET DATA(.05)=$GET(IBSEG(8))

 +24      ;

 +25      ; .06 = REGION

 +26       SET DATA(.06)=$GET(IBSEG(9))

 +27      ;

 +28      ; .07 = DATE/TIME CREATED

 +29      ; MAD = Add

 +30       IF IBCNACT="MAD"

               IF IEN=-1

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

 +31      ;

 +32      ; Initialize primary contact name variables

 +33       SET NAME=$GET(IBSEG(10))

 +34       DO NAME

 +35      ;

 +36      ; 1.01 = PRIMARY CONTACT NAME

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

 +38      ;

 +39      ; 1.02 = PRIMARY CONTACT PREFIX

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

 +41      ;

 +42      ; 1.03 = PRIMARY CONTACT DEGREE

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

 +44      ;

 +45      ; Initialize alternate contact name variables

 +46       SET NAME=$GET(IBSEG(11))

 +47       DO NAME

 +48      ;

 +49      ; 1.04 = ALTERNATE CONTACT NAME

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

 +51      ;

 +52      ; 1.05 = ALETRNATE CONTACT PREFIX

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

 +54      ;

 +55      ; 1.06 = ALTERNATE CONTACT DEGREE

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

 +57       QUIT

 +58      ;

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

IBCNRZPL.m