source: WorldVistAEHR/trunk/r/DRUG_ACCOUNTABILITY-PSA/PSAOP.m@ 1800

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

initial load of WorldVistAEHR

File size: 5.8 KB
RevLine 
[613]1PSAOP ;BIR/LTL-Outpatient Dispensing (Single Drug) ;7/23/97
2 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**3,15**; 10/24/97
3 ;This routine is the gathers OP dispensing for a date range.
4 ;
5 ;References to ^PSDRUG( are covered by IA #2095
6 ;References to ^PSRX( are covered by IA #254
7 ;
8 D PSAWARN^PSAPSI I $D(PSAQUIT) K PSAQUIT Q
9 ;
10 N DIC,DIE,DINUM,D0,D1,DLAYGO,DR,DIR,DIRUT,DTOUT,DUOUT,PSADR,PSADREC,PSADT,PSAPG,PSAS,PSA,PSAOUT,PSARELDT,PSADT,DA,PSADRUG,PSADRUGN,PSALN,PSAP,PSAN,PSAQ,PSAR,X,X2,Y
11LOOK D:'$G(PSALOC) OP^PSADA
12 I $G(PSALOC)<0 K PSALOC G QUIT
13 S:'$G(PSALOCN) PSALOCN=$P($G(^PSD(58.8,+PSALOC,0)),U)
14 S DIR(0)="Y",DIR("A")="OK",DIR("B")="Yes",DIR("?")="No allows you to change Location." D ^DIR K DIR S:$D(DIRUT) PSAOUT=1 G:$D(DIRUT) QUIT I Y=0 K PSALOC D OP^PSADA G:'$G(PSALOC) QUIT
15 I '$O(^PSD(58.8,+PSALOC,1,0)) W !!,"There are no drugs in ",PSALOCN G QUIT
16 D NOW^%DTC S PSADT=X,X="T-6000" D ^%DT S PSADT(1)=Y
17 S DIC="^PSD(58.8,+PSALOC,1,",DIC(0)="AEQ",DIC("A")="Please select "_PSALOCN_"'S drug: ",DIC("S")="I $S($P($G(^(0)),U,14):$P($G(^(0)),U,14)>DT,1:1)"
18 S PSAS=$P($G(^PSD(58.8,+PSALOC,0)),U,10),PSADT(3)=0
19 F W ! S DA(1)=PSALOC D ^DIC G:Y<0 QUIT S PSADRUG=+Y D G:$G(PSAOUT) QUIT G:$G(PSA(5)) TR D DEV Q:$G(PSAOUT)
20 .D:'$G(^PSD(58.8,+PSALOC,1,+PSADRUG,6)) Q:$G(PSAOUT)
21 ..W !!,"Dispensing has never been collected for this drug.",!!
22 ..S DIR(0)="D^"_PSADT(1)_":"_PSADT_":AEX",DIR("A")="How far back would you like to collect",DIR("B")="T-6000" D ^DIR K DIR S (PSADT(2),PSADT(4),PSAR,PSAP,PSAN)=Y,(PSADT(3),PSAR(1),PSAP(1),PSAN(1))=0 I Y<1 S PSAOUT=1 Q
23 .S PSAG=$G(^PSD(58.8,+PSALOC,1,+PSADRUG,6))
24 .S:'$G(PSADT(2)) PSADT(2)=$P(PSAG,U),PSA(7)=1
25 .W !!,"Checking dispensing"
26 .S:'$G(PSAR) PSAR=$P(PSAG,U,2) S:'$G(PSAP) PSAP=$P(PSAG,U,7)
27 .S:'$G(PSAN) PSAN=$P(PSAG,U,9) S (PSAR(1),PSAP(1),PSAN(1))=0
28 .F S PSADT(2)=$O(^PSRX("AL",PSADT(2))) Q:'PSADT(2) F S PSADT(3)=$O(^PSRX("AL",+PSADT(2),PSADT(3))) Q:'PSADT(3) W:'(PSADT(3)#10) "." D:$P($G(^PSRX(+PSADT(3),0)),U,6)=PSADRUG&($P($G(^PSRX(+PSADT(3),2)),U,9)=PSAS)
29 ..S PSADT(4)="" F S PSADT(4)=$O(^PSRX("AL",+PSADT(2),+PSADT(3),PSADT(4))) Q:PSADT(4)="" D
30 ...;
31 ...;DAVE B (PSA*3*3)
32 ...Q:$D(^PSRX("AR",+PSADT(2),+PSADT(3),PSADT(4))) ;Released to CMOP, do not count
33 ...S ^TMP("PSA",$J,+PSADRUG,$E(PSADT(2),1,7))=($P($G(^TMP("PSA",$J,+PSADRUG,$E(PSADT(2),1,7))),U)+$S(PSADT(4):$P($G(^PSRX(+PSADT(3),1,+PSADT(4),0)),U,4),1:$P($G(^PSRX(+PSADT(3),0)),U,7)))_U_PSADT(2)_U_PSADT(3),PSA(9)=PSADT(3)
34 .W !!,"Checking refills"
35 .D:$O(^PSRX("AJ",PSAR))
36 ..F S PSAR=$O(^PSRX("AJ",PSAR)) Q:'PSAR F S PSAR(1)=$O(^PSRX("AJ",+PSAR,+PSAR(1))) Q:'PSAR(1) W "." D:$P($G(^PSRX(+PSAR(1),0)),U,6)=PSADRUG&($P($G(^PSRX(+PSAR(1),2)),U,9)=PSAS)
37 ...S PSAR(3)="" F S PSAR(3)=$O(^PSRX("AJ",+PSAR,+PSAR(1),PSAR(3))) Q:PSAR(3)="" D
38 ....S $P(^TMP("PSA",$J,+PSADRUG,$E(PSAR,1,7)),U)=($P($G(^TMP("PSA",$J,+PSADRUG,$E(PSAR,1,7))),U)-$S(PSAR(3):$P($G(^PSRX(+PSAR(1),1,+PSAR(3),0)),U,4),1:$P($G(^PSRX(+PSAR(1),0)),U,7)))
39 ....S $P(^TMP("PSA",$J,+PSADRUG,$E(PSAR,1,7)),U,4)=PSAR,$P(^($E(PSAR,1,7)),U,5)=PSAR(1),PSAR(2)=PSAR(1)
40 .D:$O(^PSRX("AM",+PSAP))!($O(^PSRX("AN",+PSAN))) AM^PSAOP4
41 .I '$D(^TMP("PSA",$J,+PSADRUG)) W !!,"Sorry, no dispensing for this drug has occurred since " S Y=$S($P(PSAG,U):$P(PSAG,U),1:$G(PSADT(4))) X ^DD("DD") W Y,".",! S PSAOUT=1 Q
42 .S DIR(0)="Y",DIR("A")="Would you like a report of dispensing totals",DIR("B")="Yes" D ^DIR K DIR S:$D(DIRUT) PSAOUT=1 S:Y'=1 PSA(5)=1
43 ;
44DEV K IO("Q") N %ZIS,IOP,POP S %ZIS="Q" I Y=1 W ! D ^%ZIS
45 I $G(POP) W !,"NO DEVICE SELECTED OR ACTION TAKEN!" S PSAOUT=1 G QUIT
46 I $D(IO("Q")) N ZTDESC,ZTIO,ZTRTN,ZTSAVE,ZTDTH,ZTSK S ZTRTN="LUP^PSAOP",ZTDESC="Drug Acct-OP Dispensing Log",(ZTSAVE("^TMP(""PSA"",$J,+PSADRUG,"),ZTSAVE("PSA*"))="" D ^%ZTLOAD,HOME^%ZIS G QUIT
47LUP S (PSAPG,PSAOUT)=0,PSADRUG(1)=$P($G(^PSDRUG(+PSADRUG,660)),U,6),PSADRUG(2)=$P($G(^(660)),U,8)
48 S X=PSADRUG(1),X2="3$" D COMMA^%DTC S PSADRUG(3)=X
49 D HEADER
50 S (PSA(4),PSA(6))=0 F S PSA(4)=$O(^TMP("PSA",$J,+PSADRUG,PSA(4))) Q:'PSA(4) S PSA(6)=PSA(6)+1,Y=PSA(4) X ^DD("DD") D
51 .W !!,Y S X=$P($G(^TMP("PSA",$J,+PSADRUG,PSA(4))),U),X2=0 D COMMA^%DTC W ?14,X,PSADRUG(2),?40,PSADRUG(3),"/",PSADRUG(2),?63
52 .S PSADRUG(4)=$G(PSADRUG(4))+$P($G(^TMP("PSA",$J,+PSADRUG,PSA(4))),U)
53 .S X=$P($G(^TMP("PSA",$J,+PSADRUG,PSA(4))),U)*PSADRUG(1),PSADRUG(5)=$G(PSADRUG(5))+X,X2="2$" D COMMA^%DTC W ?40,X
54 W !,PSALN,!,PSA(6)," DAY TOTALS: " S X=PSADRUG(4),X2=0 D COMMA^%DTC W ?5,X,PSADRUG(2)
55 S X=PSADRUG(5),X2="2$" D COMMA^%DTC W ?63,X
56STOP W:$E(IOST)'="C" @IOF
57 I $E(IOST,1,2)="C-",'$G(PSAOUT) W ! S DIR(0)="EA",DIR("A")="END OF REPORT! Press <RET> to return to the menu." D ^DIR K DIR
58 D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@" K IO("Q")
59 W !!,"Updating history and dispensing totals."
60TR S ZTIO="",ZTRTN="LOOP^PSAOP",ZTDESC="Drug Acct-Dispensing Totals",ZTDTH=$H,(ZTSAVE("^TMP(""PSA"",$J,+PSADRUG,"),ZTSAVE("PSA*"))="" D ^%ZTLOAD,HOME^%ZIS
61 K ^TMP("PSA",$J,+PSADRUG),PSA,PSADRUG
62QUIT Q
63HEADER I $E(IOST,1,2)'="P-",PSAPG S DIR(0)="E" D ^DIR K DIR I 'Y S PSAOUT=1 Q
64 I $$S^%ZTLOAD S PSAOUT=1 Q
65 W:$Y @IOF S $P(PSALN,"-",81)="",PSAPG=PSAPG+1 W !,?2,"DAILY DISPENSING TOTALS FOR ",$E($P($G(^PSDRUG(+PSADRUG,0)),U),1,30),?70,"PAGE: ",PSAPG,!,PSALN,!
66 W " DATE",?23,"TOTAL",?45,"$/DISP",?67,"TOTAL",!
67 W "DISPENSED",?23,"DISP",?46,"UNIT",?68,"COST",!,PSALN
68 Q
69LOOP S PSA(2)=0 F S PSA(2)=$O(^TMP("PSA",$J,+PSADRUG,PSA(2))) Q:'PSA(2) S PSA(3)=$P(^TMP("PSA",$J,+PSADRUG,PSA(2)),"^") D
70 .;PSA*3*25 Dave B - Remove single reference for OP site
71 .S PSA=^TMP("PSA",$J,+PSADRUG,PSA(2)),PSAOP=+$P($G(^PSD(58.8,PSALOC,0)),"^",10),PSARELDT=+$P(PSA(2),".")
72 .K:$D(^XTMP("PSA",PSAOP,PSADRUG,PSARELDT)) ^XTMP("PSA",PSAOP,PSADRUG,PSARELDT)
73 .D ^PSAOP1
74 .S DIE="^PSD(58.8,"_+PSALOC_",1,",DA(1)=PSALOC,DA=PSADRUG
75 .S DR="22////"_$P(PSA,U,2)_";22.1////"_$P(PSA,U,3)_";23////"_$P(PSA,U,4)_";23.1////"_$P(PSA,U,5)_";22.2////"_$P(PSA,U,6)_";22.3////"_$P(PSA,U,7)_";23.2////"_$P(PSA,U,8)_";23.3////"_$P(PSA,U,9)
76 .D ^DIE K DA,DIE,DR
77 Q
Note: See TracBrowser for help on using the repository browser.