source: FOIAVistA/trunk/r/SPINAL_CORD_DYSFUNCTION-SPN/SPNLGSRX.m@ 1607

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

initial load of FOIAVistA 6/30/08 version

File size: 3.0 KB
Line 
1SPNLGSRX ; ISC-SF/GMB - SCD GATHER (SPECIFIC) OUTPATIENT PHARMACY DATA;16 JUN 94 [ 07/02/94 4:24 PM ] ;6/23/95 11:49
2 ;;2.0;Spinal Cord Dysfunction;;01/02/1997
3SELECT(DFN,FDATE,TDATE,HI,QLIST) ;
4 ; DFN Patient's internal entry number in the Patient file
5 ; FDATE "From" date
6 ; TDATE "Thru" date, default=today
7 ; HI 1=keep track of individual patient usage
8 ; 0=don't keep track
9 ; Data will be rolled up into the following global:
10 ; ^TMP("SPN",$J,"RX",
11 ; with the following nodes:
12 ; "DRUG",drugnr) # fills for this drug
13 ; "DRUG",drugnr,"NAME") name of this drug
14 ; "DRUG",drugnr,"PAT") # patients who had this drug
15 ; "DRUG",drugnr,"PRICE") current unit price (cost) of this drug
16 ; "DRUG",drugnr,"QTY") total quantity of all fills for this drug
17 ; "DRUG",drugnr,"PID",patient name^SSN) fills^qty
18 N EXPDATE,RECNR,ZEROREC,TWOREC,ZDRUGNR,FILLS,UNITVAL,PNAME,PSSN
19 N FILLDATE,QTY,SUBRECNR
20 I '$D(TDATE) S TDATE=DT
21 ; We are interested in any drug whose prescription 'expiration' or
22 ; 'cancel' date falls on or after the 'from' date.
23 ; We are going to take only the fills or refills which occurred
24 ; during the 'from'-'thru' date range.
25 S EXPDATE=FDATE-.000001 ; for each expiration date
26 F S EXPDATE=$O(^PS(55,DFN,"P","A",EXPDATE)) Q:EXPDATE'>0 D
27 . S RECNR=0 ; for each prescription on that date
28 . F S RECNR=$O(^PS(55,DFN,"P","A",EXPDATE,RECNR)) Q:RECNR'>0 D
29 . . S TWOREC=$G(^PSRX(RECNR,2)) ; follow ptr to get prescripton info
30 . . Q:TWOREC=""
31 . . S FILLDATE=$P(TWOREC,U,2)
32 . . Q:FILLDATE>TDATE
33 . . S ZEROREC=$G(^PSRX(RECNR,0))
34 . . Q:ZEROREC=""
35 . . S ZDRUGNR=+$P(ZEROREC,U,6)
36 . . Q:'$D(QLIST(ZDRUGNR))
37 . . S (FILLS,QTY)=0
38 . . I FILLDATE'<FDATE,FILLDATE'>TDATE D TRACKIT(.FILLS,.QTY,$P(ZEROREC,U,7))
39 . . S SUBRECNR=0 ; for each refill of the drug
40 . . F S SUBRECNR=$O(^PSRX(RECNR,1,SUBRECNR)) Q:SUBRECNR'>0 D
41 . . . S ZEROREC=$G(^PSRX(RECNR,1,SUBRECNR,0))
42 . . . S FILLDATE=$P(ZEROREC,U,1)
43 . . . Q:FILLDATE<FDATE!(FILLDATE>TDATE)
44 . . . D TRACKIT(.FILLS,.QTY,$P(ZEROREC,U,4))
45 . . Q:'FILLS
46 . . S FILLS(ZDRUGNR)=$G(FILLS(ZDRUGNR))+FILLS
47 . . S QTY(ZDRUGNR)=$G(QTY(ZDRUGNR))+QTY
48 Q:$D(FILLS)<10 ; make sure this array has descendants
49 D:HI GETNAME^SPNLRU(DFN,.PNAME,.PSSN)
50 S ZDRUGNR="" ; for each drug
51 F S ZDRUGNR=$O(FILLS(ZDRUGNR)) Q:ZDRUGNR="" D
52 . S ^("PAT")=$G(^TMP("SPN",$J,"RX","DRUG",ZDRUGNR,"PAT"))+1
53 . S FILLS=FILLS(ZDRUGNR)
54 . S ^(ZDRUGNR)=$G(^TMP("SPN",$J,"RX","DRUG",ZDRUGNR))+FILLS
55 . S ^("QTY")=$G(^TMP("SPN",$J,"RX","DRUG",ZDRUGNR,"QTY"))+QTY(ZDRUGNR)
56 . S:HI ^TMP("SPN",$J,"RX","DRUG",ZDRUGNR,"PID",PNAME_U_PSSN)=FILLS_U_QTY
57 Q
58TRACKIT(FILLS,QTY,FILLQTY) ;
59 S FILLS=FILLS+1
60 S QTY=QTY+FILLQTY
61 Q
62PRICEIT ; gets the current unit price (cost) of each of the drugs
63 N ZDRUGNR,UNITVAL
64 S ZDRUGNR="" ; We might have a drug number which is zero...
65 F S ZDRUGNR=$O(^TMP("SPN",$J,"RX","DRUG",ZDRUGNR)) Q:ZDRUGNR="" D
66 . S UNITVAL=+$P($G(^PSDRUG(ZDRUGNR,660)),U,6) ; current price
67 . S ^TMP("SPN",$J,"RX","DRUG",ZDRUGNR,"PRICE")=UNITVAL
68 Q
Note: See TracBrowser for help on using the repository browser.