source: FOIAVistA/trunk/r/PHARMACY_DATA_MANAGEMENT-PSS/PSS50CMP.m@ 1427

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

initial load of FOIAVistA 6/30/08 version
File size: 6.6 KB
Line 
1PSS50CMP ;BIR/RTR - CONTINUATION OF API FOR INFORMATION FROM FILE 50; 5 Sep 03
2 ;;1.0;PHARMACY DATA MANAGEMENT;**85**;9/30/97
3 ;
4CMOP ;
5 ;PSSIEN - IEN of entry in 50
6 ;PSSFT - Free Text name in 50
7 ;PSSFL - Inactive flag - "" - All entries
8 ; FileMan Date - Only entries with no Inactive Date or an Inactive Date greater than this date.
9 ;PSSPK - Application Package's Use - "" - All entries
10 ; Alphabetic codes that represent the DHCP packages that consider this drug to be
11 ; part of their formulary.
12 ;PSSRTOI - Orderable Item - return only entries matched to a Pharmacy Orderable Item
13 ;LIST - Subscript of ^TMP array in the form ^TMP($J,LIST,Field Number where Field Number is the Field Number of the data
14 ; piece being returned.
15 ;Returns zero node of 50
16 N DIERR,ZZERR,PSSP50,SCR,PSS,PSSMLCT
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 S SCR("S")=""
21 I +$G(PSSFL)>0!($G(PSSPK)]"")!($G(PSSRTOI)=1) N PSS5ND,PSSZ3,PSSZ4 D SETSCRN^PSS50A
22 I +$G(PSSIEN)>0 N PSSIEN2 S PSSIEN2=$$FIND1^DIC(50,"","A","`"_PSSIEN,,SCR("S"),"") D K ^TMP("PSSP50",$J) Q
23 .K ^TMP("DIERR",$J)
24 .I +PSSIEN2'>0 S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q
25 .S ^TMP($J,LIST,0)=1
26 .D SETSUB5^PSS50AQM(+PSSIEN2)
27 .K ^TMP("PSSP50",$J) D GETS^DIQ(50,+PSSIEN2,".01;213;214*;215;28","IE","^TMP(""PSSP50"",$J)") S PSS(1)=0
28 .F S PSS(1)=$O(^TMP("PSSP50",$J,50,PSS(1))) Q:'PSS(1) D SETCMOP D
29 ..S (PSS(2),PSSMLCT)=0 F S PSS(2)=$O(^TMP("PSSP50",$J,50.0214,PSS(2))) Q:'PSS(2) S PSSMLCT=PSSMLCT+1 D SETACT
30 ..S ^TMP($J,LIST,+PSS(1),"AL",0)=$S($G(PSSMLCT):PSSMLCT,1:"-1^NO DATA FOUND")
31 I $G(PSSIEN)'="" S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q
32 I $G(PSSFT)]"" D
33 .I PSSFT["??" D LOOP Q
34 .K ^TMP("DILIST",$J)
35 .D FIND^DIC(50,,"@;.01","QP",PSSFT,,"B",SCR("S"),,"")
36 .I +$G(^TMP("DILIST",$J,0))=0 S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q
37 .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
38 ..S PSSIEN=+^TMP("DILIST",$J,PSSXX,0)
39 ..D SETSUB5^PSS50AQM(PSSIEN) K ^TMP("PSSP50",$J) D GETS^DIQ(50,+PSSIEN,".01;213;214*;215;28","IE","^TMP(""PSSP50"",$J)") S PSS(1)=0
40 ..F S PSS(1)=$O(^TMP("PSSP50",$J,50,PSS(1))) Q:'PSS(1) D SETCMOP D
41 ...S (PSS(2),PSSMLCT)=0 F S PSS(2)=$O(^TMP("PSSP50",$J,50.0214,PSS(2))) Q:'PSS(2) S PSSMLCT=PSSMLCT+1 D SETACT
42 ...S ^TMP($J,LIST,+PSS(1),"AL",0)=$S($G(PSSMLCT):PSSMLCT,1:"-1^NO DATA FOUND")
43 K ^TMP("DILIST",$J),^TMP("PSSP50",$J)
44 Q
45SETCMOP ;
46 S ^TMP($J,LIST,+PSS(1),.01)=$G(^TMP("PSSP50",$J,50,PSS(1),.01,"I"))
47 S ^TMP($J,LIST,"B",$G(^TMP("PSSP50",$J,50,PSS(1),.01,"I")),+PSS(1))=""
48 S ^TMP($J,LIST,+PSS(1),213)=$S($G(^TMP("PSSP50",$J,50,PSS(1),213,"I"))="":"",1:^TMP("PSSP50",$J,50,PSS(1),213,"I")_"^"_$G(^TMP("PSSP50",$J,50,PSS(1),213,"E")))
49 S ^TMP($J,LIST,+PSS(1),215)=$G(^TMP("PSSP50",$J,50,PSS(1),215,"I"))
50 S ^TMP($J,LIST,+PSS(1),28)=$S($G(^TMP("PSSP50",$J,50,PSS(1),28,"I"))="":"",1:^TMP("PSSP50",$J,50,PSS(1),28,"I")_"^"_$G(^TMP("PSSP50",$J,50,PSS(1),28,"E")))
51 Q
52SETACT ;
53 S ^TMP($J,LIST,+PSS(1),"AL",+PSS(2),.01)=$S($G(^TMP("PSSP50",$J,50.0214,PSS(2),.01,"I"))="":"",1:^TMP("PSSP50",$J,50.0214,PSS(2),.01,"I")_"^"_$G(^TMP("PSSP50",$J,50.0214,PSS(2),.01,"E")))
54 S ^TMP($J,LIST,+PSS(1),"AL",+PSS(2),1)=$S($G(^TMP("PSSP50",$J,50.0214,PSS(2),1,"I"))="":"",1:^TMP("PSSP50",$J,50.0214,PSS(2),1,"I")_"^"_$G(^TMP("PSSP50",$J,50.0214,PSS(2),1,"E")))
55 S ^TMP($J,LIST,+PSS(1),"AL",+PSS(2),2)=$S($G(^TMP("PSSP50",$J,50.0214,PSS(2),2,"I"))="":"",1:^TMP("PSSP50",$J,50.0214,PSS(2),2,"I")_"^"_$G(^TMP("PSSP50",$J,50.0214,PSS(2),2,"E")))
56 S ^TMP($J,LIST,+PSS(1),"AL",+PSS(2),3)=$G(^TMP("PSSP50",$J,50.0214,PSS(2),3,"I"))
57 S ^TMP($J,LIST,+PSS(1),"AL",+PSS(2),4)=$G(^TMP("PSSP50",$J,50.0214,PSS(2),4,"I"))
58 S ^TMP($J,LIST,+PSS(1),"AL",+PSS(2),5)=$G(^TMP("PSSP50",$J,50.0214,PSS(2),5,"I"))
59 Q
60 ;
61LOOP ;
62 N PSS50DD9,PSS50D10,PSS50D11,PSS50ER9,PSS50E10,PSS50E11,PSS28OPD,PSS213PD,PSS5021X
63 D FIELD^DID(50,28,"Z","POINTER","PSS50DD9","PSS50ER9") S PSS28OPD=$G(PSS50DD9("POINTER"))
64 D FIELD^DID(50,213,"Z","POINTER","PSS50D10","PSS50E10") S PSS213PD=$G(PSS50D10("POINTER"))
65 D FIELD^DID(50.0214,1,"Z","POINTER","PSS50D11","PSS50E11") S PSS5021X=$G(PSS50D11("POINTER"))
66 N PSSENCT
67 S PSSENCT=0
68 S PSS(1)=0 F S PSS(1)=$O(^PSDRUG(PSS(1))) Q:'PSS(1) D
69 .I $P($G(^PSDRUG(PSS(1),0)),"^")="" Q
70 .I $G(PSSFL),$P($G(^PSDRUG(PSS(1),"I")),"^"),$P($G(^("I")),"^")'>PSSFL Q
71 .I $G(PSSRTOI)=1,'$P($G(^PSDRUG(PSS(1),2)),"^") Q
72 .;Naked reference below refers to ^PSDRUG(PSS(1),2)
73 .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
74 .I $G(PSSPK)]"",'PSSZ5 Q
75 .D SETSUB5^PSS50AQM(PSS(1))
76 .D SETCMQ,SETACQ
77 .S PSSENCT=PSSENCT+1
78 S ^TMP($J,LIST,0)=$S($G(PSSENCT):$G(PSSENCT),1:"-1^NO DATA FOUND")
79 Q
80 ;
81SETCMQ ;
82 N PSSCMP3,PSSCMP5,PSSCMP6
83 S ^TMP($J,LIST,+PSS(1),.01)=$P(^PSDRUG(PSS(1),0),"^")
84 S ^TMP($J,LIST,"B",$P(^PSDRUG(+PSS(1),0),"^"),+PSS(1))=""
85 N PSS28OP S PSS28OP=$P($G(^PSDRUG(+PSS(1),6)),"^") D
86 .I PSS28OP'="",PSS28OPD'="",PSS28OPD[(PSS28OP_":") S ^TMP($J,LIST,+PSS(1),28)=PSS28OP_"^"_$P($E(PSS28OPD,$F(PSS28OPD,(PSS28OP_":")),999),";") Q
87 .S ^TMP($J,LIST,+PSS(1),28)=""
88 N PSS213P S PSS213P=$P($G(^PSDRUG(+PSS(1),3)),"^") D
89 .I PSS213P'="",PSS213PD'="",PSS213PD[(PSS213P_":") S ^TMP($J,LIST,+PSS(1),213)=PSS213P_"^"_$P($E(PSS213PD,$F(PSS213PD,(PSS213P_":")),999),";") Q
90 .S ^TMP($J,LIST,+PSS(1),213)=""
91 S ^TMP($J,LIST,+PSS(1),215)=$P($G(^PSDRUG(+PSS(1),5)),"^")
92 Q
93 ;
94SETACQ ;
95 N PSS504C S PSS504C=0
96 I $O(^PSDRUG(+PSS(1),4,0)) N PSS504,PSS504ND D
97 .F PSS504=0:0 S PSS504=$O(^PSDRUG(+PSS(1),4,PSS504)) Q:'PSS504 D
98 ..S PSS504ND=$G(^PSDRUG(+PSS(1),4,PSS504,0)) I $P(PSS504ND,"^")'="" S PSS504C=PSS504C+1 D
99 ...N Y S (^TMP($J,LIST,+PSS(1),"AL",PSS504,.01),Y)=$P(PSS504ND,"^") X ^DD("DD") S ^TMP($J,LIST,+PSS(1),"AL",PSS504,.01)=^TMP($J,LIST,+PSS(1),"AL",PSS504,.01)_"^"_$G(Y)
100 ...N PSS5021 S PSS5021=$P(PSS504ND,"^",2) D
101 ....I PSS5021'="",PSS5021X'="",PSS5021X[(PSS5021_":") S ^TMP($J,LIST,+PSS(1),"AL",PSS504,1)=PSS5021_"^"_$P($E(PSS5021X,$F(PSS5021X,(PSS5021_":")),999),";") Q
102 ....S ^TMP($J,LIST,+PSS(1),"AL",PSS504,1)=""
103 ...N PSS200,PSSA200 S PSS200=$P(PSS504ND,"^",3) I PSS200 D GETS^DIQ(50.0214,+PSS504_","_+PSS(1),2,"E","PSSA200") S ^TMP($J,LIST,+PSS(1),"AL",PSS504,2)=PSS200_"^"_$G(PSSA200(50.0214,+PSS504_","_+PSS(1)_",",2,"E"))
104 ...S ^TMP($J,LIST,+PSS(1),"AL",PSS504,3)=$P(PSS504ND,"^",4)
105 ...S ^TMP($J,LIST,+PSS(1),"AL",PSS504,4)=$P(PSS504ND,"^",5)
106 ...S ^TMP($J,LIST,+PSS(1),"AL",PSS504,5)=$P(PSS504ND,"^",6)
107 S ^TMP($J,LIST,+PSS(1),"AL",0)=$S(PSS504C:PSS504C,1:"-1^NO DATA FOUND")
108 Q
109
Note: See TracBrowser for help on using the repository browser.