source: FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECXAPHA2.m@ 1536

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

initial load of FOIAVistA 6/30/08 version

File size: 4.4 KB
Line 
1ECXAPHA2 ;ALB/TMD-Pharmacy Extracts Unusual Volumes Report ; 10/18/07 2:10pm
2 ;;3.0;DSS EXTRACTS;**40,49,84,104,105**;Dec 22, 1997;Build 70
3 ;
4EN ; entry point
5 N COUNT,ECUNIT,LINE,ECDFN,ECD,ECDRG,ECDAY,ECDFN,ECQTY,ECUNIT,ECCOST,ECDS
6 K ^TMP($J)
7 S (COUNT,ECDS)=0,ECUNIT=""
8 S ECD=ECSD1,ECED=ECED+.3
9 S LINE=$S(ECXOPT=1:"PRE",ECXOPT=2:"IVP",ECXOPT=3:"UDP",1:"EXIT")
10 D @LINE
11 Q
12 ;
13PRE ; entry point for PRE data
14 N ECRFL,ECRX,ECREF,ECDATA,ECDATA1,ECPRC,IEN
15 K ^TMP($J,"ECXDSS")
16 ;call pharmacy api pso52ex
17 D EXTRACT^PSO52EX(ECD,ECED,"ECXDSS")
18 S ECREF="RF"
19 ;order thru fills and refills; refill values 0 thru 11
20 ; Note: refill 0 = original fill
21 F S ECD=$O(^TMP($J,"ECXDSS","AL",ECD)),IEN=0 Q:'ECD Q:ECD>ECED Q:ECXERR F S IEN=$O(^(ECD,IEN)),ECRFL="" Q:'IEN Q:ECXERR F S ECRFL=$O(^(IEN,ECRFL)) Q:'ECRFL Q:ECXERR D PRE2
22 ;
23 ;order thru partial fills
24 S ECD=ECSD1,ECREF="P"
25 F S ECD=$O(^TMP($J,"ECXDSS","AM",ECD)),IEN=0 Q:'ECD Q:ECD>ECED Q:ECXERR F S IEN=$O(^(ECD,IEN)),ECRFL="" Q:'IEN Q:ECXERR F S ECRFL=$O(^(IEN,ECRFL)) Q:'ECRFL Q:ECXERR D PRE2
26 K ^TMP($J,"ECXDSS")
27 Q
28 ;
29PRE2 ; get Prescription data
30 I (ECREF="RF")&(ECRFL) D
31 .S ECQTY=+^TMP($J,"ECXDSS",IEN,ECREF,ECRFL,1)
32 .S ECDS=+^TMP($J,"ECXDSS",IEN,ECREF,ECRFL,1.1)
33 .S ECPRC=^TMP($J,"ECXDSS",IEN,ECREF,ECRFL,1.2)
34 I (ECREF="RF")&('ECRFL) D
35 .S ECQTY=+^TMP($J,"ECXDSS",IEN,7)
36 .S ECDS=+^TMP($J,"ECXDSS",IEN,8)
37 .S ECPRC=+^TMP($J,"ECXDSS",IEN,17)
38 I ECREF="P" D
39 .S ECQTY=+^TMP($J,"ECXDSS",IEN,ECREF,ECRFL,.04)
40 .S ECDS=+^TMP($J,"ECXDSS",IEN,ECREF,ECRFL,.041)
41 .S ECPRC=+^TMP($J,"ECXDSS",IEN,ECREF,ECRFL,.042)
42 ;check to see if quantity>threshold
43 I ECQTY>ECTHLD D
44 .S ECDAY=ECD
45 .S ECDFN=$P(^TMP($J,"ECXDSS",IEN,2),U)
46 .S ECDRG=+$P(^TMP($J,"ECXDSS",IEN,6),U)
47 .S ECCOST=ECQTY*ECPRC
48 .D FILE Q:ECXERR
49 Q
50 ;
51IVP ; entry point for IVP Data
52 N DFN,ON,DA,SA,ECCOUNT
53 F S ECD=$O(^ECX(728.113,"A",ECD)),DFN=0 Q:'ECD Q:ECD>ECED Q:ECXERR F S DFN=$O(^ECX(728.113,"A",ECD,DFN)),ON=0 Q:'DFN F S ON=$O(^ECX(728.113,"A",ECD,DFN,ON)),DA=0 Q:'ON K ^TMP($J,"A"),^("S") D Q:ECXERR
54 .F S DA=$O(^ECX(728.113,"A",ECD,DFN,ON,DA)) Q:'DA Q:ECXERR I $D(^ECX(728.113,DA,0)) S EC=^(0) Q:ECXERR D
55 ..S ECDRG=$P(EC,U,4)
56 ..S SA=$S($P(EC,U,8)]"":"A",$P(EC,U,9):"S",1:"")
57 ..; set up new record for first DA for this drug
58 ..I '$D(^TMP($J,SA,ECDRG)) D
59 ...S ECQTY=+$S(SA="A":+$P(EC,U,7),SA="S":+$P(EC,U,9),1:0)
60 ...S ECUNIT=$S(SA="A":$P(EC,U,8),SA="S":"ML",1:"")
61 ...S ECCOST=$P(EC,U,12),ECDFN=DFN
62 ...S ^TMP($J,SA,ECDRG)=ECUNIT_U_ECD_U_ECDFN_U_ECCOST_U_ECQTY
63 ...S ^(ECDRG,1)=0
64 ..; add to qty (0,1, or -1) to total
65 ..S ^TMP($J,SA,ECDRG,1)=^TMP($J,SA,ECDRG,1)+$S($P(EC,U,6)=1:1,$P(EC,U,6)=4:0,1:-1)
66 .; looped thru all DAs for this order - now check for unusual volumes
67 .F SA="S","A" S ECDRG="" F S ECDRG=$O(^TMP($J,SA,ECDRG)) Q:ECDRG="" Q:ECXERR D
68 ..S ECQTY=$P(^TMP($J,SA,ECDRG),U,5),ECCOUNT=^(ECDRG,1)
69 ..S ECQTY=ECQTY*ECCOUNT
70 ..; check to see if quantity is outside of threshold range
71 ..I (ECQTY>ECTHLD)!(ECQTY<-ECTHLD) D
72 ...S ECUNIT=$P(^TMP($J,SA,ECDRG),U)
73 ...S ECDAY=$P(^(ECDRG),U,2)
74 ...S ECDFN=$P(^(ECDRG),U,3)
75 ...S ECCOST=$P(^(ECDRG),U,4)*ECCOUNT
76 ...D FILE Q:ECXERR
77 K ^TMP($J,"A"),^("S")
78 Q
79 ;
80UDP ; entry point for UDP data
81 N ECXJ,ECDATA
82 F S ECD=$O(^ECX(728.904,"A",ECD)) Q:'ECD Q:ECD>ECED Q:ECXERR D
83 .S ECXJ=0 F S ECXJ=$O(^ECX(728.904,"A",ECD,ECXJ)) Q:'ECXJ Q:ECXERR I $D(^ECX(728.904,ECXJ,0)) D
84 ..S DATA=^ECX(728.904,ECXJ,0),ECQTY=$P(DATA,U,5)
85 ..;check to see if quantity>threshold
86 ..I ECQTY>ECTHLD D
87 ...S ECDFN=$P(DATA,U,2),ECDRG=$P(DATA,U,4),ECCOST=$P(DATA,U,8),ECDAY=ECD
88 ...D FILE Q:ECXERR
89 Q
90 ;
91FILE ; put records in temp file to print later
92 N OK,ECXPAT,ECNAME,ECSSN,ECGNAME,ECNDC,ECPROD,ECFKEY,ECXPHA
93 ; get demographics
94 S OK=$$PAT^ECXUTL3(ECDFN,$P(ECD,"."),"1;",.ECXPAT)
95 I 'OK Q
96 S ECNAME=ECXPAT("NAME")
97 S ECSSN=ECXPAT("SSN")
98 S ECDAY=$E(ECDAY,4,5)_"/"_$E(ECDAY,6,7)
99 ; get drug file data
100 S ECXPHA="",ECXPHA=$$PHAAPI^ECXUTL5(ECDRG)
101 S ECGNAME=$P(ECXPHA,U)
102 S ECNDC=$P(ECXPHA,U,3)
103 S ECNDC=$$RJ^XLFSTR($P(ECNDC,"-"),6,0)_$$RJ^XLFSTR($P(ECNDC,"-",2),4,0)_$$RJ^XLFSTR($P(ECNDC,"-",3),2,0)
104 S ECNDC=$TR(ECNDC,"*",0)
105 S ECPROD=$P(ECXPHA,U,6)
106 S ECPROD=$$RJ^XLFSTR(ECPROD,5,0)
107 S ECFKEY=ECPROD_ECNDC
108 I ECXOPT'=2 S ECUNIT=$P(ECXPHA,U,8)
109 ; file
110 S ^TMP($J,ECFKEY,-ECQTY,ECDAY,ECSSN)=ECNAME_U_ECSSN_U_ECDAY_U_ECGNAME_U_ECFKEY_U_ECQTY_U_ECUNIT_U_"$"_$FNUMBER(ECCOST,",",2)_U_ECDS
111 S COUNT=COUNT+1
112 I COUNT#100=0 I $$S^ZTLOAD S (ZSTOP,ECXERR)=1
113 Q
114 ;
115EXIT S ECXERR=1 Q
Note: See TracBrowser for help on using the repository browser.