Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSADJ

PSADJ.m

Go to the documentation of this file.
  1. PSADJ ;BIR/LTL,JMB-Balance Adjustments ;8/21/97
  1. ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**3,12,64**; 10/24/97;Build 4
  1. ;This routine allows the user to review the drug history then enter
  1. ;adjustments.
  1. ;
  1. ;References to ^PSDRUG( are covered by IA #2095
  1. ;
  1. 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."
  1. S DIR("??")="^D ADJ^PSADJ" D ^DIR K DIR G:$D(DIRUT) EXIT D:Y=1 ^PSADJR G:$G(DTOUT)!($G(DUOUT)) EXIT
  1. D SIG^XUSESIG G:X1="" EXIT
  1. LOC ;Gets locations to have adjustments
  1. S (PSACNT,PSAOUT)=0 D ^PSAUTL3 G:PSAOUT EXIT
  1. S PSACNT=0,PSACHK=$O(PSALOC(""))
  1. I PSACHK="",'PSALOC W !,"There are no active pharmacy locations." G EXIT
  1. 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
  1. .D SITES^PSAUTL1,DRUG
  1. .I PSAOUT S PSAX=$O(PSALOC(PSALOCN)) I PSAX'="" S PSAOUT=0
  1. .K PSAX
  1. ;
  1. EXIT ;Kills all variables
  1. 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
  1. K PSALOC,PSALOCA,PSALOCN,PSAOUT,PSAQ,PSAR,PSAREC,PSASEL,PSAT,X,X1,X2,Y,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
  1. Q
  1. ;
  1. DRUG ;Selects location's drug and processes adjustment
  1. F S DIC="^PSD(58.8,PSALOC,1,",DIC(0)="AEMQZ",DIC("A")="Select drug to adjust: " D Q:PSAOUT
  1. .S DIC("S")="I $S($P($G(^(0)),""^"",14):$P($G(^(0)),""^"",14)>DT,1:1)",DA(1)=PSALOC
  1. .W !!,PSALOCN D ^DIC K DIC I (Y<0&(X="")!(X="^"))!($G(DTOUT))!($G(DUOUT)) S PSAOUT=1 Q
  1. .Q:Y<0&(X'="")
  1. .S PSADRUG=+Y,PSADRUGN=$P($G(^PSDRUG(PSADRUG,0)),"^")
  1. .S PSAQ=$P($G(^PSD(58.8,PSALOC,1,PSADRUG,0)),"^",4)
  1. .W !!,"Current Balance: ",$G(PSAQ),!
  1. .S DIR(0)="NO^-999999:999999:2" S DIR("A")="Adjustment quantity"
  1. .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"
  1. .D ^DIR K DIR Q:Y=0!(Y="")!($G(DUOUT)) I $G(DTOUT) S PSAOUT=1 Q
  1. .S PSAREC=Y
  1. .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
  1. .Q:$G(DUOUT)!(Y=" ") I $G(DTOUT) S PSAOUT=1 Q
  1. .S PSAR=Y,Y=DT D DD^%DT S PSADJDT=Y
  1. .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"
  1. .D ^DIR K DIR Q:$G(DUOUT) I $G(DTOUT) S PSAOUT=1 Q
  1. .S PSADJDT=Y
  1. POST .;Post adjustment if yes.
  1. .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."
  1. .S DIR("??")="^D OK^PSADJ" D ^DIR K DIR
  1. .I 'Y!($G(DIRUT)) S:$G(DTOUT) PSAOUT=1 W ! Q
  1. .D:Y=1 K PSADRUG Q
  1. ..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."
  1. ..W !,"Updating files. Please wait."
  1. ..F L +^PSD(58.8,PSALOC,1,PSADRUG,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
  1. ..D NOW^%DTC S PSADT=+$E(%,1,12)
  1. ..S PSAQ=$S($P($G(^PSD(58.8,PSALOC,1,PSADRUG,0)),"^",4):$P($G(^(0)),"^",4),1:0)
  1. ..S $P(^PSD(58.8,PSALOC,1,PSADRUG,0),"^",4)=PSAREC+PSAQ
  1. ..L -^PSD(58.8,PSALOC,1,PSADRUG,0) W "."
  1. MON ..S:'$D(^PSD(58.8,PSALOC,1,PSADRUG,5,0)) ^(0)="^58.801A^^"
  1. ..I '$D(^PSD(58.8,PSALOC,1,PSADRUG,5,$E(PSADJDT,1,5)*100,0)) D
  1. ...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
  1. ...S DA(2)=PSALOC,DA(1)=PSADRUG,DLAYGO=58.8 D ^DIC K DIC,DLAYGO,DD,DO
  1. ...;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
  1. ...;S DIE="^PSD(58.8,"_PSALOC_",1,"_PSADRUG_",5,",DA(2)=PSALOC,DA(1)=PSADRUG,DR="3////^S X=PSAQ" D ^DIE K DIE
  1. ..;DAVE B (PSA*3*12)
  1. ..D PSA12
  1. ..S DIE="^PSD(58.8,"_PSALOC_",1,"_PSADRUG_",5,",DA(2)=PSALOC,DA(1)=PSADRUG,DA=$E(PSADJDT,1,5)*100
  1. ..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)
  1. ..D ^DIE W "."
  1. TR ..F L +^PSD(58.81,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
  1. FIND ..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
  1. ..L -^PSD(58.81,0) K DD,DIC,DO W "."
  1. ..S DIC="^PSD(58.81,",DIC(0)="L",DLAYGO=58.81,X=PSAT D ^DIC K DIC,DLAYGO W "."
  1. ..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:"")
  1. ..S DIE="^PSD(58.81,",DA=PSAT D ^DIE K DIE,DD,DO W "."
  1. ..S:'$D(^PSD(58.8,PSALOC,1,PSADRUG,4,0)) ^(0)="^58.800119PA^^"
  1. ..S DIC="^PSD(58.8,PSALOC,1,PSADRUG,4,",DIC(0)="L",(X,DINUM)=PSAT
  1. ..S DA(2)=PSALOC,DA(1)=PSADRUG,DLAYGO=58.8 D ^DIC K DIC,DLAYGO,DA,PSADRUG W ".",!
  1. Q
  1. ;
  1. ADJ ;Extended help for "Review drug adjustment history" at PSADJ+2
  1. W !,"Enter yes to print all adjustments for this drug on the screen",!,"or printer. You can enter an adjustment after the report prints."
  1. W !!,"Enter no to bypass the report and make an adjustment."
  1. Q
  1. ADJDATE ;Extended help for "Adjustment date"
  1. W !,"If the adjustment pertains today, press the Return key.",!!,"If the adjustment is for a previous date, enter that date."
  1. W !,"Today's date will be recorded as the date the adjustment was made."
  1. Q
  1. OK ;Extended help for "OK to post?"
  1. 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"
  1. W !,"in the activity log and the monthly balance will be adjusted.",!!,"Enter no to abort the adjustment process and return to the menu."
  1. Q
  1. QTY ;Extended help for "Adjustment quantity"
  1. 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"
  1. 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."
  1. Q
  1. REASON ;Extended help for "Adjustment reason"
  1. W !,"Enter the reason you are changing the current balance."
  1. Q
  1. ;
  1. PSA12 ;Patch PSA*3*12
  1. I $E(PSADJDT,1,5)=$E(DT,1,5) Q
  1. ;This section was added to CORRECTLY make adjustments to
  1. ;the monthly activity balances when an adjustment was made.
  1. S X="T" D ^%DT S PSAENDDT=$E(Y,1,5)
  1. S PSADJDT1=$E(PSADJDT,1,5)
  1. BGN S PSADJDT1=PSADJDT1+1
  1. S PSADAV=$E(PSADJDT1,4,5) I PSADAV=13 S PSADAV1=$E(PSADJDT1,1,3)+1,PSADAV2="01",PSADJDT1=PSADAV1_PSADAV2
  1. I PSADJDT1=PSAENDDT G DONE
  1. W !,"Updating " S Y=PSADJDT1 X ^DD("DD") W Y
  1. 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
  1. S DA=$S($G(DA)="":(PSADJDT1*100),1:DA)
  1. S DIE="^PSD(58.8,"_PSALOC_",1,"_PSADRUG_",5,",DA(2)=PSALOC,DA(1)=PSADRUG
  1. 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)
  1. D ^DIE
  1. K DA G BGN
  1. DONE 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
  1. S ^PSD(58.8,PSALOC,1,PSADRUG,5,"B",($E(PSADT,1,5)*100),($E(PSADT,1,5)*100))=""
  1. W !,"DONE" Q