PSADJR ;BIR/LTL,JMB-Balance Adjustments History ;8/21/97
;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**15**; 10/24/97
;This routine reviews adjustment transactions for drugs.
;
;References to ^PSDRUG( are covered by IA #2095
;
LOOK ;Get locations to display
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
I '$O(^PSD(58.8,PSALOC,1,0)) W !!,"There are no drugs in ",PSALOCN S PSAOUT=1 G EXIT
S DIC="^PSD(58.8,PSALOC,1,",DIC(0)="AEMQZ",DIC("A")="Select drug for history: ",DA(1)=PSALOC,DIC("W")="I $S($P($G(^(0)),U,14):$P($G(^(0)),U,14)'>DT,1:0) W $C(7),"" ***INACTIVE ***""" W !
D ^DIC K DIC S PSA=+Y I PSA<0 S PSAOUT=1 G EXIT
I '$O(^PSD(58.81,"F",+Y,"")) W !!,"There have been no adjustments for this drug.",!! S PSAOUT=1 G EXIT
W ! S DIR(0)="D:AEP",DIR("A")="How far back in time do you want to go: ",DIR("B")="T-6M" D ^DIR K DIR I $D(DIRUT) S PSAOUT=1 G EXIT
S PSAT=Y
DEV ;asks device and queueing info
K IO("Q") N %ZIS,IOP,POP S %ZIS="Q" D ^%ZIS I POP W !,"NO DEVICE SELECTED OR OUTPUT PRINTED!" S PSAOUT=1 G EXIT
I $D(IO("Q")) N ZTDESC,ZTIO,ZTRTN,ZTSAVE,ZTDTH,ZTSK S ZTRTN="START^PSADJR",ZTDESC="Drug Acct. - Drug adjustment review",ZTSAVE("PSA*")="" D ^%ZTLOAD,HOME^%ZIS S PSAOUT=1 G EXIT
START ;compiles and prints output
D SITES^PSAUTL1 S PSALOCN=$P(^PSD(58.8,PSALOC,0),"^")_PSACOMB
S PSADRG=$P($G(^PSDRUG(PSA,0)),"^"),PSATAB=(80-$L(PSADRG))/2
N %DT,PSASLN,PSAPG,PSAOUT,PSARPDT S (PSAPG,PSAOUT)=0,$P(PSASLN,"-",81)="",Y=DT D DD^%DT S PSARPDT=Y,PSAR=0 D HEADER
LOOP F S PSAR=+$O(^PSD(58.81,"F",PSA,PSAR)) Q:'PSAR I $P($G(^PSD(58.81,PSAR,0)),"^",4)'<PSAT,$P($G(^(0)),"^",2)=9!($P($G(^(0)),"^",2)=24),$P($G(^(0)),"^",3)=PSALOC D Q:PSAOUT
.I $P($G(^PSD(58.81,PSAR,0)),"^",2)=9,$Y+4>IOSL D HEADER Q:PSAOUT
.I $P($G(^PSD(58.81,PSAR,0)),"^",2)=24,$Y+6>IOSL D HEADER Q:PSAOUT
.S Y=$P($G(^PSD(58.81,PSAR,0)),"^",4) X ^DD("DD") W !,$E(Y,1,17)
.W:$P($G(^PSD(58.81,PSAR,0)),"^",2)=9 ?22 W:$P($G(^PSD(58.81,PSAR,0)),"^",2)=24 ?30 W $J($P($G(^PSD(58.81,PSAR,0)),"^",6),5,0)
.W ?37,$E($P($G(^VA(200,+$P($G(^PSD(58.81,PSAR,0)),"^",7),0)),"^"),1,20)
.I $P($G(^PSD(58.81,PSAR,0)),"^",2)=9 W !?37,$P($G(^PSD(58.81,PSAR,0)),"^",16),! Q
.S PSATRANL=$P($G(^PSD(58.81,+$P($G(^PSD(58.81,PSAR,0)),"^",17),0)),"^",3),PSAHOLD=PSALOC,PSAHOLDN=PSALOCN,PSALOC=PSATRANL
.I PSALOC="" W !?37,"TRANSFER DATA MISSING",! S PSALOC=PSAHOLD,PSALOCN=PSAHOLDN Q
.D SITES^PSAUTL1 S PSALOCN=$P(^PSD(58.8,PSALOC,0),"^")_PSACOMB
.I $P($G(^PSD(58.81,PSAR,0)),"^",6)<0 W:$L(PSALOCN)<42 !?37,"TO "_PSALOCN,! I $L(PSALOCN)>43 S PSATF="T" W !?37,"TO " D TRAN
.I $P($G(^PSD(58.81,PSAR,0)),"^",6)>0 W:$L(PSALOCN)<42 !?37,"FROM "_PSALOCN,! I $L(PSALOCN)>43 S PSATF="F" W !?37,"FROM " D TRAN
.S PSALOC=PSAHOLD,PSALOCN=PSAHOLDN
EXIT W:$E(IOST)'="C" @IOF
I $E(IOST,1,2)="C-",'$G(PSAOUT) D
.S PSASS=21-$Y F PSAKK=1:1:PSASS W !
.S DIR(0)="EA",DIR("A")="END OF REPORT! Press <RET> to return to the menu." D ^DIR W @IOF
D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@" K IO("Q")
K DA,DIC,DIR,DIRUT,DTOUT,DUOUT,PSA,PSACHK,PSACNT,PSACOMB,PSADRG,PSAHOLD,PSAHOLDN,PSAKK,PSALOC,PSALOCA,PSALOCN,PSAOUT,PSAR,PSASEL,PSASS,PSAT,PSATAB,PSATF,PSATRAN,PSATRANL,X,Y
Q
I $E(IOST,1,2)="C-",PSAPG D Q:PSAOUT
.S PSASS=21-$Y F PSAKK=1:1:PSASS W !
.S DIR(0)="E" D ^DIR K DIR I 'Y S PSAOUT=1 Q
I $$S^%ZTLOAD W !!,"Task #",$G(ZTSK),", ",$G(ZTDESC)," was stopped by ",$P($G(^VA(200,+$G(DUZ),0)),"^"),"." S PSAOUT=1
W:$Y @IOF S PSAPG=PSAPG+1
W:$E(IOST)'="C" !,PSARPDT,?20,"DRUG ACCOUNTABILITY/INVENTORY INTERFACE"
W !?22,"HISTORY OF ADJUSTMENTS AND TRANSFERS",?70,"PAGE: ",PSAPG,!
W:$L(PSALOCN)>76 ?2,$P(PSALOCN,"(IP)",1)_"(IP)",!?19,$P(PSALOCN,"(IP)",2),! W:$L(PSALOCN)<77 ?((80-$L(PSALOCN))/2),PSALOCN,!?PSATAB,PSADRG,!
I $P($G(^PSD(58.8,PSALOC,1,PSA,0)),"^",14),$P($G(^(0)),"^",14)'>DT W ?20,"** INACTIVE DRUG IN PHARMACY LOCATION **",!
W !,"DATE",?22,"ADJUST",?30,"TRANS",?37,"TRANSACTOR & REASON",!,PSASLN
Q
TRAN ;
I $E(PSALOCN)="I" W $P($P(PSALOCN,":",2),"(IP)"),!
I $E(PSALOCN)="O" W $P($P(PSALOCN,":",2),"(OP)"),!
I $E(PSALOCN)="C" W "COMBINED:"_$P($P(PSALOCN,":",2),"(IP)",1)_"(IP)",! W:PSATF="T" ?49 W:PSATF="F" ?51 W $P($P(PSALOCN,":",2),"(IP)",2),!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSADJR 4324 printed Apr 09, 2024@20:56:13 Page 2
PSADJR ;BIR/LTL,JMB-Balance Adjustments History ;8/21/97
+1 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**15**; 10/24/97
+2 ;This routine reviews adjustment transactions for drugs.
+3 ;
+4 ;References to ^PSDRUG( are covered by IA #2095
+5 ;
LOOK ;Get locations to display
+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 IF '$ORDER(^PSD(58.8,PSALOC,1,0))
WRITE !!,"There are no drugs in ",PSALOCN
SET PSAOUT=1
GOTO EXIT
+5 SET DIC="^PSD(58.8,PSALOC,1,"
SET DIC(0)="AEMQZ"
SET DIC("A")="Select drug for history: "
SET DA(1)=PSALOC
SET DIC("W")="I $S($P($G(^(0)),U,14):$P($G(^(0)),U,14)'>DT,1:0) W $C(7),"" ***INACTIVE ***"""
WRITE !
+6 DO ^DIC
KILL DIC
SET PSA=+Y
IF PSA<0
SET PSAOUT=1
GOTO EXIT
+7 IF '$ORDER(^PSD(58.81,"F",+Y,""))
WRITE !!,"There have been no adjustments for this drug.",!!
SET PSAOUT=1
GOTO EXIT
+8 WRITE !
SET DIR(0)="D:AEP"
SET DIR("A")="How far back in time do you want to go: "
SET DIR("B")="T-6M"
DO ^DIR
KILL DIR
IF $DATA(DIRUT)
SET PSAOUT=1
GOTO EXIT
+9 SET PSAT=Y
DEV ;asks device and queueing info
+1 KILL IO("Q")
NEW %ZIS,IOP,POP
SET %ZIS="Q"
DO ^%ZIS
IF POP
WRITE !,"NO DEVICE SELECTED OR OUTPUT PRINTED!"
SET PSAOUT=1
GOTO EXIT
+2 IF $DATA(IO("Q"))
NEW ZTDESC,ZTIO,ZTRTN,ZTSAVE,ZTDTH,ZTSK
SET ZTRTN="START^PSADJR"
SET ZTDESC="Drug Acct. - Drug adjustment review"
SET ZTSAVE("PSA*")=""
DO ^%ZTLOAD
DO HOME^%ZIS
SET PSAOUT=1
GOTO EXIT
START ;compiles and prints output
+1 DO SITES^PSAUTL1
SET PSALOCN=$PIECE(^PSD(58.8,PSALOC,0),"^")_PSACOMB
+2 SET PSADRG=$PIECE($GET(^PSDRUG(PSA,0)),"^")
SET PSATAB=(80-$LENGTH(PSADRG))/2
+3 NEW %DT,PSASLN,PSAPG,PSAOUT,PSARPDT
SET (PSAPG,PSAOUT)=0
SET $PIECE(PSASLN,"-",81)=""
SET Y=DT
DO DD^%DT
SET PSARPDT=Y
SET PSAR=0
DO HEADER
LOOP FOR
SET PSAR=+$ORDER(^PSD(58.81,"F",PSA,PSAR))
if 'PSAR
QUIT
IF $PIECE($GET(^PSD(58.81,PSAR,0)),"^",4)'<PSAT
IF $PIECE($GET(^(0)),"^",2)=9!($PIECE($GET(^(0)),"^",2)=24)
IF $PIECE($GET(^(0)),"^",3)=PSALOC
Begin DoDot:1
+1 IF $PIECE($GET(^PSD(58.81,PSAR,0)),"^",2)=9
IF $Y+4>IOSL
DO HEADER
if PSAOUT
QUIT
+2 IF $PIECE($GET(^PSD(58.81,PSAR,0)),"^",2)=24
IF $Y+6>IOSL
DO HEADER
if PSAOUT
QUIT
+3 SET Y=$PIECE($GET(^PSD(58.81,PSAR,0)),"^",4)
XECUTE ^DD("DD")
WRITE !,$EXTRACT(Y,1,17)
+4 if $PIECE($GET(^PSD(58.81,PSAR,0)),"^",2)=9
WRITE ?22
if $PIECE($GET(^PSD(58.81,PSAR,0)),"^",2)=24
WRITE ?30
WRITE $JUSTIFY($PIECE($GET(^PSD(58.81,PSAR,0)),"^",6),5,0)
+5 WRITE ?37,$EXTRACT($PIECE($GET(^VA(200,+$PIECE($GET(^PSD(58.81,PSAR,0)),"^",7),0)),"^"),1,20)
+6 IF $PIECE($GET(^PSD(58.81,PSAR,0)),"^",2)=9
WRITE !?37,$PIECE($GET(^PSD(58.81,PSAR,0)),"^",16),!
QUIT
+7 SET PSATRANL=$PIECE($GET(^PSD(58.81,+$PIECE($GET(^PSD(58.81,PSAR,0)),"^",17),0)),"^",3)
SET PSAHOLD=PSALOC
SET PSAHOLDN=PSALOCN
SET PSALOC=PSATRANL
+8 IF PSALOC=""
WRITE !?37,"TRANSFER DATA MISSING",!
SET PSALOC=PSAHOLD
SET PSALOCN=PSAHOLDN
QUIT
+9 DO SITES^PSAUTL1
SET PSALOCN=$PIECE(^PSD(58.8,PSALOC,0),"^")_PSACOMB
+10 IF $PIECE($GET(^PSD(58.81,PSAR,0)),"^",6)<0
if $LENGTH(PSALOCN)<42
WRITE !?37,"TO "_PSALOCN,!
IF $LENGTH(PSALOCN)>43
SET PSATF="T"
WRITE !?37,"TO "
DO TRAN
+11 IF $PIECE($GET(^PSD(58.81,PSAR,0)),"^",6)>0
if $LENGTH(PSALOCN)<42
WRITE !?37,"FROM "_PSALOCN,!
IF $LENGTH(PSALOCN)>43
SET PSATF="F"
WRITE !?37,"FROM "
DO TRAN
+12 SET PSALOC=PSAHOLD
SET PSALOCN=PSAHOLDN
End DoDot:1
if PSAOUT
QUIT
EXIT if $EXTRACT(IOST)'="C"
WRITE @IOF
+1 IF $EXTRACT(IOST,1,2)="C-"
IF '$GET(PSAOUT)
Begin DoDot:1
+2 SET PSASS=21-$Y
FOR PSAKK=1:1:PSASS
WRITE !
+3 SET DIR(0)="EA"
SET DIR("A")="END OF REPORT! Press <RET> to return to the menu."
DO ^DIR
WRITE @IOF
End DoDot:1
+4 DO ^%ZISC
if $DATA(ZTQUEUED)
SET ZTREQ="@"
KILL IO("Q")
+5 KILL DA,DIC,DIR,DIRUT,DTOUT,DUOUT,PSA,PSACHK,PSACNT,PSACOMB,PSADRG,PSAHOLD,PSAHOLDN,PSAKK,PSALOC,PSALOCA,PSALOCN,PSAOUT,PSAR,PSASEL,PSASS,PSAT,PSATAB,PSATF,PSATRAN,PSATRANL,X,Y
+6 QUIT
+1 IF $EXTRACT(IOST,1,2)="C-"
IF PSAPG
Begin DoDot:1
+2 SET PSASS=21-$Y
FOR PSAKK=1:1:PSASS
WRITE !
+3 SET DIR(0)="E"
DO ^DIR
KILL DIR
IF 'Y
SET PSAOUT=1
QUIT
End DoDot:1
if PSAOUT
QUIT
+4 IF $$S^%ZTLOAD
WRITE !!,"Task #",$GET(ZTSK),", ",$GET(ZTDESC)," was stopped by ",$PIECE($GET(^VA(200,+$GET(DUZ),0)),"^"),"."
SET PSAOUT=1
+5 if $Y
WRITE @IOF
SET PSAPG=PSAPG+1
+6 if $EXTRACT(IOST)'="C"
WRITE !,PSARPDT,?20,"DRUG ACCOUNTABILITY/INVENTORY INTERFACE"
+7 WRITE !?22,"HISTORY OF ADJUSTMENTS AND TRANSFERS",?70,"PAGE: ",PSAPG,!
+8 if $LENGTH(PSALOCN)>76
WRITE ?2,$PIECE(PSALOCN,"(IP)",1)_"(IP)",!?19,$PIECE(PSALOCN,"(IP)",2),!
if $LENGTH(PSALOCN)<77
WRITE ?((80-$LENGTH(PSALOCN))/2),PSALOCN,!?PSATAB,PSADRG,!
+9 IF $PIECE($GET(^PSD(58.8,PSALOC,1,PSA,0)),"^",14)
IF $PIECE($GET(^(0)),"^",14)'>DT
WRITE ?20,"** INACTIVE DRUG IN PHARMACY LOCATION **",!
+10 WRITE !,"DATE",?22,"ADJUST",?30,"TRANS",?37,"TRANSACTOR & REASON",!,PSASLN
+11 QUIT
TRAN ;
+1 IF $EXTRACT(PSALOCN)="I"
WRITE $PIECE($PIECE(PSALOCN,":",2),"(IP)"),!
+2 IF $EXTRACT(PSALOCN)="O"
WRITE $PIECE($PIECE(PSALOCN,":",2),"(OP)"),!
+3 IF $EXTRACT(PSALOCN)="C"
WRITE "COMBINED:"_$PIECE($PIECE(PSALOCN,":",2),"(IP)",1)_"(IP)",!
if PSATF="T"
WRITE ?49
if PSATF="F"
WRITE ?51
WRITE $PIECE($PIECE(PSALOCN,":",2),"(IP)",2),!
+4 QUIT
