source: WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODISP1.m@ 691

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

initial load of WorldVistAEHR
File size: 6.7 KB
RevLine 
[613]1PSODISP1 ;BHAM ISC/SAB,PDW - Rx released/unrelease report ; 08 Oct 1999 9:58 AM
2 ;;7.0;OUTPATIENT PHARMACY;**15,9,33**;DEC 1997
3 ;External reference to ^PS(59.7 supported by DBIA 694
4 ;External reference to ^PSDRUG( supported by DBIA 221
5 I '$D(PSOPAR) D ^PSOLSET I '$D(PSOPAR) W $C(7),!!,"Pharmacy Division must be selected!",! G EXIT
6AC S (I,MUL)=0,SITE=PSOSITE,PSIN=+$P($G(^PS(59.7,1,49.99)),"^",2)
7 F S I=$O(^PS(59,I)) Q:'I S MUL=MUL+1
8 W @IOF,!?15,"Report of Released and UnReleased Prescriptions",!
9 I $G(MUL)>1 D G:$D(STOP) EXIT
10 .W ! S DIR("?",1)="Your Site Parameter file shows multiple divisions.",DIR("A",1)="You are currently logged in under the "_$P(^PS(59,PSOSITE,0),"^",1)_" division."
11 .S DIR("A")="Do you want to select a different division",DIR("?")="Enter 'Y' to select a different division for this report.",DIR(0)="Y",DIR("B")="NO" D ^DIR K DIR S:$D(DIRUT) STOP=1
12 .I $G(Y)=1 W ! S DIC("A")="Division: ",DIC=59,DIC(0)="AEQM" D ^DIC K DIC I $D(DIRUT) S STOP=1 Q
13 .Q:Y<1 S SITE=+Y W !
14 W ! S DIR("B")="NO",DIR("A")="Do you want ONLY Unreleased Prescriptions",DIR("?")="Enter 'Y' for ONLY Unreleased Prescriptions",DIR(0)="Y" D ^DIR K DIR G:$D(DTOUT)!($D(DUOUT)) EXIT S DUD=Y
15 ;
16CS ; ask CS selection criteria - store in DUD1
17 K DIR
18 S DIR(0)="SA^C:Controlled Substances Rxs Only;N:Non-controlled Substances Rxs Only;B:Both Controlled and Non-controlled Substance Rxs"
19 S DIR("B")="B",DIR("A")="Include (C)S Rx only, (N)on CS Rx only, or (B)oth (C/N/B): "
20 K DUD1 D ^DIR K DIR G:$D(DTOUT)!($D(DUOUT)) EXIT
21 S DUD1=Y
22 W ! S %DT(0)=PSIN,X1=DT,X2=-30 D C^%DTC I X>PSIN S (BEGDT,Y)=X
23 E S (BEGDT,Y)=PSIN
24 X ^DD("DD") S BEG=Y,%DT("A")="Enter Start date: ",%DT("B")=BEG,%DT="AEPX",%DT(0)=PSIN D ^%DT G:"^"[$E(X) EXIT S (%DT(0),BEGDT)=Y
25 S Y=DT X ^DD("DD") S END=Y
26 S %DT("A")="Ending date: ",%DT("B")=END D ^%DT K %DT G:"^"[$E(X) EXIT S ENDDT=Y
27 S Y=ENDDT D DD^%DT S PEDATE=Y S Y=BEGDT D DD^%DT S PSDATE=Y
28 ; ***
29 K IO("Q"),%ZIS,IOP,ZTSK S PSOION=ION,%ZIS("S")="I $E($G(^%ZIS(2,+$G(^(""SUBTYPE"")),0)),1)=""P""",%ZIS="MQ",%ZIS("A")="Select a PRINTER: ",%ZIS("B")=""
30 D ^%ZIS I POP S IOP=PSOION D ^%ZIS K IOP,PSOION G EXIT
31 K PSOION I $D(IO("Q")) D G EXIT
32 .S ZTRTN="BC^PSODISP1",ZTDESC="Report of released & unreleased prescriptions"
33 .F G="BEGDT","ENDDT","PSDATE","PEDATE","SITE","DUD","DUD1","PSXSYS" S:$D(@G) ZTSAVE(G)=""
34 .D ^%ZTLOAD W:$D(ZTSK) !,"Report Queued to Print !!",! K ZTSK,IO("Q")
35 ;
36BC S PG=1,(UNREL,CP)=0 U IO D HD,RPT
37 W !!," # of Unreleased Fills - "_UNREL_" # of Copay Fills - "_CP
38 I $E($G(IOST),1,2)'["C-" W !,@IOF
39EXIT D ^%ZISC K PG,LIN,G,UNREL,BEG,BEGDT,END,ENDDT,DR,X,X1,X2,Y,REC,DIR,DIRUT,DUOUT,I,Y,RXN,NODE,PAR,BDT,PSX,PSXZ
40 K PSOLCMF,STOP,TYPE,UNDERL,ZTDESC,ZTRTN,ZTSAVE,DIC,XY,ND,DUD,DUD1,DTOUT,SITE,MUL,CP,PSIN,%DT,PSDATE,PEDATE S:$D(ZTQUEUED) ZTREQ="@" K ZTQUEUED
41 Q
42RPT S ND="",RXN=0,BDT=BEGDT-1 F S BDT=$O(^PSRX("AD",BDT)) Q:'BDT!(BDT>ENDDT) F S RXN=$O(^PSRX("AD",BDT,RXN)) Q:'RXN F S ND=$O(^PSRX("AD",BDT,RXN,ND)) Q:ND="" S NODE=ND D I $Y+4>IOSL D HD
43 .Q:$G(^PSRX(RXN,0))']"" I $G(PSXSYS) K PSX D CMOP^PSOCMOPA
44 .Q:$G(^PSRX(RXN,0))']"" D @$S(NODE:"REF",1:"RPT2") K LB,LBLP
45 S (RXN,ND)=0,BDT=BEGDT-1 F S BDT=$O(^PSRX("ADP",BDT)) Q:'BDT!(BDT>ENDDT) F S RXN=$O(^PSRX("ADP",BDT,RXN)) Q:'RXN F S ND=$O(^PSRX("ADP",BDT,RXN,ND)) Q:'ND S NODE=ND D I $Y+4>IOSL D HD
46 .Q:$G(^PSRX(RXN,0))']"" S PAR=1 D REF K LB,LBLP
47 Q
48RPT2 I $P($G(^PSRX(RXN,2)),"^",13),DUD Q
49 I $P($G(^PSRX(RXN,2)),"^",15)]"",'$P(^(2),"^",14) Q
50 I $P($G(^PSRX(RXN,2)),"^",9)'=SITE Q
51 S XY=$P(^PSRX(RXN,"STA"),"^") I (XY=3)!(XY=4)!(XY=13)!(XY=16) Q
52 I $$CSDEA(RXN)=0 Q ; quit if CS Criteria fails
53 I $P(^PSRX(RXN,2),"^",13) W !,$P(^PSRX(RXN,0),"^"),?16,"Original" S Y=$P(^PSRX(RXN,2),"^",13) X ^DD("DD") W ?29,$S(Y["@":$P(Y,"@"),1:Y),?50,"YES" D CP1 Q
54 I '$P(^PSRX(RXN,2),"^",13) D Q:('$G(LBLP)&($G(PSX(0))']"")) W !,$P(^PSRX(RXN,0),"^"),?16,"Original",?50,"No" S UNREL=UNREL+1 D CP1
55 .F LB=0:0 S LB=$O(^PSRX(RXN,"L",LB)) Q:'LB I '$P(^PSRX(RXN,"L",LB,0),"^",2),$P(^(0),"^",3)'["INTERACTION",'$P(^(0),"^",5) S LBLP=1 Q
56 ;I $G(PSX(0))]"" W ?85,"YES",?95,$S(PSX(0)=0:"Transmitted",PSX(0)=1:"DISPENSED",PSX(0)=2:"Retransmitted",PSX(0)=3:"Not Dispensed",1:"Unknown")
57 Q
58REF ;
59 I $P($G(^PSRX(RXN,$S('$G(PAR):1,1:"P"),NODE,0)),"^",$S('$G(PAR):18,1:19)),DUD Q
60 I $P($G(^PSRX(RXN,$S('$G(PAR):1,1:"P"),NODE,0)),"^",9)'=SITE Q
61 I $P($G(^PSRX(RXN,$S('$G(PAR):1,1:"P"),NODE,0)),"^",16)]"" Q
62 S XY=$P(^PSRX(RXN,"STA"),"^") I (XY=3)!(XY=4)!(XY>12) Q
63 I $$CSDEA(RXN)=0 Q ; quit if CS Criteria fails
64 I $P($G(^PSRX(RXN,$S('$G(PAR):1,1:"P"),NODE,0)),"^",$S('$G(PAR):18,1:19)) D G CP1
65 .W !,$P(^PSRX(RXN,0),"^"),?16,$S('$G(PAR):"Refill",1:"Partial")_" #",NODE S Y=$P(^PSRX(RXN,$S('$G(PAR):1,1:"P"),NODE,0),"^",$S('$G(PAR):18,1:19)) X ^DD("DD") W ?29,$S(Y["@":$P(Y,"@"),1:Y),?50,"Yes"
66 I '$P(^PSRX(RXN,$S('$G(PAR):1,1:"P"),NODE,0),"^",$S('$G(PAR):18,1:19)) D Q:('$G(LBLP)&($G(PSX(NODE))']"")) D TEST Q:'$G(LBLP)&($G(PSOLCMF)) W !,$P(^PSRX(RXN,0),"^"),?16,$S('$G(PAR):"Refill",1:"Partial")_" #",NODE,?50,"No" S UNREL=UNREL+1
67 .F LB=0:0 S LB=$O(^PSRX(RXN,"L",LB)) Q:'LB I $P(^PSRX(RXN,"L",LB,0),"^",2)=$S('$G(PAR):NODE,1:99-NODE) S LBLP=1 Q
68CP1 W ?60,$S(XY=1:"Non-verified",XY=2:"Refill",XY=3!(XY=16):"Hold",XY=5:"Suspended",XY=10:"Done",XY=11:"Expired",XY=12!(XY=14)!(XY=15):"Discontinued",1:"Active")
69 Q:$G(PAR) I $P($G(^PSRX(RXN,"IB")),"^") W ?75,"Yes" S CP=CP+1
70 I $G(PSX(NODE))]"" W ?85,"Yes",?95,$S(PSX(NODE)=0:"Transmitted",PSX(NODE)=1:"Dispensed",PSX(NODE)=2:"Retransmitted",PSX(NODE)=3:"Not Dispensed",1:"Unknown")
71 Q
72 ;
73HD W @IOF,?$S('DUD:17,1:20),$S('DUD:"Release/",1:"")_"Unreleased Report for "_$P(^PS(59,SITE,0),"^",1),!
74 I $G(DUD1)="N" W ?13,"Non-controlled Substance Prescriptions Only"
75 I $G(DUD1)="C" W ?17,"Controlled Substance Prescriptions Only"
76 W !?18,PSDATE_" to "_PEDATE,?70,"Page: "_PG,!!,?16,"Fill/",?32,"Date",!,"Rx #",?16,"Refill",?30,"Released",?49,"Released",?61,"Status",?74,"Copay " W:$G(PSXSYS) "CMOP CMOP Status" W ! F LIN=1:1:$S($G(PSXSYS):115,1:80) W "-"
77 W ! S PG=PG+1 Q
78 ;
79TEST ;
80 S (PSOLCMF,PSOLCMR)=0
81 F PSOLCR=0:0 S PSOLCR=$O(^PSRX(RXN,1,PSOLCR)) Q:'PSOLCR I $D(^(PSOLCR,0)) S PSOLCMR=PSOLCR
82 I '$G(PSOLCMR) G TESTX
83 F PSOLCR=0:0 S PSOLCR=$O(^PSRX(RXN,"A",PSOLCR)) Q:'PSOLCR!($G(PSOLCMF)) D
84 .Q:$P($G(^PSRX(RXN,"A",PSOLCR,0)),"^",2)'="I"
85 .I $G(PSOLCMR)<6 S:$P($G(^PSRX(RXN,"A",PSOLCR,0)),"^",4)=$G(PSOLCMR) PSOLCMF=1 Q
86 .S PSOLCMRZ=$G(PSOLCMR)+1 S:PSOLCMRZ=$P($G(^PSRX(RXN,"A",PSOLCR,0)),"^",4) PSOLCMF=1 K PSOLCMRZ Q
87TESTX K PSOLCR,PSOLCMR
88 Q
89CSDEA(X) ;CS Critera .. returns a 1 if both DEA on drug & criteria 'N/C/B' are satisfied
90 I DUD1="B" Q 1 ;both CS & non CS (all)
91 N DEA,DRUGDA
92 S DRUGDA=$$GET1^DIQ(52,X,6,"I"),DEA=$$GET1^DIQ(50,DRUGDA,3)
93 S DEA=$S(DEA="":0,DEA["C":1,DEA["A":1,1:0) ;***
94 I DUD1="N",DEA=0 Q 1 ; no CS
95 I DUD1="C",DEA=1 Q 1 ; CS only
96 Q 0
Note: See TracBrowser for help on using the repository browser.