PSADJ ;BIR/LTL,JMB-Balance Adjustments ;8/21/97
;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**3,12,64**; 10/24/97;Build 4
;This routine allows the user to review the drug history then enter
;adjustments.
;
;References to ^PSDRUG( are covered by IA #2095
;
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."
S DIR("??")="^D ADJ^PSADJ" D ^DIR K DIR G:$D(DIRUT) EXIT D:Y=1 ^PSADJR G:$G(DTOUT)!($G(DUOUT)) EXIT
D SIG^XUSESIG G:X1="" EXIT
LOC ;Gets locations to have adjustments
S (PSACNT,PSAOUT)=0 D ^PSAUTL3 G:PSAOUT EXIT
S PSACNT=0,PSACHK=$O(PSALOC(""))
I PSACHK="",'PSALOC W !,"There are no active pharmacy locations." G EXIT
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
.D SITES^PSAUTL1,DRUG
.I PSAOUT S PSAX=$O(PSALOC(PSALOCN)) I PSAX'="" S PSAOUT=0
.K PSAX
;
EXIT ;Kills all variables
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
K PSALOC,PSALOCA,PSALOCN,PSAOUT,PSAQ,PSAR,PSAREC,PSASEL,PSAT,X,X1,X2,Y,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
Q
;
DRUG ;Selects location's drug and processes adjustment
F S DIC="^PSD(58.8,PSALOC,1,",DIC(0)="AEMQZ",DIC("A")="Select drug to adjust: " D Q:PSAOUT
.S DIC("S")="I $S($P($G(^(0)),""^"",14):$P($G(^(0)),""^"",14)>DT,1:1)",DA(1)=PSALOC
.W !!,PSALOCN D ^DIC K DIC I (Y<0&(X="")!(X="^"))!($G(DTOUT))!($G(DUOUT)) S PSAOUT=1 Q
.Q:Y<0&(X'="")
.S PSADRUG=+Y,PSADRUGN=$P($G(^PSDRUG(PSADRUG,0)),"^")
.S PSAQ=$P($G(^PSD(58.8,PSALOC,1,PSADRUG,0)),"^",4)
.W !!,"Current Balance: ",$G(PSAQ),!
.S DIR(0)="NO^-999999:999999:2" S DIR("A")="Adjustment quantity"
.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"
.D ^DIR K DIR Q:Y=0!(Y="")!($G(DUOUT)) I $G(DTOUT) S PSAOUT=1 Q
.S PSAREC=Y
.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
.Q:$G(DUOUT)!(Y=" ") I $G(DTOUT) S PSAOUT=1 Q
.S PSAR=Y,Y=DT D DD^%DT S PSADJDT=Y
.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"
.D ^DIR K DIR Q:$G(DUOUT) I $G(DTOUT) S PSAOUT=1 Q
.S PSADJDT=Y
POST .;Post adjustment if yes.
.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."
.S DIR("??")="^D OK^PSADJ" D ^DIR K DIR
.I 'Y!($G(DIRUT)) S:$G(DTOUT) PSAOUT=1 W ! Q
.D:Y=1 K PSADRUG Q
..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."
..W !,"Updating files. Please wait."
..F L +^PSD(58.8,PSALOC,1,PSADRUG,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
..D NOW^%DTC S PSADT=+$E(%,1,12)
..S PSAQ=$S($P($G(^PSD(58.8,PSALOC,1,PSADRUG,0)),"^",4):$P($G(^(0)),"^",4),1:0)
..S $P(^PSD(58.8,PSALOC,1,PSADRUG,0),"^",4)=PSAREC+PSAQ
..L -^PSD(58.8,PSALOC,1,PSADRUG,0) W "."
MON ..S:'$D(^PSD(58.8,PSALOC,1,PSADRUG,5,0)) ^(0)="^58.801A^^"
..I '$D(^PSD(58.8,PSALOC,1,PSADRUG,5,$E(PSADJDT,1,5)*100,0)) D
...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
...S DA(2)=PSALOC,DA(1)=PSADRUG,DLAYGO=58.8 D ^DIC K DIC,DLAYGO,DD,DO
...;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
...;S DIE="^PSD(58.8,"_PSALOC_",1,"_PSADRUG_",5,",DA(2)=PSALOC,DA(1)=PSADRUG,DR="3////^S X=PSAQ" D ^DIE K DIE
..;DAVE B (PSA*3*12)
..D PSA12
..S DIE="^PSD(58.8,"_PSALOC_",1,"_PSADRUG_",5,",DA(2)=PSALOC,DA(1)=PSADRUG,DA=$E(PSADJDT,1,5)*100
..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)
..D ^DIE W "."
TR ..F L +^PSD(58.81,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
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
..L -^PSD(58.81,0) K DD,DIC,DO W "."
..S DIC="^PSD(58.81,",DIC(0)="L",DLAYGO=58.81,X=PSAT D ^DIC K DIC,DLAYGO W "."
..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:"")
..S DIE="^PSD(58.81,",DA=PSAT D ^DIE K DIE,DD,DO W "."
..S:'$D(^PSD(58.8,PSALOC,1,PSADRUG,4,0)) ^(0)="^58.800119PA^^"
..S DIC="^PSD(58.8,PSALOC,1,PSADRUG,4,",DIC(0)="L",(X,DINUM)=PSAT
..S DA(2)=PSALOC,DA(1)=PSADRUG,DLAYGO=58.8 D ^DIC K DIC,DLAYGO,DA,PSADRUG W ".",!
Q
;
ADJ ;Extended help for "Review drug adjustment history" at PSADJ+2
W !,"Enter yes to print all adjustments for this drug on the screen",!,"or printer. You can enter an adjustment after the report prints."
W !!,"Enter no to bypass the report and make an adjustment."
Q
ADJDATE ;Extended help for "Adjustment date"
W !,"If the adjustment pertains today, press the Return key.",!!,"If the adjustment is for a previous date, enter that date."
W !,"Today's date will be recorded as the date the adjustment was made."
Q
OK ;Extended help for "OK to post?"
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"
W !,"in the activity log and the monthly balance will be adjusted.",!!,"Enter no to abort the adjustment process and return to the menu."
Q
QTY ;Extended help for "Adjustment quantity"
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"
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."
Q
REASON ;Extended help for "Adjustment reason"
W !,"Enter the reason you are changing the current balance."
Q
;
PSA12 ;Patch PSA*3*12
I $E(PSADJDT,1,5)=$E(DT,1,5) Q
;This section was added to CORRECTLY make adjustments to
;the monthly activity balances when an adjustment was made.
S X="T" D ^%DT S PSAENDDT=$E(Y,1,5)
S PSADJDT1=$E(PSADJDT,1,5)
BGN S PSADJDT1=PSADJDT1+1
S PSADAV=$E(PSADJDT1,4,5) I PSADAV=13 S PSADAV1=$E(PSADJDT1,1,3)+1,PSADAV2="01",PSADJDT1=PSADAV1_PSADAV2
I PSADJDT1=PSAENDDT G DONE
W !,"Updating " S Y=PSADJDT1 X ^DD("DD") W Y
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
S DA=$S($G(DA)="":(PSADJDT1*100),1:DA)
S DIE="^PSD(58.8,"_PSALOC_",1,"_PSADRUG_",5,",DA(2)=PSALOC,DA(1)=PSADRUG
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)
D ^DIE
K DA G BGN
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
S ^PSD(58.8,PSALOC,1,PSADRUG,5,"B",($E(PSADT,1,5)*100),($E(PSADT,1,5)*100))=""
W !,"DONE" Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSADJ 7629 printed Dec 13, 2024@01:49:09 Page 2
PSADJ ;BIR/LTL,JMB-Balance Adjustments ;8/21/97
+1 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**3,12,64**; 10/24/97;Build 4
+2 ;This routine allows the user to review the drug history then enter
+3 ;adjustments.
+4 ;
+5 ;References to ^PSDRUG( are covered by IA #2095
+6 ;
+7 SET DIR(0)="Y"
SET DIR("A")="Review drug adjustment history"
SET DIR("B")="No"
SET DIR("?",1)="Enter yes to display all adjustments within a selected date range."
SET DIR("?")="Enter no to enter the adjustment."
+8 SET DIR("??")="^D ADJ^PSADJ"
DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO EXIT
if Y=1
DO ^PSADJR
if $GET(DTOUT)!($GET(DUOUT))
GOTO EXIT
+9 DO SIG^XUSESIG
if X1=""
GOTO EXIT
LOC ;Gets locations to have adjustments
+1 SET (PSACNT,PSAOUT)=0
DO ^PSAUTL3
if PSAOUT
GOTO EXIT
+2 SET PSACNT=0
SET PSACHK=$ORDER(PSALOC(""))
+3 IF PSACHK=""
IF 'PSALOC
WRITE !,"There are no active pharmacy locations."
GOTO EXIT
+4 SET PSALOCN=""
FOR
SET PSALOCN=$ORDER(PSALOC(PSALOCN))
if PSALOCN=""
QUIT
SET PSALOC=0
FOR
SET PSALOC=+$ORDER(PSALOC(PSALOCN,PSALOC))
if 'PSALOC
QUIT
Begin DoDot:1
+5 DO SITES^PSAUTL1
DO DRUG
+6 IF PSAOUT
SET PSAX=$ORDER(PSALOC(PSALOCN))
IF PSAX'=""
SET PSAOUT=0
+7 KILL PSAX
End DoDot:1
if PSAOUT
QUIT
+8 ;
EXIT ;Kills all variables
+1 KILL %,%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
+2 KILL PSALOC,PSALOCA,PSALOCN,PSAOUT,PSAQ,PSAR,PSAREC,PSASEL,PSAT,X,X1,X2,Y,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
+3 QUIT
+4 ;
DRUG ;Selects location's drug and processes adjustment
+1 FOR
SET DIC="^PSD(58.8,PSALOC,1,"
SET DIC(0)="AEMQZ"
SET DIC("A")="Select drug to adjust: "
Begin DoDot:1
+2 SET DIC("S")="I $S($P($G(^(0)),""^"",14):$P($G(^(0)),""^"",14)>DT,1:1)"
SET DA(1)=PSALOC
+3 WRITE !!,PSALOCN
DO ^DIC
KILL DIC
IF (Y<0&(X="")!(X="^"))!($GET(DTOUT))!($GET(DUOUT))
SET PSAOUT=1
QUIT
+4 if Y<0&(X'="")
QUIT
+5 SET PSADRUG=+Y
SET PSADRUGN=$PIECE($GET(^PSDRUG(PSADRUG,0)),"^")
+6 SET PSAQ=$PIECE($GET(^PSD(58.8,PSALOC,1,PSADRUG,0)),"^",4)
+7 WRITE !!,"Current Balance: ",$GET(PSAQ),!
+8 SET DIR(0)="NO^-999999:999999:2"
SET DIR("A")="Adjustment quantity"
+9 SET DIR("?",1)="Enter the amount of the adjustment. If it is a negative"
SET DIR("?")="number, enter a minus sign '-' before the number."
SET DIR("??")="^D QTY^PSADJ"
+10 DO ^DIR
KILL DIR
if Y=0!(Y="")!($GET(DUOUT))
QUIT
IF $GET(DTOUT)
SET PSAOUT=1
QUIT
+11 SET PSAREC=Y
+12 SET DIR(0)="F^1:45"
SET DIR("A")="Adjustment reason"
SET DIR("?")="Enter the reason why the adjustment was made"
SET DIR("??")="^D REASON^PSADJ"
DO ^DIR
KILL DIR
+13 if $GET(DUOUT)!(Y=" ")
QUIT
IF $GET(DTOUT)
SET PSAOUT=1
QUIT
+14 SET PSAR=Y
SET Y=DT
DO DD^%DT
SET PSADJDT=Y
+15 SET DIR(0)="D^:"_DT_":EX"
SET DIR("A")="Adjustment date"
SET DIR("B")=PSADJDT
SET DIR("?")="Enter the date that the adjustment applies"
SET DIR("??")="^D ADJDATE^PSADJ"
+16 DO ^DIR
KILL DIR
if $GET(DUOUT)
QUIT
IF $GET(DTOUT)
SET PSAOUT=1
QUIT
+17 SET PSADJDT=Y
POST ;Post adjustment if yes.
+1 SET DIR(0)="Y"
SET DIR("A")="OK to post"
SET DIR("B")="Yes"
SET DIR("?",1)="Enter yes to add or subtract the adjustment quantity from the current"
SET DIR("?")="balance and record this transaction. Enter no to cancel this transaction."
+2 SET DIR("??")="^D OK^PSADJ"
DO ^DIR
KILL DIR
+3 IF 'Y!($GET(DIRUT))
if $GET(DTOUT)
SET PSAOUT=1
WRITE !
QUIT
+4 if Y=1
Begin DoDot:2
+5 WRITE !,"There were ",$SELECT($PIECE($GET(^PSD(58.8,PSALOC,1,PSADRUG,0)),"^",4):$PIECE($GET(^(0)),"^",4),1:0)," on hand. There are now ",$PIECE($GET(^(0)),"^",4)+$GET(PSAREC)," on hand."
+6 WRITE !,"Updating files. Please wait."
+7 FOR
LOCK +^PSD(58.8,PSALOC,1,PSADRUG,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
IF $TEST
QUIT
+8 DO NOW^%DTC
SET PSADT=+$EXTRACT(%,1,12)
+9 SET PSAQ=$SELECT($PIECE($GET(^PSD(58.8,PSALOC,1,PSADRUG,0)),"^",4):$PIECE($GET(^(0)),"^",4),1:0)
+10 SET $PIECE(^PSD(58.8,PSALOC,1,PSADRUG,0),"^",4)=PSAREC+PSAQ
+11 LOCK -^PSD(58.8,PSALOC,1,PSADRUG,0)
WRITE "."
MON if '$DATA(^PSD(58.8,PSALOC,1,PSADRUG,5,0))
SET ^(0)="^58.801A^^"
+1 IF '$DATA(^PSD(58.8,PSALOC,1,PSADRUG,5,$EXTRACT(PSADJDT,1,5)*100,0))
Begin DoDot:3
+2 KILL DD,DO
SET DIC="^PSD(58.8,"_PSALOC_",1,"_PSADRUG_",5,"
SET DIC(0)="L"
SET DIC("DR")="1////^S X=PSAQ"
SET (X,DINUM)=$EXTRACT(PSADJDT,1,5)*100
+3 SET DA(2)=PSALOC
SET DA(1)=PSADRUG
SET DLAYGO=58.8
DO ^DIC
KILL DIC,DLAYGO,DD,DO
+4 ;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
+5 ;S DIE="^PSD(58.8,"_PSALOC_",1,"_PSADRUG_",5,",DA(2)=PSALOC,DA(1)=PSADRUG,DR="3////^S X=PSAQ" D ^DIE K DIE
End DoDot:3
+6 ;DAVE B (PSA*3*12)
+7 DO PSA12
+8 SET DIE="^PSD(58.8,"_PSALOC_",1,"_PSADRUG_",5,"
SET DA(2)=PSALOC
SET DA(1)=PSADRUG
SET DA=$EXTRACT(PSADJDT,1,5)*100
+9 SET DR="7////^S X="_($PIECE($GET(^PSD(58.8,PSALOC,1,PSADRUG,5,DA,0)),"^",5)+PSAREC)_";3////^S X="_($PIECE($GET(^(0)),"^",4)+PSAREC)
+10 DO ^DIE
WRITE "."
TR FOR
LOCK +^PSD(58.81,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
IF $TEST
QUIT
FIND SET PSAT=$PIECE(^PSD(58.81,0),"^",3)+1
IF $DATA(^PSD(58.81,PSAT,0))
SET $PIECE(^(0),"^",3)=$PIECE(^(0),"^",3)+1
GOTO FIND
+1 LOCK -^PSD(58.81,0)
KILL DD,DIC,DO
WRITE "."
+2 SET DIC="^PSD(58.81,"
SET DIC(0)="L"
SET DLAYGO=58.81
SET X=PSAT
DO ^DIC
KILL DIC,DLAYGO
WRITE "."
+3 SET DR="1////9;2////^S X=PSALOC;3////^S X="_$SELECT(PSADJDT=$EXTRACT(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"_$SELECT(PSADJDT'=$EXTRACT(PSADT,1,7):";22////^S
X="_PSADT,1:"")
+4 SET DIE="^PSD(58.81,"
SET DA=PSAT
DO ^DIE
KILL DIE,DD,DO
WRITE "."
+5 if '$DATA(^PSD(58.8,PSALOC,1,PSADRUG,4,0))
SET ^(0)="^58.800119PA^^"
+6 SET DIC="^PSD(58.8,PSALOC,1,PSADRUG,4,"
SET DIC(0)="L"
SET (X,DINUM)=PSAT
+7 SET DA(2)=PSALOC
SET DA(1)=PSADRUG
SET DLAYGO=58.8
DO ^DIC
KILL DIC,DLAYGO,DA,PSADRUG
WRITE ".",!
End DoDot:2
KILL PSADRUG
QUIT
End DoDot:1
if PSAOUT
QUIT
+8 QUIT
+9 ;
ADJ ;Extended help for "Review drug adjustment history" at PSADJ+2
+1 WRITE !,"Enter yes to print all adjustments for this drug on the screen",!,"or printer. You can enter an adjustment after the report prints."
+2 WRITE !!,"Enter no to bypass the report and make an adjustment."
+3 QUIT
ADJDATE ;Extended help for "Adjustment date"
+1 WRITE !,"If the adjustment pertains today, press the Return key.",!!,"If the adjustment is for a previous date, enter that date."
+2 WRITE !,"Today's date will be recorded as the date the adjustment was made."
+3 QUIT
OK ;Extended help for "OK to post?"
+1 WRITE !,"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"
+2 WRITE !,"in the activity log and the monthly balance will be adjusted.",!!,"Enter no to abort the adjustment process and return to the menu."
+3 QUIT
QTY ;Extended help for "Adjustment quantity"
+1 WRITE !,"Enter the quantity to be added or subtracted from the current balance.",!,"If the quantity should be subtracted from the balance, enter a minus"
+2 WRITE !,"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."
+3 QUIT
REASON ;Extended help for "Adjustment reason"
+1 WRITE !,"Enter the reason you are changing the current balance."
+2 QUIT
+3 ;
PSA12 ;Patch PSA*3*12
+1 IF $EXTRACT(PSADJDT,1,5)=$EXTRACT(DT,1,5)
QUIT
+2 ;This section was added to CORRECTLY make adjustments to
+3 ;the monthly activity balances when an adjustment was made.
+4 SET X="T"
DO ^%DT
SET PSAENDDT=$EXTRACT(Y,1,5)
+5 SET PSADJDT1=$EXTRACT(PSADJDT,1,5)
BGN SET PSADJDT1=PSADJDT1+1
+1 SET PSADAV=$EXTRACT(PSADJDT1,4,5)
IF PSADAV=13
SET PSADAV1=$EXTRACT(PSADJDT1,1,3)+1
SET PSADAV2="01"
SET PSADJDT1=PSADAV1_PSADAV2
+2 IF PSADJDT1=PSAENDDT
GOTO DONE
+3 WRITE !,"Updating "
SET Y=PSADJDT1
XECUTE ^DD("DD")
WRITE Y
+4 IF '$DATA(^PSD(58.8,PSALOC,1,PSADRUG,5,(PSADJDT1*100),0))
SET DIC="^PSD(58.8,"_PSALOC_",1,"_PSADRUG_",5,"
SET DIC(0)="L"
SET (X,DINUM)=$EXTRACT(PSADJDT1,1,5)*100
SET DA(2)=PSALOC
SET DA(1)=PSADRUG
SET DLAYGO=58.8
DO ^DIC
SET DA=+Y
+5 SET DA=$SELECT($GET(DA)="":(PSADJDT1*100),1:DA)
+6 SET DIE="^PSD(58.8,"_PSALOC_",1,"_PSADRUG_",5,"
SET DA(2)=PSALOC
SET DA(1)=PSADRUG
+7 SET DR="1////^S X="_($PIECE($GET(^PSD(58.8,PSALOC,1,PSADRUG,5,DA,0)),"^",2)+PSAREC)_";3////^S X="_($PIECE($GET(^(0)),"^",4)+PSAREC)
+8 DO ^DIE
+9 KILL DA
GOTO BGN
DONE SET $PIECE(^PSD(58.8,PSALOC,1,PSADRUG,5,($EXTRACT(PSADT,1,5)*100),0),"^",2)=$PIECE($GET(^PSD(58.8,PSALOC,1,PSADRUG,5,($EXTRACT(PSADT,1,5)*100),0)),"^",2)+PSAREC
+1 SET ^PSD(58.8,PSALOC,1,PSADRUG,5,"B",($EXTRACT(PSADT,1,5)*100),($EXTRACT(PSADT,1,5)*100))=""
+2 WRITE !,"DONE"
QUIT
