source: FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOMHV1.m@ 1397

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

initial load of FOIAVistA 6/30/08 version
File size: 9.1 KB
Line 
1PSOMHV1 ;BIR/MHA - MHV API, Build patient medication ; 4/20/05 8:54am
2 ;;7.0;OUTPATIENT PHARMACY;**204**;DEC 1997
3 ;External reference ^PS(55 supported by DBIA 2228
4 ;External reference ^PSDRUG( supported by DBIA 221
5 ;External reference to ^PS(51 supported by DBIA 2224
6 ;External reference to ^PS(51.2 supported by DBIA 2226
7 ;External reference to ^PS(50.7 supported by DBIA 2223
8 ;External reference to ^PS(50.606 supported by DBIA 2174
9 ; Input variables: dfn, start date, cut off date
10EN(DFN,BDT,EDT) ;entry point to return medication list
11 Q:'$G(DFN)
12 N DRG,DRGN,EXD,I,IFN,MIG,LSTFD,ORD,PEN,PSOBD,PSOED,PSODD,PSOOI,PSOSD,RX,RX0,RX2,RX3,TFN,TD,TR,TRM,SC,SCH,ST0,STA,PSODIV
13 I '$G(DT) S DT=$$DT^XLFDT
14 K ^TMP("PSO",$J) S PSOBD=$G(BDT),PSOED=$G(EDT)
15 I +$G(PSOBD)<1 S X1=DT,X2=-120 D C^%DTC S PSOBD=X
16 S EXD=PSOBD-1
17 I PSOED="" S PSOED=9999999
18 F S EXD=$O(^PS(55,DFN,"P","A",EXD)) Q:'EXD Q:EXD>PSOED D
19 .S RX=0 F S RX=$O(^PS(55,DFN,"P","A",EXD,RX)) Q:'RX D:$D(^PSRX(RX,0)) GET
20 S STA="ACT^NVR^REF^HLD^NVR^SUS^^^^^^EXP^DCD^DEL^DCD^DCD^HLD"
21 S DRG="" F S DRG=$O(PSOSD(DRG)) Q:DRG="" D:$G(PSOSD(DRG))]""
22 .S PSOSD($P(STA,"^",$P(PSOSD(DRG),"^",2)+1),DRG)=PSOSD(DRG) K PSOSD(DRG)
23 D PEN D:$D(PSOSD) BLD
24 Q
25EN2(DFN,RXLIST) ;Entry point to return data for specified RX #s
26 Q:DFN<1
27 Q:'RXLIST
28 N DRG,DRGN,EXD,I,IFN,MIG,LSTFD,ORD,PEN,PSOBD,PSOED,PSODD,PSOOI,PSOSD,RX,RX0,RX2,RX3,TFN,TD,TR,TRM,SC,SCH,ST0,STA,PSORX,J,PSOERR,RX,PSRXD,PSODIV,PSOSTA
29 I '$G(DT) S DT=$$DT^XLFDT
30 K ^TMP("PSO",$J)
31 S PSOSTA="ACT^NVR^REF^HLD^NVR^SUS^^^^^^EXP^DCD^DEL^DCD^DCD^HLD"
32 F J=1:1 S PSORX=$P(RXLIST,"^",J) Q:PSORX="" D
33 . I '$D(^PSRX("B",PSORX)) Q
34 . I $O(^PSRX("B",PSORX,""))="" Q
35 . S RX=$O(^PSRX("B",PSORX,"")),PSRXD=$G(^PSRX(RX,0))
36 . Q:PSRXD=""
37 . Q:$P(PSRXD,"^",2)'=DFN
38 . Q:$P($G(^PSRX(RX,"STA")),"^")=13
39 . Q:$P($G(^PSRX(RX,"STA")),"^")=15
40 . Q:'$D(^PSDRUG($P(PSRXD,"^",6),0))
41 . S IFN=RX,TR=$P(PSOSTA,"^",$P($G(^PSRX(RX,"STA")),"^")+1)
42 . S TD=$P(^PSDRUG($P(PSRXD,"^",6),0),"^")
43 . D RXD
44 . Q
45 Q
46 ;
47EN3(DFN,BDT,EDT) ;entry point to return prescription history
48 Q:'$G(DFN)
49 N DRG,DRGN,EXD,I,IFN,MIG,LSTFD,ORD,PEN,PSOBD,PSOED,PSODD,PSOOI,PSOSD,RX,RX0,RX2,RX3,TFN,TD,TR,TRM,SC,SCH,ST0,STA,PSODIV
50 I '$G(DT) S DT=$$DT^XLFDT
51 K ^TMP("PSO",$J) S PSOBD=$G(BDT),PSOED=$G(EDT)
52 I +$G(PSOBD)<1 S X1=DT,X2=-120 D C^%DTC S PSOBD=X
53 S EXD=PSOBD-1
54 I PSOED="" S PSOED=9999999
55 F S EXD=$O(^PS(55,DFN,"P","A",EXD)) Q:'EXD Q:EXD>PSOED D
56 .S RX=0 F S RX=$O(^PS(55,DFN,"P","A",EXD,RX)) Q:'RX D:$D(^PSRX(RX,0)) GET1
57 S STA="ACT^NVR^REF^HLD^NVR^SUS^^^^^^EXP^DCD^DEL^DCD^DCD^HLD"
58 ; Uses RX (Rx IEN) instead of DRUG as a subscript in PSOSD and thus
59 ; in ^TMP("PSO",$J). Other entry points use DRUG
60 S RX="" F S RX=$O(PSOSD(RX)) Q:RX="" D:$G(PSOSD(RX))]""
61 .S PSOSD($P(STA,"^",$P(PSOSD(RX),"^",2)+1),RX)=PSOSD(RX) K PSOSD(RX)
62 D:$D(PSOSD) BLD
63 Q
64 ;
65PEN F PEN=0:0 S PEN=$O(^PS(52.41,"P",DFN,PEN)) Q:'PEN D
66 .S ORD=^PS(52.41,PEN,0) Q:$P(ORD,"^",2)'=DFN S DRG=""
67 .Q:$P(ORD,"^",3)="DC"!($P(ORD,"^",3)="DE")!($P(ORD,"^",3)="")!($P(ORD,"^",3)="RF")
68 .S PSOOI=$P(ORD,"^",8),PSODD=+$P(ORD,"^",9)
69 .S DRG=$S(PSODD:$P($G(^PSDRUG(PSODD,0)),"^"),+PSOOI&('PSODD):$P(^PS(50.7,+PSOOI,0),"^")_" "_$P(^PS(50.606,$P(^PS(50.7,+PSOOI,0),"^",2),0),"^"),1:"")
70 .Q:DRG']""
71 .I $D(PSOSD("PEN",DRG)) S DRG=DRG_"^"_PEN
72 .S PSOSD("PEN",DRG)=PEN
73 Q
74GET ;
75 Q:$P($G(^PSRX(RX,"STA")),"^")=13
76 Q:$P($G(^PSRX(RX,"STA")),"^")=15
77 Q:'$P(^PSRX(RX,0),"^",2)
78 Q:$P(^PSRX(RX,0),"^",2)'=DFN
79 S RX0=^PSRX(RX,0),RX2=^PSRX(RX,2)
80 S DRG=$P(^PSRX(RX,0),"^",6),STA=+^("STA") Q:'$D(^PSDRUG(DRG,0))
81 S DRGN=$P(^PSDRUG(DRG,0),"^"),ST0=$S(STA<12&($P(RX2,"^",6)<DT):11,1:STA)
82 I $D(PSOSD(DRGN)),ST0>10 Q:$P(PSOSD(DRGN),"^",2)<11 Q:$P(PSOSD(DRGN),"^",2)>10&($P(RX0,"^",13)<$P(^PSRX(+$P(PSOSD(DRGN),"^"),0),"^",13))
83 I $D(PSOSD(DRGN)),$P(PSOSD(DRGN),"^",2)<10,ST0<10 S PSOSD(DRGN_"^"_RX)=RX_"^"_ST0
84 E S PSOSD(DRGN)=RX_"^"_ST0
85 Q
86GET1 ;
87 Q:'$P(^PSRX(RX,0),"^",2)
88 Q:$P(^PSRX(RX,0),"^",2)'=DFN
89 S RX0=^PSRX(RX,0),RX2=^PSRX(RX,2)
90 S DRG=$P(^PSRX(RX,0),"^",6),STA=+^("STA") Q:'$D(^PSDRUG(DRG,0))
91 S DRGN=$P(^PSDRUG(DRG,0),"^"),ST0=$S(STA<12&($P(RX2,"^",6)<DT):11,1:STA)
92 S PSOSD(RX)=RX_"^"_ST0
93 Q
94BLD ;
95 S TR="" F S TR=$O(PSOSD(TR)) Q:TR="" D
96 .S TFN=0,TD="" F S TD=$O(PSOSD(TR,TD)) Q:TD="" S IFN=+PSOSD(TR,TD) D @$S(TR="PEN":"PND",1:"RXD")
97 Q
98RXD ;
99 Q:'$D(^PSRX(IFN,0))
100 S RX0=^PSRX(IFN,0),RX2=$G(^(2)),RX3=$G(^(3)),STA=+$G(^("STA")),TRM=0,LSTFD=$P(RX2,"^",2)
101 S ^TMP("PSO",$J,TR,TD,"RXN",0)=$P(RX0,"^")_"^"_$E($P(RX2,"^",13),1,7)_"^"_$S($P(RX0,"^",11)="W":"W",1:"M")_"^"_$P(RX3,"^",7)
102 S ^TMP("PSO",$J,TR,TD,"RXN",0)=^TMP("PSO",$J,TR,TD,"RXN",0)_"^"_$S($P($G(^PSRX(IFN,"OR1")),"^",5):$P(^PSRX(IFN,"OR1"),"^",5),1:"")_"^"_$E($P(RX2,"^",2),1,7)_"^"_$E($P(RX2,"^",13),1,7)_"^^"_IFN
103 S I=0 F S I=$O(^PSRX(IFN,1,I)) Q:'I S TRM=TRM+1,LSTFD=$P(^PSRX(IFN,1,I,0),"^") D
104 .S ^TMP("PSO",$J,TR,TD,"REF",I,0)=$P(^PSRX(IFN,1,I,0),"^")_"^"_$P(^(0),"^",10)_"^"_$P(^(0),"^",4)_"^"_$E($P(^(0),"^",18),1,7)_"^"_$S($P(^(0),"^",2)="W":"W",1:"M")_"^"_$P(^(0),"^",3)
105 .I $P(^PSRX(IFN,1,I,0),"^",18) S $P(^TMP("PSO",$J,TR,TD,"RXN",0),"^",2)=$E($P(^PSRX(IFN,1,I,0),"^",18),1,7)
106 .S ^TMP("PSO",$J,TR,TD,"REF",0)=$G(^TMP("PSO",$J,TR,TD,"REF",0))+1
107 S I=0 F S I=$O(^PSRX(IFN,"P",I)) Q:'I D
108 .S ^TMP("PSO",$J,TR,TD,"PAR",I,0)=$P(^PSRX(IFN,"P",I,0),"^")_"^"_$P(^(0),"^",10)_"^"_$P(^(0),"^",4)_"^"_$E($P(^(0),"^",19),1,7)_"^"_$S($P(^(0),"^",2)="W":"W",1:"M")_"^"_$P(^(0),"^",3)
109 .S ^TMP("PSO",$J,TR,TD,"PAR",0)=$G(^TMP("PSO",$J,TR,TD,"PAR",0))+1
110 S ^TMP("PSO",$J,TR,TD,0)=$P($G(^PSDRUG(+$P(RX0,"^",6),0)),"^")_"^^"_$P(RX2,"^",6)
111 S ^TMP("PSO",$J,TR,TD,"P",0)=$P(RX0,"^",4)_"^"_$P($G(^VA(200,+$P(RX0,"^",4),0)),"^")
112 S ST0=$S(STA<12&($P(RX2,"^",6)<DT):11,1:STA)
113 S SC=$P("ERROR^ACTIVE^NON-VERIFIED^REFILL FILL^HOLD^NON-VERIFIED^SUSPENDED^^^^^DONE^EXPIRED^DISCONTINUED^DELETED^DISCONTINUED^DISCONTINUED (EDIT)^HOLD^","^",ST0+2)
114 S ^TMP("PSO",$J,TR,TD,0)=^TMP("PSO",$J,TR,TD,0)_"^"_($P(RX0,"^",9)-TRM)_"^"_$P(RX0,"^",13)_"^"_SC_"^"_$P(RX0,"^",8)_"^"_$P(RX0,"^",7)_"^^^"_$P($G(^PSRX(IFN,"OR1")),"^",2)_"^"_LSTFD_"^^"
115 S ^TMP("PSO",$J,TR,TD,"DD",0)=1,^TMP("PSO",$J,TR,TD,"DD",1,0)=$P(RX0,"^",6)_"^^"
116 S (SCH,SC)=0
117 F S SC=$O(^PSRX(IFN,"SCH",SC)) Q:'SC S SCH=SCH+1,^TMP("PSO",$J,TR,TD,"SCH",SCH,0)=$P(^PSRX(IFN,"SCH",SC,0),"^") D
118 .S ^TMP("PSO",$J,TR,TD,"SCH",0)=$G(^TMP("PSO",$J,TR,TD,"SCH",0))+1
119 D MDR
120 S SC=0 I $D(^PSRX(IFN,"SIG")),'$P(^PSRX(IFN,"SIG"),"^",2) S SC=1 S X=$P(^PSRX(IFN,"SIG"),"^") D SIG
121 I '$G(SC) S SCH=1 D
122 .S ^TMP("PSO",$J,TR,TD,"SIG",SCH,0)=$G(^PSRX(IFN,"SIG1",1,0)),^TMP("PSO",$J,TR,TD,"SIG",0)=SCH
123 .F I=1:0 S I=$O(^PSRX(IFN,"SIG1",I)) Q:'I S SCH=SCH+1,^TMP("PSO",$J,TR,TD,"SIG",SCH,0)=^PSRX(IFN,"SIG1",I,0),^TMP("PSO",$J,TR,TD,"SIG",0)=SCH
124 S (I,SC)=0
125 F S I=$O(^PSRX(IFN,"PRC",I)) Q:'I S SC=SC+1 D
126 .S ^TMP("PSO",$J,TR,TD,"PC",SC,0)=^PSRX(IFN,"PRC",I,0),^TMP("PSO",$J,TR,TD,"PC",0)=SC
127 S PSODIV=$P(RX2,"^",9)
128 I PSODIV'="",$D(^PS(59,PSODIV,0)) S ^TMP("PSO",$J,TR,TD,"DIV",0)=PSODIV_"^"_^PS(59,PSODIV,0)
129 Q
130MDR ;
131 S (SCH,SC)=0
132 F S SC=$O(^PSRX(IFN,"MEDR",SC)) Q:'SC D
133 .Q:'$D(^PS(51.2,+^PSRX(IFN,"MEDR",SC,0),0)) S SCH=SCH+1
134 .S ^TMP("PSO",$J,TR,TD,"MDR",SCH,0)=$S($P(^PS(51.2,+^PSRX(IFN,"MEDR",SC,0),0),"^",3)]"":$P(^(0),"^",3),1:$P(^(0),"^"))
135 .S ^TMP("PSO",$J,TR,TD,"MDR",0)=SCH
136 Q
137PND Q:'$D(^PS(52.41,IFN,0))
138 S ORD=^PS(52.41,IFN,0) Q:$P(ORD,"^",2)'=DFN
139 Q:$P(ORD,"^",3)="DC"!($P(ORD,"^",3)="DE")
140 S PSOOI=+$P(ORD,"^",8),PSODD=+$P(ORD,"^",9)
141 S DRG=$S(PSODD:$P($G(^PSDRUG(PSODD,0)),"^"),1:$P(^PS(50.7,PSOOI,0),"^")_" "_$P(^PS(50.606,$P(^PS(50.7,PSOOI,0),"^",2),0),"^"))
142 S ^TMP("PSO",$J,TR,TD,0)=DRG
143 S:PSODD ^TMP("PSO",$J,TR,TD,"DD",0)=1,^TMP("PSO",$J,TR,TD,"DD",1,0)=PSODD_"^^"
144 S ^TMP("PSO",$J,TR,TD,0)=^TMP("PSO",$J,TR,TD,0)_"^"_$S($G(^PS(51.2,+$P(ORD,"^",15),0))]"":$P(^PS(51.2,+$P(ORD,"^",15),0),"^",3),1:"")
145 S ^TMP("PSO",$J,TR,TD,0)=^TMP("PSO",$J,TR,TD,0)_"^^"_$P(ORD,"^",11)_"^"_$P($P(ORD,"^",6),".")_"^"_$S($P(ORD,"^",3)'="HD":"PENDING",1:" ONHOLD")_"^^"_$P(ORD,"^",10)
146 S $P(^TMP("PSO",$J,TR,TD,0),"^",11)=$P(ORD,"^")
147 S (SC,SCH)=0 F S SC=$O(^PS(52.41,IFN,1,SC)) Q:'SC D
148 .S SCH=SCH+1,^TMP("PSO",$J,TR,TD,"SCH",SCH,0)=$P(^PS(52.41,IFN,1,SC,1),"^"),^TMP("PSO",$J,TR,TD,"SCH",0)=SCH
149 S (SC,SCH)=0 F S SC=$O(^PS(52.41,IFN,"SIG",SC)) Q:'SC D
150 .S SCH=SCH+1,^TMP("PSO",$J,TR,TD,"SIG",SCH,0)=$P(^PS(52.41,IFN,"SIG",SC,0),"^"),^TMP("PSO",$J,TR,TD,"SIG",0)=SCH
151 S SC=1,PEN="" F S PEN=$O(^PS(52.41,IFN,2,PEN)) Q:'PEN D
152 .S MIG=^PS(52.41,IFN,2,PEN,0),^TMP("PSO",$J,TR,TD,"SIO",0)=SC D
153 ..F SCH=1:1:$L(MIG," ") S:$L($G(^TMP("PSO",$J,TR,TD,"SIO",SC,0))_" "_$P(MIG,"",SCH))>80 SC=SC+1,^TMP("PSO",$J,TR,TD,"SIO",0)=SC D
154 ...S ^TMP("PSO",$J,TR,TD,"SIO",SC,0)=$G(^TMP("PSO",$J,TR,TD,"SIO",SC,0))_" "_$P(MIG," ",SCH)
155 Q
156SIG ;
157 N Z0,Z1,PSOX1,PSOX2 F Z0=1:1:$L(X," ") Q:Z0="" S Z1=$P(X," ",Z0) D
158 .D:$D(X)&($G(Z1)]"")
159 ..S Y=$O(^PS(51,"B",Z1,0)) Q:'Y!($P($G(^PS(51,+Y,0)),"^",4)>1) S Z1=$P(^PS(51,Y,0),"^",2) Q:'$D(^(9)) S Y=$P(X," ",Z0-1),Y=$E(Y,$L(Y)) S:Y>1 Z1=^(9)
160 .I $G(^TMP("PSO",$J,TR,TD,"SIG",1,0))']"" S ^TMP("PSO",$J,TR,TD,"SIG",1,0)=Z1,^TMP("PSO",$J,TR,TD,"SIG",0)=1 Q
161 .F PSOX1=0:0 S PSOX1=$O(^TMP("PSO",$J,TR,TD,"SIG",PSOX1)) Q:'PSOX1 S PSOX2=PSOX1
162 .I $L(^TMP("PSO",$J,TR,TD,"SIG",PSOX2,0))+$L(Z1)<245 S ^TMP("PSO",$J,TR,TD,"SIG",PSOX2,0)=^TMP("PSO",$J,TR,TD,"SIG",PSOX2,0)_" "_Z1
163 .E S PSOX2=PSOX2+1,^TMP("PSO",$J,TR,TD,"SIG",PSOX2,0)=Z1
164 Q
Note: See TracBrowser for help on using the repository browser.