source: WorldVistAEHR/trunk/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJORDF.m@ 619

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

initial load of WorldVistAEHR
File size: 7.1 KB
RevLine 
[613]1PSSJORDF ;BIR/MV-RETURN MED ROUTES(MR) AND INSTRUCTIONS(INS) ;06/26/98
2 ;;1.0;PHARMACY DATA MANAGEMENT;**5,13,34,38,69,113,94**;9/30/97;Build 26
3 ;;
4 ; Reference to ^PS(50.7 is supported by DBIA 2180.
5 ; Reference to ^PS(51.2 is supported by DBIA 2178.
6 ; Reference to ^PS(50.606 is supported by DBIA 2174.
7 ;
8 ;* PSJORD is the Orderable Item IEN pass to Pharmacy by OE/RR.
9 ;* 1. If the dosage form is valid, this routine will return all med
10 ;* routes and instructions associated with that dose form.
11 ;* 2. If the dose form is null, this routine will return all med routes
12 ;* that exist in the medication routes file.
13 ;* 3. ^TMP format:
14 ;* ^TMP("PSJMR",$J,#)=MED ROUTE^MED ROUTE ABREVATION^IEN^OUTPATIENT
15 ;* EXPANSION^IV FLAG^DEFAULT FLAG
16 ;* ^TMP("PSJNOUN",$J,D0)=NOUN^VERB^PREPOSITION
17 ;* ^TMP("PSJSCH",$J)=DEFAULT SCHEDULE NAME
18 ;
19START(PSJORD,PSJOPAC) ;
20 NEW MR,MRNODE,INS,PSJDFNO,X,MCT,Z,PSJOISC
21 I '+PSJORD D MEDROUTE Q
22 S PSJDFNO=+$P($G(^PS(50.7,+PSJORD,0)),U,2)
23 ;S ^TMP("PSJSCH",$J)=$P($G(^PS(50.7,+PSJORD,0)),"^",8) ;default schedule
24 S PSJOISC=$P($G(^PS(50.7,+PSJORD,0)),"^",8)
25 I $G(PSJOPAC)="O"!($G(PSJOPAC)="X") D:$G(PSJOISC)'="" EN^PSSOUTSC(.PSJOISC) S:$G(PSJOISC)'="" ^TMP("PSJSCH",$J)=$G(PSJOISC) G SCPASS
26 I $G(PSJOISC)'="" D EN^PSSGSGUI(.PSJOISC,"I") S:$G(PSJOISC)'="" ^TMP("PSJSCH",$J)=$G(PSJOISC)
27SCPASS ;
28 I $G(^PS(50.606,PSJDFNO,0))="" D NOD Q:$D(^TMP("PSJMR",$J,1)) D MEDROUTE Q
29 K ^TMP("PSJMR",$J),^TMP("PSJNOUN",$J)
30 D DF
31 Q
32 ;
33DF ;* Loop thru DF node to find all available med routes, nouns, and instructions.
34 N VERB,MR,INS,X
35 S (MR,INS,X,MCT)=0
36 S VERB=$P($G(^PS(50.606,PSJDFNO,"MISC")),U)
37 S MR=+$P($G(^PS(50.7,+PSJORD,0)),"^",6) I MR,$D(^PS(51.2,MR,0)),$P($G(^(0)),"^",4)=1 S ^TMP("PSJMR",$J,1)=$P(^PS(51.2,MR,0),"^")_U_$P(^(0),"^",3)_U_MR_U_$P(^(0),"^",2)_U_$S($P(^(0),"^",6):1,1:0)_"^D",MCT=MCT+1
38 S MR=0 F S MR=$O(^PS(50.606,PSJDFNO,"MR",MR)) Q:'MR D
39 . S X=+$G(^PS(50.606,PSJDFNO,"MR",MR,0)) Q:'X!($P($G(^TMP("PSJMR",$J,1)),"^",3)=X)
40 . S MRNODE=$G(^PS(51.2,X,0))
41 . I $P($G(MRNODE),"^",4)'=1 Q
42 . S MCT=MCT+1,^TMP("PSJMR",$J,MCT)=$P(MRNODE,U)_U_$P(MRNODE,U,3)_U_X_U_$P(MRNODE,U,2)_U_$S($P(MRNODE,U,6):1,1:0)
43 S X=0
44 ;F S INS=$O(^PS(50.606,PSJDFNO,"INS",INS)) Q:'INS S X=X+1,^TMP("PSJINS",$J,X)=VERB_U_$G(^PS(50.606,PSJDFNO,"INS",INS,0))
45 ;I '$D(^TMP("PSJINS",$J)),VERB]"" S ^TMP("PSJINS",$J,1)=VERB
46 S X=0
47 I $D(^PS(50.606,PSJDFNO,"NOUN")) F Z=0:0 S Z=$O(^PS(50.606,PSJDFNO,"NOUN",Z)) Q:'Z S X=X+1,^TMP("PSJNOUN",$J,X)=$P($G(^PS(50.606,PSJDFNO,"NOUN",Z,0)),U)_U_$P($G(^PS(50.606,PSJDFNO,"MISC")),U)_U_$P($G(^("MISC")),U,3)
48 Q
49 ;
50MEDROUTE ;* Return all med routes in the med routes file.
51 S (MR,MCT)=0 K ^TMP("PSJMR",$J)
52 F S MR=$O(^PS(51.2,MR)) Q:'MR S MRNODE=^PS(51.2,MR,0) I $P(^PS(51.2,MR,0),"^",4)=1 S MCT=MCT+1,^TMP("PSJMR",$J,MCT)=$P(MRNODE,U)_U_$P(MRNODE,U,3)_U_MR_U_$P(MRNODE,U,2)_U_$S($P(MRNODE,U,6):1,1:0)
53 Q
54NOD K ^TMP("PSJMR",$J)
55 S MR=+$P($G(^PS(50.7,+PSJORD,0)),"^",6) I MR,$D(^PS(51.2,MR,0)),$P(^PS(51.2,MR,0),"^",4)=1 S ^TMP("PSJMR",$J,1)=$P(^PS(51.2,MR,0),"^")_U_$P(^(0),"^",3)_U_MR_U_$P(^(0),"^",2)_U_$S($P(^(0),"^",6):1,1:0)_"^D"
56 Q
57START1(PSJORD,PSJQOF) ;Entry point for IV dialog PSS*1*94
58 ; This is the new entry point for the IV Dialog box from CPRS GUI 27. PSJORD will be an array
59 ; sent by CPRS that contains all the IENS for all orderable items that are part of the order. The zero node of the array
60 ; will contain the total number of orderable items in the order.
61 ;
62 ; PSJQOF is the quick order flag. 0=not a quick order 1=quick order
63 ;
64 ; If there is only one orderable item, any default defined in the Pharmacy Orderable Item file (50.7) will be
65 ; marked with a D at the end of the data string.
66 ;
67 ; If there is more than one orderable item in the order, no default will be sent, and a union (the overlapping)
68 ; of the med routes will be returned. For example if Dextrose can be given IV or IM, and the Ampicillin is only
69 ; given IM, IM is the only med route that will be returned because it is the only overlapping med route between
70 ; the two orderable items. If there is no overlapping med route to be returned, then a NULL will be returned to CPRS.
71 ;
72 ; If the quick order flag PSJQOF is set to 1, then CPRS is expecting the overlapping med routes for the orderable items
73 ; as well as the entire list of med routes that are flagged for IV's.
74 ;
75 I PSJQOF="" S PSJQOF=0
76 K PSJORD1,^TMP("PSJMR",$J)
77 I $G(PSJORD(0))=1 S PSJOPAC="I" D Q
78 . S PSJORD=$P($G(PSJORD(1)),"^",1)
79 . D MEDRT(PSJORD)
80 . I PSJQOF=1 S MCT=$O(^TMP("PSJMR",$J,"A"),-1) D ALLMED(MCT)
81 . M PSJORD1=^TMP("PSJMR",$J)
82 . D REMDUP
83 . K PSJORD
84 . M PSJORD=PSJORD1
85 . K PSJORD1,^TMP("PSJMR",$J)
86 S X=0
87 F S X=$O(PSJORD(X)) Q:X="" D
88 . S PSJORD=$P($G(PSJORD(X)),"^",1)
89 . D MEDRT(PSJORD)
90 . M PSJORD1(X)=^TMP("PSJMR",$J) K ^TMP("PSJMR",$J) ;Start with fresh TMP for each OI
91 D OVERLAP
92 I PSJQOF=1 S MCT=$O(MRTEMP2("A"),-1) D ALLMED(MCT)
93 M PSJORD1=^TMP("PSJMR",$J)
94 D REMDUP
95 K PSJORD
96 M PSJORD=PSJORD1
97 K PSJORD1,MRTEMP2,MRTEMP,MRNODE,MRNODE1,^TMP("PSJMR",$J),PSSCNTR1
98 Q
99MEDRT(PSJORD) ;All Med Routes for dosage form.
100 N MR,X,PSJDFNO,MCT
101 S (MR,MCT,X,PSJDFNO)=0
102 S PSJDFNO=+$P($G(^PS(50.7,+PSJORD,0)),U,2)
103 S MR=+$P($G(^PS(50.7,+PSJORD,0)),"^",6) I MR,$D(^PS(51.2,MR,0)),$P($G(^(0)),"^",4)=1 S ^TMP("PSJMR",$J,1)=MR_U_$P(^PS(51.2,MR,0),"^")_U_$P(^(0),"^",3)_U_$P(^(0),"^",2)_U_"D",MCT=MCT+1
104 S MR=0 F S MR=$O(^PS(50.606,PSJDFNO,"MR",MR)) Q:'MR D
105 . S X=+$G(^PS(50.606,PSJDFNO,"MR",MR,0))
106 . I X=$P($G(^PS(50.7,+PSJORD,0)),"^",6) Q ;Already counted as the default. Don't count twice.
107 . S MRNODE=$G(^PS(51.2,X,0))
108 . I $P($G(MRNODE),"^",4)'=1 Q
109 . S MCT=MCT+1,^TMP("PSJMR",$J,MCT)=X_U_$P(MRNODE,U)_U_$P(MRNODE,U,3)_U_$P(MRNODE,U,2)_U
110 Q
111ALLMED(MCT) ;Return all med routes with IV flag set to 1
112 N MR,MRNODE
113 I MCT="" S MCT=0
114 S (MR,MRNODE)=""
115 F S MR=$O(^PS(51.2,MR)) Q:MR="" D
116 . S MRNODE=$G(^PS(51.2,MR,0))
117 . I $P(MRNODE,U,4)'=1 Q ;Not defined for all packages
118 . I $P(MRNODE,U,6)'=1 Q ;IV flag not set
119 . S MCT=MCT+1,^TMP("PSJMR",$J,MCT)=MR_U_$P(MRNODE,U)_U_$P(MRNODE,U,3)_U_$P(MRNODE,U,2)_U
120 Q
121OVERLAP ; Only maintains any overlapping med routes between orderable items in order
122 N MR,MRNODE,X,PSSCNTR1
123 K MRTEMP,MRTEMP2
124 S (MR,MRNODE,X)=""
125 F S X=$O(PSJORD1(X)) Q:X="" D
126 . F S MR=$O(PSJORD1(X,MR)) Q:MR="" D
127 . . S MRNODE=$P($G(PSJORD1(X,MR)),"^",1)
128 . . S MRTEMP(MRNODE)=$G(MRTEMP(MRNODE))+1
129 S MR=""
130 F S MR=$O(MRTEMP(MR)) Q:MR="" D
131 . I MRTEMP(MR)'=$G(PSJORD(0)) K MRTEMP(MR) Q
132 I '$D(MRTEMP) K PSJORD1 S PSJORD1="" Q ;No overlapping med routes between orderable items.
133 S (MR,MRNODE)="",PSSCNTR1=1
134 F S MR=$O(MRTEMP(MR)) Q:MR="" D
135 . S MRNODE=$G(^PS(51.2,MR,0))
136 . S MRTEMP2(PSSCNTR1)=MR_U_$P(MRNODE,U,1)_U_$P(MRNODE,U,3)_U_$P(MRNODE,U,2)_U,PSSCNTR1=PSSCNTR1+1
137 K PSJORD1,MRTEMP
138 M PSJORD1=MRTEMP2
139 Q
140REMDUP ; Remove duplicate entries
141 N MR,MRNODE
142 S MR="",MRNODE=""
143 F S MR=$O(PSJORD1(MR)) Q:MR="" D
144 . S MRNODE=$P($G(PSJORD1(MR)),"^",2)
145 . I $D(MRTEMP(MRNODE)) K PSJORD1(MR) Q
146 . S MRTEMP(MRNODE)=$G(PSJORD1(MR))
147 . I MR=1,$P($G(PSJORD1(MR)),"^",5)="D" S MRTEMP(MR)=PSJORD1(MR) Q ;Maintain default if there is one.
148 . S MRTEMP(MR)=PSJORD1(MR)
149 S MR=""
150 F S MR=$O(MRTEMP(MR)) Q:MR="" D
151 . I MR'?1.N K MRTEMP(MR)
152 I PSJORD(0)=1 M PSJORD1=MRTEMP
153 K MRTEMP
154 Q
Note: See TracBrowser for help on using the repository browser.