source: WorldVistAEHR/trunk/r/PHARMACY_DATA_MANAGEMENT-PSS/PSS50F.m@ 1375

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

initial load of WorldVistAEHR
File size: 7.7 KB
Line 
1PSS50F ;BIR/LDT - API FOR INFORMATION FROM FILE 50; 5 Sep 03
2 ;;1.0;PHARMACY DATA MANAGEMENT;**85,91**;9/30/97
3 ;External reference to DD(50,0,"IX" supported by DBIA 4323
4 ;External reference to PRC(441 is supported by DBIA 214
5 ;
6OLDNM ;
7 ;PSSIEN - IEN of entry in 50
8 ;PSSFT - Free Text name in 50
9 ;PSSFL - Inactive flag - "" - All entries
10 ; FileMan Date - Only entries with no Inactive Date or an Inactive Date greater than this date.
11 ;PSSPK - Application Package's Use - "" - All entries
12 ; Alphabetic codes that represent the DHCP packages that consider this drug to be
13 ; part of their formulary.
14 ;LIST - Subscript of ^TMP array in the form ^TMP($J,LIST,Field Number where Field Number is the Field Number of the data
15 ; piece being returned.
16 N DIERR,ZZERR,PSSP50,SCR,PSS,CNT
17 I $G(LIST)']"" Q
18 K ^TMP($J,LIST)
19 I +$G(PSSIEN)'>0,($G(PSSFT)']"") S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q
20 I $G(PSSIEN)]"",+$G(PSSIEN)'>0 S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q
21 S SCR("S")="",CNT=0
22 I +$G(PSSFL)>0!($G(PSSPK)]"") N PSS5ND,PSSZ3,PSSZ4 D SETSCRN^PSS50A
23 I $G(PSSIEN)]"" N PSSIEN2 S PSSIEN2=$$FIND1^DIC(50,"","A","`"_PSSIEN,,SCR("S"),"") D
24 .I +PSSIEN2'>0 S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q
25 .S ^TMP($J,LIST,0)=1
26 .K ^TMP($J,"PSS50") D GETS^DIQ(50,+PSSIEN2,".01;900*","IE","^TMP($J,""PSS50""") S PSS(1)=0
27 .F S PSS(1)=$O(^TMP($J,"PSS50",50,PSS(1))) Q:'PSS(1) D
28 ..S ^TMP($J,LIST,+PSS(1),.01)=^TMP($J,"PSS50",50,PSS(1),.01,"I")
29 ..S ^TMP($J,LIST,"B",^TMP($J,"PSS50",50,PSS(1),.01,"I"),+PSS(1))=""
30 ..S PSS(2)=0 F S PSS(2)=$O(^TMP($J,"PSS50",50.01,PSS(2))) Q:'PSS(2) D SETOLDNM S CNT=CNT+1
31 ..S ^TMP($J,LIST,+PSS(1),"OLD",0)=$S(CNT>0:CNT,1:"-1^NO DATA FOUND")
32 I +$G(PSSIEN)'>0,$G(PSSFT)]"" D
33 .I PSSFT["??" D LOOP(1) Q
34 .D FIND^DIC(50,,"@;.01","QP",PSSFT,,"B",SCR("S"),,"")
35 .I +$G(^TMP("DILIST",$J,0))=0 S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q
36 .I +^TMP("DILIST",$J,0)>0 S ^TMP($J,LIST,0)=+^TMP("DILIST",$J,0) N PSSXX S PSSXX=0 F S PSSXX=$O(^TMP("DILIST",$J,PSSXX)) Q:'PSSXX D
37 ..S PSSIEN=+^TMP("DILIST",$J,PSSXX,0) K ^TMP($J,"PSS50") S CNT=0 D GETS^DIQ(50,+PSSIEN,".01;900*","IE","^TMP($J,""PSS50""") S PSS(1)=0
38 ..F S PSS(1)=$O(^TMP($J,"PSS50",50,PSS(1))) Q:'PSS(1) D
39 ...S ^TMP($J,LIST,+PSS(1),.01)=^TMP($J,"PSS50",50,PSS(1),.01,"I")
40 ...S ^TMP($J,LIST,"B",^TMP($J,"PSS50",50,PSS(1),.01,"I"),+PSS(1))=""
41 ...S PSS(2)=0 F S PSS(2)=$O(^TMP($J,"PSS50",50.01,PSS(2))) Q:'PSS(2) D SETOLDNM S CNT=CNT+1
42 ...S ^TMP($J,LIST,+PSS(1),"OLD",0)=$S(CNT>0:CNT,1:"-1^NO DATA FOUND")
43 K ^TMP("DILIST",$J),^TMP($J,"PSS50")
44 Q
45 ;
46LOOP(PSS) ;
47 N CNT,PSSIEN S CNT=0
48 S PSSIEN=0 F S PSSIEN=$O(^PSDRUG(PSSIEN)) Q:'PSSIEN D
49 .I $P($G(^PSDRUG(PSSIEN,0)),"^")="" Q
50 .I $G(PSSFL),$P($G(^PSDRUG(PSSIEN,"I")),"^"),$P($G(^("I")),"^")'>PSSFL Q
51 .I $G(PSSRTOI)=1,'$P($G(^PSDRUG(PSSIEN,2)),"^") Q
52 .;Naked reference below refers to ^PSDRUG(PSSIEN,2)
53 .I $G(PSSPK)]"" N PSSZ5,PSSZ6 S PSSZ5=0 F PSSZ6=1:1:$L(PSSPK) Q:PSSZ5 I $P($G(^(2)),"^",3)[$E(PSSPK,PSSZ6) S PSSZ5=1
54 .I $G(PSSPK)]"",'PSSZ5 Q
55 .D @PSS
56 S ^TMP($J,LIST,0)=$S(CNT>0:CNT,1:"-1^NO DATA FOUND")
57 Q
58 ;
59SETOLDNM ;
60 S ^TMP($J,LIST,+PSS(1),"OLD",+PSS(2),.01)=^TMP($J,"PSS50",50.01,PSS(2),.01,"I")
61 S ^TMP($J,LIST,+PSS(1),"OLD",+PSS(2),.02)=$S($G(^TMP($J,"PSS50",50.01,PSS(2),.02,"I"))="":"",1:^TMP($J,"PSS50",50.01,PSS(2),.02,"I")_"^"_^TMP($J,"PSS50",50.01,PSS(2),.02,"E"))
62 Q
63 ;
64SETLIST ;
65 S ^TMP($J,LIST,+PSS(1),.01)=^TMP($J,"PSS50",50,PSS(1),.01,"I")
66 S ^TMP($J,LIST,$S($G(PSSD)]"":$P(PSSD,"^"),1:"B"),^TMP($J,"PSS50",50,PSS(1),.01,"I"),+PSS(1))=""
67 S ^TMP($J,LIST,+PSS(1),2.1)=$S($G(^TMP($J,"PSS50",50,PSS(1),2.1,"I"))="":"",1:^TMP($J,"PSS50",50,PSS(1),2.1,"I")_"^"_^TMP($J,"PSS50",50,PSS(1),2.1,"E"))
68 S ^TMP($J,LIST,+PSS(1),100)=$S($G(^TMP($J,"PSS50",50,PSS(1),100,"I"))="":"",1:^TMP($J,"PSS50",50,PSS(1),100,"I")_"^"_^TMP($J,"PSS50",50,PSS(1),100,"E"))
69 Q
70 ;
71SETLOOK ;
72 S ^TMP($J,LIST,+PSS(2),.01)=PSS50(50,PSS(2),.01,"I")
73 S ^TMP($J,LIST,$S($G(PSSCRFL)]"":$P(PSSCRFL,"^"),1:"B"),PSS50(50,PSS(2),.01,"I"),+PSS(2))=""
74 S ^TMP($J,LIST,+PSS(2),2.1)=$S($G(PSS50(50,PSS(2),25,"I"))="":"",1:PSS50(50,PSS(2),25,"I")_"^"_PSS50(50,PSS(2),25,"E"))
75 S ^TMP($J,LIST,+PSS(2),100)=$S($G(PSS50(50,PSS(2),100,"I"))="":"",1:PSS50(50,PSS(2),100,"I")_"^"_PSS50(50,PSS(2),100,"E"))
76 S ^TMP($J,LIST,+PSS(2),101)=$S($G(PSS50(50,PSS(2),101,"I"))="":"",1:PSS50(50,PSS(2),101,"I")_"^"_PSS50(50,PSS(2),101,"E"))
77 Q
78 ;
79ADDOLDNM(PSSIEN2,PSSONM2,PSSDT2) ;
80 ;PSSIEN2 - IEN of entry in DRUG file (#50).
81 ;PSSONM2 - Text of the old name.
82 ;PSSDT2 - Date changed in FileMan format.
83 ;0 (zero)is returned if ADD was unsuccessful. 1 (one) will indicate successful ADD.
84 ;Adding new entry to OLD NAME multiple (#50.01) of the DRUG file (#50).
85 I (+$G(PSSIEN2)'>0)!($G(PSSONM2)']"") Q 0
86 S:+$G(PSSDT2)'>0 PSSDT2=DT
87 N PSS,QFLG
88 N PSSIEN4 S PSSIEN4=$$FIND1^DIC(50,"","A","`"_PSSIEN2,,,"")
89 I +PSSIEN4'>0 Q 0
90 D LIST^DIC(50.01,","_PSSIEN2_",","@;.01IE;.02IE","P",,,,,,,)
91 I +^TMP("DILIST",$J,0)'>0 D
92 .S PSS(1,50.01,"+2,"_PSSIEN2_",",.01)=$G(PSSONM2)
93 .S PSS(1,50.01,"+2,"_PSSIEN2_",",.02)=$G(PSSDT2)
94 I +^TMP("DILIST",$J,0)>0 S (QFLG,PSS)=0 F S PSS=$O(^TMP("DILIST",$J,PSS)) Q:'PSS Q:QFLG D
95 .I $P($G(^TMP("DILIST",$J,PSS,0)),"^",2)=PSSONM2,($P($G(^(0)),"^",4)=PSSDT2) S QFLG=1 Q
96 .S PSS(1,50.01,"+2,"_PSSIEN2_",",.01)=$G(PSSONM2)
97 .S PSS(1,50.01,"+2,"_PSSIEN2_",",.02)=$G(PSSDT2)
98 I $G(QFLG) Q 0
99 D UPDATE^DIE("","PSS(1)") Q 1
100 Q
101EDTIFCAP(PSSIEN2,PSSVAL2) ;
102 ;PSSIEN2 - IEN of entry in DRUG file (#50).
103 ;PSSVAL2 - IFCAP ITEM NUMBER to be added.
104 ;0 (zero)is returned if ADD was unsuccessful. 1 (one) will indicate successful ADD.
105 ;Adding new entry to IFCAP ITEM NUMBER multiple (#50.01) of the DRUG file (#50).
106 I (+$G(PSSIEN2)'>0)!+($G(PSSVAL2)'>0) Q 0
107 N PSS,QFLG
108 N PSSIEN3 S PSSIEN3=$$FIND1^DIC(441,"","A","`"_PSSVAL2,,,"")
109 I +PSSIEN3'>0 Q 0
110 N PSSIEN4 S PSSIEN4=$$FIND1^DIC(50,"","A","`"_PSSIEN2,,,"")
111 I +PSSIEN4'>0 Q 0
112 D LIST^DIC(50.0441,","_PSSIEN2_",","@;.01IE","P",,,,,,,)
113 I +^TMP("DILIST",$J,0)'>0 D
114 .S PSS(1,50.0441,"+2,"_PSSIEN2_",",.01)=$G(PSSVAL2)
115 I +^TMP("DILIST",$J,0)>0 S (QFLG,PSS)=0 F S PSS=$O(^TMP("DILIST",$J,PSS)) Q:'PSS Q:QFLG D
116 .I $P($G(^TMP("DILIST",$J,PSS,0)),"^",2)=PSSVAL2 S QFLG=1 Q
117 .I $O(^PSDRUG("AB",PSSVAL2,"")) S QFLG=1 Q
118 .S PSS(1,50.0441,"+2,"_PSSIEN2_",",.01)=$G(PSSVAL2)
119 I $G(QFLG) Q 0
120 D UPDATE^DIE("","PSS(1)") Q 1
121 Q
1221 ;
123 N CNT2 S CNT2=0
124 K ^TMP($J,"PSS50") D GETS^DIQ(50,+PSSIEN,".01;900*","IE","^TMP($J,""PSS50""") S PSS(1)=0
125 F S PSS(1)=$O(^TMP($J,"PSS50",50,PSS(1))) Q:'PSS(1) D
126 .S ^TMP($J,LIST,+PSS(1),.01)=^TMP($J,"PSS50",50,PSS(1),.01,"I"),CNT=CNT+1
127 .S ^TMP($J,LIST,"B",^TMP($J,"PSS50",50,PSS(1),.01,"I"),+PSS(1))=""
128 .S (PSS(2),CNT2)=0 F S PSS(2)=$O(^TMP($J,"PSS50",50.01,PSS(2))) Q:'PSS(2) D SETOLDNM S CNT2=CNT2+1
129 .S ^TMP($J,LIST,+PSS(1),"OLD",0)=$S(CNT2>0:CNT2,1:"-1^NO DATA FOUND")
130 K ^TMP($J,"PSS50")
131 Q
1322 ;
133 K ^TMP($J,"PSS50") D GETS^DIQ(50,+PSSIEN,".01;100;2.1","IE","^TMP($J,""PSS50""") S PSS(1)=0
134 F S PSS(1)=$O(^TMP($J,"PSS50",50,PSS(1))) Q:'PSS(1) D SETLIST S CNT=CNT+1
135 K ^TMP($J,"PSS50")
136 Q
137PARSE(PSSLUP) ; Create array of cross references, piece 2 of the array =1 for pointer fields, else 0
138 I $G(PSSLUP)="" Q
139 N PSSLUPA,PSSLUP1,PSSLUP2,PSSLUP3,PSSLUP4,PSSLUP5,PSSDTYPE,PSSPTER
140 I $E(PSSLUP)="^" S PSSLUP=$E(PSSLUP,2,$L(PSSLUP))
141 S PSSLUP1=0 F PSSLUP2=1:1:$L(PSSLUP) I $E(PSSLUP,PSSLUP2)="^" S PSSLUP1=PSSLUP1+1
142 S PSSLUP1=PSSLUP1+1
143 S PSSLUP4=1 F PSSLUP3=1:1:PSSLUP1 S PSSLUP5=$P(PSSLUP,"^",PSSLUP3) I PSSLUP5'="" D S PSSLUPAR(PSSLUP4)=PSSLUP5_"^"_$G(PSSPTER),PSSLUP4=PSSLUP4+1
144 .N PSSCRX,PSSCRX1 S PSSPTER=0
145 .S PSSCRX="" F S PSSCRX=$O(^DD(50,0,"IX",PSSLUP5,PSSCRX)) Q:PSSCRX="" S PSSCRX1="" F S PSSCRX1=$O(^DD(50,0,"IX",PSSLUP5,PSSCRX,PSSCRX1)) Q:PSSCRX1="" D
146 ..K PSSDTYPE D FIELD^DID(PSSCRX,PSSCRX1,,"TYPE","PSSDTYPE") I $G(PSSDTYPE("TYPE"))="POINTER" S PSSPTER=1
147 Q
Note: See TracBrowser for help on using the repository browser.