source: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCMCHLB1.m@ 1375

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

revised back to 6/30/08 version

File size: 4.4 KB
Line 
1SCMCHLB1 ;BP/DJB - PCMM HL7 Bld Segment Array Cont. ; 8/17/99 9:29am
2 ;;5.3;Scheduling;**177,515**;May 01, 1999;Build 14
3 ;
4SEGMENTS(DFN,SUB) ;Build EVN & PID segments
5 ;Input:
6 ; DFN - Patient IEN
7 ; SUB - Value for 1st Subscript
8 ;Output:
9 ; XMITARRY() - Array of EVN & PID segments
10 ;
11 NEW LINETAG,SEGMENTS,SEGNAME,SEGORD
12 NEW EVNTDATE,EVNTHL7,VAFARRY,VAFEVN,VAFPID,VAFSTR
13 ;
14 ;Initialize variables
15 Q:'$G(DFN) ;Required for PID segment
16 Q:'$G(SUB)
17 S EVNTDATE=DT
18 S EVNTHL7="A08"
19 ;
20 ;Get array of segments to be built
21 D SEGMENTS^SCMCHLS(EVNTHL7,"SEGMENTS")
22 ;
23 ;Loop thru segments array. Ignore ZPC segment - already built.
24 S SEGORD=0
25 F S SEGORD=+$O(SEGMENTS(SEGORD)) Q:'SEGORD D ;
26 . S SEGNAME=""
27 . F S SEGNAME=$O(SEGMENTS(SEGORD,SEGNAME)) Q:SEGNAME="" D ;
28 .. Q:SEGNAME="ZPC" ;.................ZPC already built
29 .. S VAFSTR=SEGMENTS(SEGORD,SEGNAME) ;String of segment fields
30 .. S LINETAG="BLD"_SEGNAME
31 .. D @LINETAG^SCMCHLS ;...............Build segment
32 .. S LINETAG="CPY"_SEGNAME
33 .. D @LINETAG^SCMCHLS ;...............Copy segment into array
34 Q
35 ;
36ZPC(ARRAY,DELETE) ;Loop thru array and build array of ZPC segments.
37 ;
38 ;Input:
39 ; ARRAY - Array to be processed. This array was built in ^SCMCHLB
40 ; with calls to $$PRTPC^SCAPMC() and $$PRPTTPC^SCAPMC().
41 ; Examples:
42 ; ARRAY(2290,"PCP","2290-406-34-PCP")= Data
43 ; ARRAY(345,"PROV-P","2290-405-0-AP")= Data
44 ; DELETE - 1=Process a delete type ZPC segment (all fields null)
45 ;Output:
46 ; Array of ZPC segments
47 ;
48 NEW DATA,DATE,ID,ID1,LINETAG,NUM,TYPE,VAFZPC
49 ;
50 S NUM=0
51 F S NUM=$O(ARRAY(NUM)) Q:'NUM D ;
52 . S TYPE=""
53 . F S TYPE=$O(ARRAY(NUM,TYPE)) Q:TYPE="" D ;
54 .. S ID=""
55 .. F S ID=$O(ARRAY(NUM,TYPE,ID)) Q:ID="" D ;
56 ... S DATA=$G(ARRAY(NUM,TYPE,ID))
57 ... I $G(DELETE) S DATA="^^^" ;A Delete type ZPC segment
58 ... E D ;....................A ZPC segment with data
59 .... ;Get dates
60 .... S DATE(9)=$P(DATA,U,9)
61 .... S DATE(10)=$P(DATA,U,10)
62 .... S DATE(14)=$P(DATA,U,14) ;Preceptor start date
63 .... S DATE(15)=$P(DATA,U,15) ;Preceptor end date
64 .... I DATE(14),DATE(14)>DATE(9) S DATE(9)=DATE(14)
65 .... I DATE(15) D ;
66 ..... I 'DATE(10) S DATE(10)=DATE(15) Q
67 ..... I DATE(15)<DATE(10) S DATE(10)=DATE(15)
68 .... ;
69 .... ;Provider^AssignDate^UnassignDate^ProviderType
70 .... S DATA=$P(DATA,U,1)_"^"_DATE(9)_"^"_DATE(10)
71 ....; PATCH 515 DLL ADD NEW ROLES (TPA,CCM,PM)
72 ....; OLD CODE = S DATA=DATA_"^"_$S(ID["AP":"AP",1:"PCP")
73 ....S ROLE=$P(ID,"-",4) I $G(ROLE)="" S ROLE="PCP"
74 ....S DATA=DATA_"^"_ROLE
75 ... ;
76 ... S LINETAG="BLDZPC"
77 ... D @LINETAG^SCMCHLS ;..Build segment
78 ... S LINETAG="CPYZPC"
79 ... D @LINETAG^SCMCHLS ;..Copy segment into array
80 Q
81 ;
82DFN(ND) ;Find DFN from zero node of Patient Team Position Assign (404.43).
83 ;Input:
84 ; ND - Zero node of 404.43
85 ;Output:
86 ; DFN - Patient IEN
87 ; "" - No valid DFN found
88 ;
89 S DFN=$P(ND,U,1)
90 I DFN S DFN=$P($G(^SCPT(404.42,DFN,0)),U,1)
91 Q DFN
92 ;
93ADJID(ARRAY,SCIEN) ;Adjust ID to include Pt Tm Pos Assign pointer
94 ;Example: From this: 424-34-AP
95 ; To this: 2290-424-34-AP
96 ;Input:
97 ; ARRAY - Array to be processed
98 ; SCIEN - 404.43 IEN to be added to ID
99 ;
100 NEW ADJID,ID,NUM,TMP,TYPE
101 ;
102 ;Build TMP() array using adjusted ID
103 S NUM=0
104 F S NUM=$O(ARRAY(NUM)) Q:'NUM D ;
105 . S TYPE=""
106 . F S TYPE=$O(ARRAY(NUM,TYPE)) Q:TYPE="" D ;
107 .. S ID=""
108 .. F S ID=$O(ARRAY(NUM,TYPE,ID)) Q:ID="" D ;
109 ... S ADJID=SCIEN_"-"_ID ;..Add 404.43 IEN
110 ... S TMP(NUM,TYPE,ADJID)=ARRAY(NUM,TYPE,ID)
111 ;
112 ;Replace ARRAY() with adjusted TMP() array.
113 Q:'$D(TMP)
114 KILL ARRAY
115 M ARRAY=TMP ;Copy TMP() into ARRAY()
116 Q
117 ;
118CHECK(VARPTR) ;Validate event variable pointer.
119 ;Input:
120 ; VARPTR - EVENT POINTER field of PCMM HL7 EVENT (#404.48)
121 ;Output:
122 ; SCIEN - IEN portion of variable pointer
123 ; SCGLB - Global portion of variable pointer
124 ;Return:
125 ; 0: Invalid variable pointer format
126 ; 1: Valid pointer
127 ; 2: No data. Entry has been deleted. Send a delete to NPCD.
128 ;
129 NEW CHK,GLB
130 ;
131 S SCIEN=$P(VARPTR,";") ;....IEN portion of variable pointer
132 S SCGLB=$P(VARPTR,";",2) ;..Global portion of variable pointer
133 ;
134 ;Return zero if variable pointer is invalid.
135 I 'SCIEN Q 0
136 S CHK=0 D I CHK Q 0
137 . Q:SCGLB="SCPT(404.43,"
138 . Q:SCGLB="SCTM(404.52,"
139 . Q:SCGLB="SCTM(404.53,"
140 . S CHK=1
141 ;
142 ;Is there data for this IEN?
143 S GLB="^"_SCGLB_SCIEN_",0)"
144 I '$D(@GLB) Q 2 ;..Entry has been deleted
145 Q 1
Note: See TracBrowser for help on using the repository browser.