- 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 Jan 18, 2025@02:50:22 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