IBCNRZPT ;DAOU/DMK - Receive HL7 e-Pharmacy ZPT 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 ZPT Segment
; 366.01 NCPDP PROCESSOR File Update
;
; Called by IBCNRHLT
;
; Entry point
;
1000 ; Control ZPT Segment processing
D INIT
Q
;
INIT ; Initialize ZPT Segment variables
; 366.01 NCPDP PROCESSOR File
;
N NAME
;
; .01 = NAME
S DATA(.01)=$G(IBSEG(4))
;
; Error?
; V205 = NCPDP Processor Name Missing
I $TR(DATA(.01)," ","")="" S ERROR="V205" Q
;
; .02 = BLOCKED?
S DATA(.02)=$S($G(IBSEG(5))="N":0,1:1)
;
; Error?
; V210 = NCPDP Processor Blocked? Missing
I $TR(DATA(.02)," ","")="" S ERROR="V210" Q
;
; .03 = DATE/TIME CREATED
; MAD = Add
I IBCNACT="MAD",IEN=-1 S DATA(.03)=DATE("NOW")
;
; Initialize primary contact name variables
S NAME=$G(IBSEG(6))
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(7))
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[HIBCNRZPT 2147 printed Oct 16, 2024@18:17:20 Page 2
IBCNRZPT ;DAOU/DMK - Receive HL7 e-Pharmacy ZPT 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 ZPT Segment
+7 ; 366.01 NCPDP PROCESSOR File Update
+8 ;
+9 ; Called by IBCNRHLT
+10 ;
+11 ; Entry point
+12 ;
1000 ; Control ZPT Segment processing
+1 DO INIT
+2 QUIT
+3 ;
INIT ; Initialize ZPT Segment variables
+1 ; 366.01 NCPDP PROCESSOR File
+2 ;
+3 NEW NAME
+4 ;
+5 ; .01 = NAME
+6 SET DATA(.01)=$GET(IBSEG(4))
+7 ;
+8 ; Error?
+9 ; V205 = NCPDP Processor Name Missing
+10 IF $TRANSLATE(DATA(.01)," ","")=""
SET ERROR="V205"
QUIT
+11 ;
+12 ; .02 = BLOCKED?
+13 SET DATA(.02)=$SELECT($GET(IBSEG(5))="N":0,1:1)
+14 ;
+15 ; Error?
+16 ; V210 = NCPDP Processor Blocked? Missing
+17 IF $TRANSLATE(DATA(.02)," ","")=""
SET ERROR="V210"
QUIT
+18 ;
+19 ; .03 = DATE/TIME CREATED
+20 ; MAD = Add
+21 IF IBCNACT="MAD"
IF IEN=-1
SET DATA(.03)=DATE("NOW")
+22 ;
+23 ; Initialize primary contact name variables
+24 SET NAME=$GET(IBSEG(6))
+25 DO NAME
+26 ;
+27 ; 1.01 = PRIMARY CONTACT NAME
+28 SET DATA(1.01)=NAME("NAME")
+29 ;
+30 ; 1.02 = PRIMARY CONTACT PREFIX
+31 SET DATA(1.02)=NAME("PREFIX")
+32 ;
+33 ; 1.03 = PRIMARY CONTACT DEGREE
+34 SET DATA(1.03)=NAME("DEGREE")
+35 ;
+36 ; Initialize alternate contact name variables
+37 SET NAME=$GET(IBSEG(7))
+38 DO NAME
+39 ;
+40 ; 1.04 = ALTERNATE CONTACT NAME
+41 SET DATA(1.04)=NAME("NAME")
+42 ;
+43 ; 1.05 = ALETRNATE CONTACT PREFIX
+44 SET DATA(1.05)=NAME("PREFIX")
+45 ;
+46 ; 1.06 = ALTERNATE CONTACT DEGREE
+47 SET DATA(1.06)=NAME("DEGREE")
+48 QUIT
+49 ;
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
