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 ---[H[J[2J[HIBCNRZPB 2026 printed Oct 16, 2024@18:17:17 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
