source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNRZPT.m@ 841

Last change on this file since 841 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 2.0 KB
RevLine 
[613]1IBCNRZPT ;DAOU/DMK - Receive HL7 e-Pharmacy ZPT Segment ;23-OCT-2003
2 ;;2.0;INTEGRATED BILLING;**251**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ; Description
6 ;
7 ; Receive HL7 e-Pharmacy ZPT Segment
8 ; 366.01 NCPDP PROCESSOR File Update
9 ;
10 ; Called by IBCNRHLT
11 ;
12 ; Entry point
13 ;
141000 ; Control ZPT Segment processing
15 D INIT
16 Q
17 ;
18INIT ; Initialize ZPT Segment variables
19 ; 366.01 NCPDP PROCESSOR File
20 ;
21 N NAME
22 ;
23 ; .01 = NAME
24 S DATA(.01)=$G(IBSEG(4))
25 ;
26 ; Error?
27 ; V205 = NCPDP Processor Name Missing
28 I $TR(DATA(.01)," ","")="" S ERROR="V205" Q
29 ;
30 ; .02 = BLOCKED?
31 S DATA(.02)=$S($G(IBSEG(5))="N":0,1:1)
32 ;
33 ; Error?
34 ; V210 = NCPDP Processor Blocked? Missing
35 I $TR(DATA(.02)," ","")="" S ERROR="V210" Q
36 ;
37 ; .03 = DATE/TIME CREATED
38 ; MAD = Add
39 I IBCNACT="MAD",IEN=-1 S DATA(.03)=DATE("NOW")
40 ;
41 ; Initialize primary contact name variables
42 S NAME=$G(IBSEG(6))
43 D NAME
44 ;
45 ; 1.01 = PRIMARY CONTACT NAME
46 S DATA(1.01)=NAME("NAME")
47 ;
48 ; 1.02 = PRIMARY CONTACT PREFIX
49 S DATA(1.02)=NAME("PREFIX")
50 ;
51 ; 1.03 = PRIMARY CONTACT DEGREE
52 S DATA(1.03)=NAME("DEGREE")
53 ;
54 ; Initialize alternate contact name variables
55 S NAME=$G(IBSEG(7))
56 D NAME
57 ;
58 ; 1.04 = ALTERNATE CONTACT NAME
59 S DATA(1.04)=NAME("NAME")
60 ;
61 ; 1.05 = ALETRNATE CONTACT PREFIX
62 S DATA(1.05)=NAME("PREFIX")
63 ;
64 ; 1.06 = ALTERNATE CONTACT DEGREE
65 S DATA(1.06)=NAME("DEGREE")
66 Q
67 ;
68NAME ; Initialize name variables from NAME string
69 S NAME("SURNAME")=$P($P(NAME,$E(HLECH,1),1),$E(HLECH,4),1)
70 S NAME("SURNAME PREFIX")=$P($P(NAME,$E(HLECH,1),1),$E(HLECH,4),2)
71 S NAME("FAMILY")=$S(NAME("SURNAME PREFIX")]"":NAME("SURNAME PREFIX")_" ",1:"")_NAME("SURNAME")
72 S NAME("GIVEN")=$P(NAME,$E(HLECH,1),2)
73 S NAME("MIDDLE")=$P(NAME,$E(HLECH,1),3)
74 S NAME("SUFFIX")=$P(NAME,$E(HLECH,1),4)
75 S NAME("NAME")=""
76 I NAME("FAMILY")]"" S NAME("NAME")=NAME("FAMILY")_","_NAME("GIVEN")_$S(NAME("MIDDLE")]"":" "_$E(NAME("MIDDLE"),1),1:"")_$S(NAME("SUFFIX")]"":" "_NAME("SUFFIX"),1:"")
77 S NAME("PREFIX")=$P(NAME,$E(HLECH,1),5)
78 S NAME("DEGREE")=$P(NAME,$E(HLECH,1),6)
79 Q
Note: See TracBrowser for help on using the repository browser.