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
Q
;
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")
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[HIBCNRZPL 2234 printed Dec 13, 2024@02:16:38 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
