source: FOIAVistA/trunk/r/DRUG_ACCOUNTABILITY-PSA/PSADJ.m@ 1203

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

initial load of FOIAVistA 6/30/08 version
File size: 7.3 KB
Line 
1PSADJ ;BIR/LTL,JMB-Balance Adjustments ;8/21/97
2 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**3,12,64**; 10/24/97;Build 4
3 ;This routine allows the user to review the drug history then enter
4 ;adjustments.
5 ;
6 ;References to ^PSDRUG( are covered by IA #2095
7 ;
8 S DIR(0)="Y",DIR("A")="Review drug adjustment history",DIR("B")="No",DIR("?",1)="Enter yes to display all adjustments within a selected date range.",DIR("?")="Enter no to enter the adjustment."
9 S DIR("??")="^D ADJ^PSADJ" D ^DIR K DIR G:$D(DIRUT) EXIT D:Y=1 ^PSADJR G:$G(DTOUT)!($G(DUOUT)) EXIT
10 D SIG^XUSESIG G:X1="" EXIT
11LOC ;Gets locations to have adjustments
12 S (PSACNT,PSAOUT)=0 D ^PSAUTL3 G:PSAOUT EXIT
13 S PSACNT=0,PSACHK=$O(PSALOC(""))
14 I PSACHK="",'PSALOC W !,"There are no active pharmacy locations." G EXIT
15 S PSALOCN="" F S PSALOCN=$O(PSALOC(PSALOCN)) Q:PSALOCN="" S PSALOC=0 F S PSALOC=+$O(PSALOC(PSALOCN,PSALOC)) Q:'PSALOC D Q:PSAOUT
16 .D SITES^PSAUTL1,DRUG
17 .I PSAOUT S PSAX=$O(PSALOC(PSALOCN)) I PSAX'="" S PSAOUT=0
18 .K PSAX
19 ;
20EXIT ;Kills all variables
21 K %,%DT,%ZIS,D0,D1,DA,DD,DIC,DIE,DINUM,DIR,DIRUT,DO,DR,DTOUT,DUOUT,PSA,PSACHK,PSACNT,PSACOMB,PSADJDT,PSADRUG,PSADRUGN,PSADT,PSAIEN,PSAISIT,PSAISITN
22 K PSALOC,PSALOCA,PSALOCN,PSAOUT,PSAQ,PSAR,PSAREC,PSASEL,PSAT,X,X1,X2,Y,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
23 Q
24 ;
25DRUG ;Selects location's drug and processes adjustment
26 F S DIC="^PSD(58.8,PSALOC,1,",DIC(0)="AEMQZ",DIC("A")="Select drug to adjust: " D Q:PSAOUT
27 .S DIC("S")="I $S($P($G(^(0)),""^"",14):$P($G(^(0)),""^"",14)>DT,1:1)",DA(1)=PSALOC
28 .W !!,PSALOCN D ^DIC K DIC I (Y<0&(X="")!(X="^"))!($G(DTOUT))!($G(DUOUT)) S PSAOUT=1 Q
29 .Q:Y<0&(X'="")
30 .S PSADRUG=+Y,PSADRUGN=$P($G(^PSDRUG(PSADRUG,0)),"^")
31 .S PSAQ=$P($G(^PSD(58.8,PSALOC,1,PSADRUG,0)),"^",4)
32 .W !!,"Current Balance: ",$G(PSAQ),!
33 .S DIR(0)="NO^-999999:999999:2" S DIR("A")="Adjustment quantity"
34 .S DIR("?",1)="Enter the amount of the adjustment. If it is a negative",DIR("?")="number, enter a minus sign '-' before the number.",DIR("??")="^D QTY^PSADJ"
35 .D ^DIR K DIR Q:Y=0!(Y="")!($G(DUOUT)) I $G(DTOUT) S PSAOUT=1 Q
36 .S PSAREC=Y
37 .S DIR(0)="F^1:45",DIR("A")="Adjustment reason",DIR("?")="Enter the reason why the adjustment was made",DIR("??")="^D REASON^PSADJ" D ^DIR K DIR
38 .Q:$G(DUOUT)!(Y=" ") I $G(DTOUT) S PSAOUT=1 Q
39 .S PSAR=Y,Y=DT D DD^%DT S PSADJDT=Y
40 .S DIR(0)="D^:"_DT_":EX",DIR("A")="Adjustment date",DIR("B")=PSADJDT,DIR("?")="Enter the date that the adjustment applies",DIR("??")="^D ADJDATE^PSADJ"
41 .D ^DIR K DIR Q:$G(DUOUT) I $G(DTOUT) S PSAOUT=1 Q
42 .S PSADJDT=Y
43POST .;Post adjustment if yes.
44 .S DIR(0)="Y",DIR("A")="OK to post",DIR("B")="Yes",DIR("?",1)="Enter yes to add or subtract the adjustment quantity from the current",DIR("?")="balance and record this transaction. Enter no to cancel this transaction."
45 .S DIR("??")="^D OK^PSADJ" D ^DIR K DIR
46 .I 'Y!($G(DIRUT)) S:$G(DTOUT) PSAOUT=1 W ! Q
47 .D:Y=1 K PSADRUG Q
48 ..W !,"There were ",$S($P($G(^PSD(58.8,PSALOC,1,PSADRUG,0)),"^",4):$P($G(^(0)),"^",4),1:0)," on hand. There are now ",$P($G(^(0)),"^",4)+$G(PSAREC)," on hand."
49 ..W !,"Updating files. Please wait."
50 ..F L +^PSD(58.8,PSALOC,1,PSADRUG,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
51 ..D NOW^%DTC S PSADT=+$E(%,1,12)
52 ..S PSAQ=$S($P($G(^PSD(58.8,PSALOC,1,PSADRUG,0)),"^",4):$P($G(^(0)),"^",4),1:0)
53 ..S $P(^PSD(58.8,PSALOC,1,PSADRUG,0),"^",4)=PSAREC+PSAQ
54 ..L -^PSD(58.8,PSALOC,1,PSADRUG,0) W "."
55MON ..S:'$D(^PSD(58.8,PSALOC,1,PSADRUG,5,0)) ^(0)="^58.801A^^"
56 ..I '$D(^PSD(58.8,PSALOC,1,PSADRUG,5,$E(PSADJDT,1,5)*100,0)) D
57 ...K DD,DO S DIC="^PSD(58.8,"_PSALOC_",1,"_PSADRUG_",5,",DIC(0)="L",DIC("DR")="1////^S X=PSAQ",(X,DINUM)=$E(PSADJDT,1,5)*100
58 ...S DA(2)=PSALOC,DA(1)=PSADRUG,DLAYGO=58.8 D ^DIC K DIC,DLAYGO,DD,DO
59 ...;S X="T-1M" D ^%DT S DIC="^PSD(58.8,"_PSALOC_",1,"_PSADRUG_",5,",DIC(0)="L",(X,DINUM)=$E(Y,1,5)*100,DA(2)=PSALOC,DA(1)=PSADRUG,DLAYGO=58.8 D ^DIC K DIC,DLAYGO S DA=+Y
60 ...;S DIE="^PSD(58.8,"_PSALOC_",1,"_PSADRUG_",5,",DA(2)=PSALOC,DA(1)=PSADRUG,DR="3////^S X=PSAQ" D ^DIE K DIE
61 ..;DAVE B (PSA*3*12)
62 ..D PSA12
63 ..S DIE="^PSD(58.8,"_PSALOC_",1,"_PSADRUG_",5,",DA(2)=PSALOC,DA(1)=PSADRUG,DA=$E(PSADJDT,1,5)*100
64 ..S DR="7////^S X="_($P($G(^PSD(58.8,PSALOC,1,PSADRUG,5,DA,0)),"^",5)+PSAREC)_";3////^S X="_($P($G(^(0)),"^",4)+PSAREC)
65 ..D ^DIE W "."
66TR ..F L +^PSD(58.81,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
67FIND ..S PSAT=$P(^PSD(58.81,0),"^",3)+1 I $D(^PSD(58.81,PSAT,0)) S $P(^(0),"^",3)=$P(^(0),"^",3)+1 G FIND
68 ..L -^PSD(58.81,0) K DD,DIC,DO W "."
69 ..S DIC="^PSD(58.81,",DIC(0)="L",DLAYGO=58.81,X=PSAT D ^DIC K DIC,DLAYGO W "."
70 ..S DR="1////9;2////^S X=PSALOC;3////^S X="_$S(PSADJDT=$E(PSADT,1,7):PSADT,1:PSADJDT)_";4////^S X=PSADRUG;5////^S X=PSAREC;6////^S X=DUZ;9////^S X=PSAQ;15////^S X=PSAR"_$S(PSADJDT'=$E(PSADT,1,7):";22////^S X="_PSADT,1:"")
71 ..S DIE="^PSD(58.81,",DA=PSAT D ^DIE K DIE,DD,DO W "."
72 ..S:'$D(^PSD(58.8,PSALOC,1,PSADRUG,4,0)) ^(0)="^58.800119PA^^"
73 ..S DIC="^PSD(58.8,PSALOC,1,PSADRUG,4,",DIC(0)="L",(X,DINUM)=PSAT
74 ..S DA(2)=PSALOC,DA(1)=PSADRUG,DLAYGO=58.8 D ^DIC K DIC,DLAYGO,DA,PSADRUG W ".",!
75 Q
76 ;
77ADJ ;Extended help for "Review drug adjustment history" at PSADJ+2
78 W !,"Enter yes to print all adjustments for this drug on the screen",!,"or printer. You can enter an adjustment after the report prints."
79 W !!,"Enter no to bypass the report and make an adjustment."
80 Q
81ADJDATE ;Extended help for "Adjustment date"
82 W !,"If the adjustment pertains today, press the Return key.",!!,"If the adjustment is for a previous date, enter that date."
83 W !,"Today's date will be recorded as the date the adjustment was made."
84 Q
85OK ;Extended help for "OK to post?"
86 W !,"Enter yes to record this adjustment. The adjustment quantity will be subtracted",!,"from or added to the drug's current balance. The transaction will be recorded"
87 W !,"in the activity log and the monthly balance will be adjusted.",!!,"Enter no to abort the adjustment process and return to the menu."
88 Q
89QTY ;Extended help for "Adjustment quantity"
90 W !,"Enter the quantity to be added or subtracted from the current balance.",!,"If the quantity should be subtracted from the balance, enter a minus"
91 W !,"sign '-' before the quantity.",!!,"For example: -10 or -150 will be subtracted from the balance.",!?14,"10 or 150 will be added to the balance."
92 Q
93REASON ;Extended help for "Adjustment reason"
94 W !,"Enter the reason you are changing the current balance."
95 Q
96 ;
97PSA12 ;Patch PSA*3*12
98 I $E(PSADJDT,1,5)=$E(DT,1,5) Q
99 ;This section was added to CORRECTLY make adjustments to
100 ;the monthly activity balances when an adjustment was made.
101 S X="T" D ^%DT S PSAENDDT=$E(Y,1,5)
102 S PSADJDT1=$E(PSADJDT,1,5)
103BGN S PSADJDT1=PSADJDT1+1
104 S PSADAV=$E(PSADJDT1,4,5) I PSADAV=13 S PSADAV1=$E(PSADJDT1,1,3)+1,PSADAV2="01",PSADJDT1=PSADAV1_PSADAV2
105 I PSADJDT1=PSAENDDT G DONE
106 W !,"Updating " S Y=PSADJDT1 X ^DD("DD") W Y
107 I '$D(^PSD(58.8,PSALOC,1,PSADRUG,5,(PSADJDT1*100),0)) S DIC="^PSD(58.8,"_PSALOC_",1,"_PSADRUG_",5,",DIC(0)="L",(X,DINUM)=$E(PSADJDT1,1,5)*100,DA(2)=PSALOC,DA(1)=PSADRUG,DLAYGO=58.8 D ^DIC S DA=+Y
108 S DA=$S($G(DA)="":(PSADJDT1*100),1:DA)
109 S DIE="^PSD(58.8,"_PSALOC_",1,"_PSADRUG_",5,",DA(2)=PSALOC,DA(1)=PSADRUG
110 S DR="1////^S X="_($P($G(^PSD(58.8,PSALOC,1,PSADRUG,5,DA,0)),"^",2)+PSAREC)_";3////^S X="_($P($G(^(0)),"^",4)+PSAREC)
111 D ^DIE
112 K DA G BGN
113DONE S $P(^PSD(58.8,PSALOC,1,PSADRUG,5,($E(PSADT,1,5)*100),0),"^",2)=$P($G(^PSD(58.8,PSALOC,1,PSADRUG,5,($E(PSADT,1,5)*100),0)),"^",2)+PSAREC
114 S ^PSD(58.8,PSALOC,1,PSADRUG,5,"B",($E(PSADT,1,5)*100),($E(PSADT,1,5)*100))=""
115 W !,"DONE" Q
Note: See TracBrowser for help on using the repository browser.