PSADJI ;BIR/LTL-Balance Initialization ;7/23/97
;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**64**; 10/24/97;Build 4
;This routine allows the user to enter a beginning balance on hand for
;a drug in a pharmacy location.
;
D ^PSADA G:'$G(PSALOC) QUIT
N D1,D2,DIC,DIE,DINUM,D0,D1,DLAYGO,DR,DIR,DIRUT,DTOUT,DUOUT,PSAC,PSADT,DA,PSADRUG,PSADRUGN,PSAS,PSAQ,PSAR,PSAREC,PSAOUT,PSAT,X,Y
CHKD I '$O(^PSD(58.8,PSALOC,1,0)) W !!,"There are no drugs in ",$G(PSALOCN) G QUIT
W !!,"Give me a second to alphabetize.",!
S PSADRUG=0,PSADRUGN=""
F S PSADRUG=$O(^PSD(58.8,+PSALOC,1,PSADRUG)) Q:'PSADRUG!($P($G(^PSDRUG(+PSADRUG,0)),U)']"") D
.S ^TMP("PSAB",$J,$P($G(^PSDRUG(+PSADRUG,0)),U),PSADRUG)="" K Y
W @IOF
F PSAC=1:1 S PSADRUGN=$O(^TMP("PSAB",$J,PSADRUGN)) Q:PSADRUGN']"" S PSADRUG=$O(^TMP("PSAB",$J,PSADRUGN,0)) D G:$D(Y) QUIT
.I $P($G(^PSD(58.8,+PSALOC,1,PSADRUG,0)),U,4)]"" D:$Y+9>IOSL Q:$D(DUOUT)!($D(DTOUT)) W !!,PSADRUGN," may have to be adjusted.",!!,"There's already ",$P($G(^PSD(58.8,+PSALOC,1,+PSADRUG,0)),U,4)," on hand." Q
..S DIR(0)="E" D ^DIR K DIR K:Y Y W @IOF
.W !!,PSADRUGN,!!,"Dispensing Unit: "
.W $P($G(^PSDRUG(+PSADRUG,660)),U,8),!
.F L +^PSD(58.8,+PSALOC,1,+PSADRUG,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
.S DIR(0)="N^0:999999:2",DIR("A")="Initial Balance" D ^DIR K DIR
.I $D(DIRUT) L -^PSD(58.8,+PSALOC,1,+PSADRUG,0) S Y=1 Q
.S PSAREC=Y D NOW^%DTC S PSADT=+$E(%,1,12),DIE="^PSD(58.8,+PSALOC,1,"
.S DA(1)=PSALOC,DA=PSADRUG,DR="3////"_PSAREC D ^DIE
.L -^PSD(58.8,+PSALOC,1,+PSADRUG,0)
.Q:$G(PSAREC)']""
MON .S:'$D(^PSD(58.8,+PSALOC,1,+PSADRUG,5,0)) ^(0)="^58.801A^^"
.I '$D(^PSD(58.8,+PSALOC,1,+PSADRUG,5,$E(DT,1,5)*100,0)) S DIC="^PSD(58.8,+PSALOC,1,+PSADRUG,5,",DIC(0)="L",(X,DINUM)=$E(DT,1,5)*100,DA(2)=PSALOC,DA(1)=PSADRUG,DLAYGO=58.8 D ^DIC K DIC,DLAYGO
.S DIE="^PSD(58.8,+PSALOC,1,+PSADRUG,5,",DA(2)=PSALOC,DA(1)=PSADRUG,DA=$E(DT,1,5)*100,DR="1////0;7////^S X=PSAREC" D ^DIE
.W !!,"Updating beginning balance and transaction history.",!
TR .F L +^PSD(58.81,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
FIND .S PSAT=$P(^PSD(58.81,0),U,3)+1 I $D(^PSD(58.81,PSAT)) S $P(^PSD(58.81,0),U,3)=$P(^PSD(58.81,0),U,3)+1 G FIND
.S DIC="^PSD(58.81,",DIC(0)="L",DLAYGO=58.81,(DINUM,X)=PSAT D ^DIC K DIC,DLAYGO L -^PSD(58.81,0)
.S DIE="^PSD(58.81,",DA=PSAT,DR="1////11;2////^S X=PSALOC;3////^S X=PSADT;4////^S X=PSADRUG;5////^S X=PSAREC;6////^S X=DUZ;9////0" D ^DIE K DIE
.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,DA,DLAYGO,Y
QUIT K ^TMP("PSAB",$J) Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSADJI 2670 printed Sep 23, 2025@19:25:12 Page 2
PSADJI ;BIR/LTL-Balance Initialization ;7/23/97
+1 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**64**; 10/24/97;Build 4
+2 ;This routine allows the user to enter a beginning balance on hand for
+3 ;a drug in a pharmacy location.
+4 ;
+5 DO ^PSADA
if '$GET(PSALOC)
GOTO QUIT
+6 NEW D1,D2,DIC,DIE,DINUM,D0,D1,DLAYGO,DR,DIR,DIRUT,DTOUT,DUOUT,PSAC,PSADT,DA,PSADRUG,PSADRUGN,PSAS,PSAQ,PSAR,PSAREC,PSAOUT,PSAT,X,Y
CHKD IF '$ORDER(^PSD(58.8,PSALOC,1,0))
WRITE !!,"There are no drugs in ",$GET(PSALOCN)
GOTO QUIT
+1 WRITE !!,"Give me a second to alphabetize.",!
+2 SET PSADRUG=0
SET PSADRUGN=""
+3 FOR
SET PSADRUG=$ORDER(^PSD(58.8,+PSALOC,1,PSADRUG))
if 'PSADRUG!($PIECE($GET(^PSDRUG(+PSADRUG,0)),U)']"")
QUIT
Begin DoDot:1
+4 SET ^TMP("PSAB",$JOB,$PIECE($GET(^PSDRUG(+PSADRUG,0)),U),PSADRUG)=""
KILL Y
End DoDot:1
+5 WRITE @IOF
+6 FOR PSAC=1:1
SET PSADRUGN=$ORDER(^TMP("PSAB",$JOB,PSADRUGN))
if PSADRUGN']""
QUIT
SET PSADRUG=$ORDER(^TMP("PSAB",$JOB,PSADRUGN,0))
Begin DoDot:1
+7 IF $PIECE($GET(^PSD(58.8,+PSALOC,1,PSADRUG,0)),U,4)]""
if $Y+9>IOSL
Begin DoDot:2
+8 SET DIR(0)="E"
DO ^DIR
KILL DIR
if Y
KILL Y
WRITE @IOF
End DoDot:2
if $DATA(DUOUT)!($DATA(DTOUT))
QUIT
WRITE !!,PSADRUGN," may have to be adjusted.",!!,"There's already ",$PIECE($GET(^PSD(58.8,+PSALOC,1,+PSADRUG,0)),U,4)," on hand."
QUIT
+9 WRITE !!,PSADRUGN,!!,"Dispensing Unit: "
+10 WRITE $PIECE($GET(^PSDRUG(+PSADRUG,660)),U,8),!
+11 FOR
LOCK +^PSD(58.8,+PSALOC,1,+PSADRUG,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
IF $TEST
QUIT
+12 SET DIR(0)="N^0:999999:2"
SET DIR("A")="Initial Balance"
DO ^DIR
KILL DIR
+13 IF $DATA(DIRUT)
LOCK -^PSD(58.8,+PSALOC,1,+PSADRUG,0)
SET Y=1
QUIT
+14 SET PSAREC=Y
DO NOW^%DTC
SET PSADT=+$EXTRACT(%,1,12)
SET DIE="^PSD(58.8,+PSALOC,1,"
+15 SET DA(1)=PSALOC
SET DA=PSADRUG
SET DR="3////"_PSAREC
DO ^DIE
+16 LOCK -^PSD(58.8,+PSALOC,1,+PSADRUG,0)
+17 if $GET(PSAREC)']""
QUIT
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(DT,1,5)*100,0))
SET DIC="^PSD(58.8,+PSALOC,1,+PSADRUG,5,"
SET DIC(0)="L"
SET (X,DINUM)=$EXTRACT(DT,1,5)*100
SET DA(2)=PSALOC
SET DA(1)=PSADRUG
SET DLAYGO=58.8
DO ^DIC
KILL DIC,DLAYGO
+2 SET DIE="^PSD(58.8,+PSALOC,1,+PSADRUG,5,"
SET DA(2)=PSALOC
SET DA(1)=PSADRUG
SET DA=$EXTRACT(DT,1,5)*100
SET DR="1////0;7////^S X=PSAREC"
DO ^DIE
+3 WRITE !!,"Updating beginning balance and transaction history.",!
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),U,3)+1
IF $DATA(^PSD(58.81,PSAT))
SET $PIECE(^PSD(58.81,0),U,3)=$PIECE(^PSD(58.81,0),U,3)+1
GOTO FIND
+1 SET DIC="^PSD(58.81,"
SET DIC(0)="L"
SET DLAYGO=58.81
SET (DINUM,X)=PSAT
DO ^DIC
KILL DIC,DLAYGO
LOCK -^PSD(58.81,0)
+2 SET DIE="^PSD(58.81,"
SET DA=PSAT
SET DR="1////11;2////^S X=PSALOC;3////^S X=PSADT;4////^S X=PSADRUG;5////^S X=PSAREC;6////^S X=DUZ;9////0"
DO ^DIE
KILL DIE
+3 if '$DATA(^PSD(58.8,+PSALOC,1,+PSADRUG,4,0))
SET ^(0)="^58.800119PA^^"
+4 SET DIC="^PSD(58.8,+PSALOC,1,+PSADRUG,4,"
SET DIC(0)="L"
SET (X,DINUM)=PSAT
+5 SET DA(2)=PSALOC
SET DA(1)=PSADRUG
SET DLAYGO=58.8
DO ^DIC
KILL DIC,DA,DLAYGO,Y
End DoDot:1
if $DATA(Y)
GOTO QUIT
QUIT KILL ^TMP("PSAB",$JOB)
QUIT
