Routine: PSATRAN1

PSATRAN1 ;BIR/JMB-Transfer Drugs between Pharmacies - CONT'D ;7/23/97

 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**64**; 10/24/97;Build 4

 ;This routine updates the dispensing and receiving locations. The drug

 ;balance & monthly activity are updated. It creates an activity in 58.8,

 ;a transaction in 58.81, sends a mail message if the drug is new to the

 ;receiving location, and stores the data so the signature sheet can

 ;print. It is called by PSATRAN.

UPDATE ;update location balances

 D CHK Q:PSALES  W !!,"Updating pharmacy on-hand balances now..."

 S (PSATODA,PSAFRDA)=0

 F PSALCNT=1:1:2 D CALC

 I PSATODA,PSAFRDA D

 .S DIE="^PSD(58.81,",DA=PSATODA,DR="16///^S X=PSAFRDA"

 .F  L +^PSD(58.81,DA,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I  Q

 .D ^DIE L -^PSD(58.81,DA,0) K DA

 .S DA=PSAFRDA,DR="16///^S X=PSATODA"

 .F  L +^PSD(58.81,DA,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I  Q

 .D ^DIE L -^PSD(58.81,DA,0) K DA,DIE

 W !,"Done!" H 1 S ^TMP("PSASIG",$J,+PSAFROM,+PSATO,PSAFRDA)=""

 D:PSADD MSG I 'PSADD H 1

 S (PSADD,PSAOUT)=0

CALC ;sub/add qty from dsp sites

 W "." S PSATEMP=+$S(PSALCNT=1:PSAFROM,1:PSATO),PSATQTY=-PSATQTY

 F  L +^PSD(58.8,PSATEMP,1,PSADRG,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I  Q

 D NOW^%DTC S PSADT=+%

 S PSABAL(PSALCNT)=$P(^PSD(58.8,PSATEMP,1,PSADRG,0),"^",4),$P(^(0),"^",4)=$P(^(0),"^",4)+PSATQTY,$P(PSABAL(PSALCNT),"^",2)=(+PSABAL(PSALCNT)+PSATQTY)

 L -^PSD(58.8,PSATEMP,1,PSADRG,0)

ADD ;find entry number

 F  L +^PSD(58.81,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I  Q

FIND S PSAREC=$P(^PSD(58.81,0),"^",3)+1 I $D(^PSD(58.81,PSAREC)) S $P(^PSD(58.81,0),"^",3)=PSAREC G FIND

 K DIC,DLAYGO S DIC(0)="L",DIC="^PSD(58.81,",DLAYGO=58.81,(X,DINUM)=PSAREC D ^DIC K DIC,DINUM,DLAYGO

 L -^PSD(58.81,0) W "."

 S:PSALCNT=1 PSAFRDA=PSAREC S:PSALCNT=2 PSATODA=PSAREC

TRANS ;update transaction data

 K DA,DIE,DR S DA=PSAREC,DIE=58.81

 S DR="1////24;2////"_PSATEMP_";4////"_PSADRG_";3////"_PSADT_";5////"_PSATQTY_";6////"_PSADUZ_";9////"_$P(PSABAL(PSALCNT),"^")

 D ^DIE K DA,DIE,DR W "."

ACT ;update location drug info

 S:'$D(^PSD(58.8,PSATEMP,1,PSADRG,4,0)) ^PSD(58.8,PSATEMP,1,PSADRG,4,0)="^58.800119PA^^"

 I '$D(^PSD(58.8,PSATEMP,1,PSADRG,4,PSAREC,0)) K DA,DD,DO S DIC(0)="L",DIC="^PSD(58.8,"_PSATEMP_",1,"_PSADRG_",4,",DA(2)=PSATEMP,DA(1)=PSADRG,(X,DINUM)=PSAREC D ^DIC K DA,DIC,DINUM W "."

MON ;update monthly activity node

 S:'$D(^PSD(58.8,PSATEMP,1,PSADRG,5,0)) ^(0)="^58.801A^^"

 I '$D(^PSD(58.8,PSATEMP,1,PSADRG,5,$E(PSADT,1,5)*100,0)) D

 .S DIC="^PSD(58.8,"_PSATEMP_",1,"_PSADRG_",5,",DIC(0)="LM"

 .S DA(2)=PSATEMP,DA(1)=PSADRG,(X,DINUM)=($E(PSADT,1,5)*100),DLAYGO=58.8 D ^DIC K DIC,DINUM,DLAYGO W "." S DA=+Y

 .S DIE="^PSD(58.8,"_PSATEMP_",1,"_PSADRG_",5,",DA(2)=PSATEMP,DA(1)=PSADRG,DR="1////^S X="_+PSABAL(PSALCNT) D ^DIE K DIE

 .S X="T-1M" D ^%DT

 .S DIC="^PSD(58.8,"_PSATEMP_",1,"_PSADRG_",5,",DIC(0)="LM",DA(2)=PSATEMP,DA(1)=PSADRG,(X,DINUM)=($E(Y,1,5)*100),DLAYGO=58.8 D ^DIC K DINUM,DLAYGO

 ;.S DIE=DIC,DR="3////^S X="_($P($G(^PSD(58.8,PSATEMP,1,PSADRG,0)),"^",4)-PSATQTY) K DIC D ^DIE K DA,DIE W "."

 S DA=($E(PSADT,1,5)*100),PSANODE=$G(^PSD(58.8,PSATEMP,1,PSADRG,5,DA,0)) Q:'$D(PSANODE)

 S PSAREC=$P(PSANODE,"^",3),PSADJ=$P(PSANODE,"^",5),PSADISP=$P(PSANODE,"^",6),PSARET=$P(PSANODE,"^",7),PSATF=$P(PSANODE,"^",9)+PSATQTY

 S PSABAL=$P(PSANODE,"^",2)+PSAREC+PSADJ-PSADISP+PSARET+PSATF

 S DIE="^PSD(58.8,"_PSATEMP_",1,"_PSADRG_",5,",DA(2)=PSATEMP,DA(1)=PSADRG

 S DR="13////^S X="_($P($G(^PSD(58.8,PSATEMP,1,PSADRG,5,DA,0)),"^",9)+PSATQTY)_";3////^S X="_PSABAL

 D ^DIE K DA,DIE W "."

CHK ;check for valid bal

 S PSALES=0 D:PSATQTY>$P(^PSD(58.8,PSAFROM,1,PSADRG,0),"^",4)

 .W $C(7),!!,"=>   The drug balance is "_+$P(^PSD(58.8,PSAFROM,1,PSADRG,0),"^",4)_".  You cannot transfer "_PSATQTY_" for this drug.",! S PSALES=1

 .W "No action taken.",!

MSG ;send mailman message with transfer info

 K XMY,^TMP("PSATRAN",$J)

 S ^TMP("PSATRAN",$J,1,0)="Drug: "_PSADRGN

 S ^TMP("PSATRAN",$J,2,0)="Quantity  : "_PSATQTY_" ("_PSADU_")",^TMP("PSATRAN",$J,3,0)="Pharmacist: "_PSADUZN,^TMP("PSATRAN",$J,4,0)=" "

 S ^TMP("PSATRAN",$J,5,0)="Transferred from:",^TMP("PSATRAN",$J,6,0)=PSAFROMN,^TMP("PSATRAN",$J,7,0)=" "

 S ^TMP("PSATRAN",$J,8,0)="Transferred and Added to:",^TMP("PSATRAN",$J,9,0)=PSATON

 S XMSUB="Drug Transfer Between Pharmacies",XMTEXT="^TMP(""PSATRAN"",$J,",XMDUZ="Drug Accountability System"

 F PSAJJ=0:0 S PSAJJ=$O(^XUSEC("PSAMGR",PSAJJ)) Q:'PSAJJ  S XMY(PSAJJ)=""

 G:'$D(XMY) QUIT D ^XMD

QUIT K XMY,^TMP("PSATRAN",$J)

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSATRAN1   4534     printed  Mar 13, 2025@20:55:19                                                                                                                                                                                                    Page 2

PSATRAN1  ;BIR/JMB-Transfer Drugs between Pharmacies - CONT'D ;7/23/97

 +1       ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**64**; 10/24/97;Build 4

 +2       ;This routine updates the dispensing and receiving locations. The drug

 +3       ;balance & monthly activity are updated. It creates an activity in 58.8,

 +4       ;a transaction in 58.81, sends a mail message if the drug is new to the

 +5       ;receiving location, and stores the data so the signature sheet can

 +6       ;print. It is called by PSATRAN.

 +7       ;

UPDATE    ;update location balances

 +1        DO CHK

           if PSALES

               QUIT

           WRITE !!,"Updating pharmacy on-hand balances now..."

 +2        SET (PSATODA,PSAFRDA)=0

 +3        FOR PSALCNT=1:1:2

               DO CALC

 +4        IF PSATODA

               IF PSAFRDA

                   Begin DoDot:1

 +5                    SET DIE="^PSD(58.81,"

                       SET DA=PSATODA

                       SET DR="16///^S X=PSAFRDA"

 +6                    FOR

                           LOCK +^PSD(58.81,DA,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)

                          IF $TEST

                               QUIT

 +7                    DO ^DIE

                       LOCK -^PSD(58.81,DA,0)

                       KILL DA

 +8                    SET DA=PSAFRDA

                       SET DR="16///^S X=PSATODA"

 +9                    FOR

                           LOCK +^PSD(58.81,DA,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)

                          IF $TEST

                               QUIT

 +10                   DO ^DIE

                       LOCK -^PSD(58.81,DA,0)

                       KILL DA,DIE

                   End DoDot:1

 +11       WRITE !,"Done!"

           HANG 1

           SET ^TMP("PSASIG",$JOB,+PSAFROM,+PSATO,PSAFRDA)=""

 +12       if PSADD

               DO MSG

           IF 'PSADD

               HANG 1

 +13       SET (PSADD,PSAOUT)=0

 +14       QUIT

CALC      ;sub/add qty from dsp sites

 +1        WRITE "."

           SET PSATEMP=+$SELECT(PSALCNT=1:PSAFROM,1:PSATO)

           SET PSATQTY=-PSATQTY

 +2        FOR

               LOCK +^PSD(58.8,PSATEMP,1,PSADRG,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)

              IF $TEST

                   QUIT

 +3        DO NOW^%DTC

           SET PSADT=+%

 +4        SET PSABAL(PSALCNT)=$PIECE(^PSD(58.8,PSATEMP,1,PSADRG,0),"^",4)

           SET $PIECE(^(0),"^",4)=$PIECE(^(0),"^",4)+PSATQTY

           SET $PIECE(PSABAL(PSALCNT),"^",2)=(+PSABAL(PSALCNT)+PSATQTY)

 +5        LOCK -^PSD(58.8,PSATEMP,1,PSADRG,0)

ADD       ;find entry number

 +1        FOR

               LOCK +^PSD(58.81,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)

              IF $TEST

                   QUIT

FIND       SET PSAREC=$PIECE(^PSD(58.81,0),"^",3)+1

           IF $DATA(^PSD(58.81,PSAREC))

               SET $PIECE(^PSD(58.81,0),"^",3)=PSAREC

               GOTO FIND

 +1        KILL DIC,DLAYGO

           SET DIC(0)="L"

           SET DIC="^PSD(58.81,"

           SET DLAYGO=58.81

           SET (X,DINUM)=PSAREC

           DO ^DIC

           KILL DIC,DINUM,DLAYGO

 +2        LOCK -^PSD(58.81,0)

           WRITE "."

 +3        if PSALCNT=1

               SET PSAFRDA=PSAREC

           if PSALCNT=2

               SET PSATODA=PSAREC

TRANS     ;update transaction data

 +1        KILL DA,DIE,DR

           SET DA=PSAREC

           SET DIE=58.81

 +2        SET DR="1////24;2////"_PSATEMP_";4////"_PSADRG_";3////"_PSADT_";5////"_PSATQTY_";6////"_PSADUZ_";9////"_$PIECE(PSABAL(PSALCNT),"^")

 +3        DO ^DIE

           KILL DA,DIE,DR

           WRITE "."

ACT       ;update location drug info

 +1        if '$DATA(^PSD(58.8,PSATEMP,1,PSADRG,4,0))

               SET ^PSD(58.8,PSATEMP,1,PSADRG,4,0)="^58.800119PA^^"

 +2        IF '$DATA(^PSD(58.8,PSATEMP,1,PSADRG,4,PSAREC,0))

               KILL DA,DD,DO

               SET DIC(0)="L"

               SET DIC="^PSD(58.8,"_PSATEMP_",1,"_PSADRG_",4,"

               SET DA(2)=PSATEMP

               SET DA(1)=PSADRG

               SET (X,DINUM)=PSAREC

               DO ^DIC

               KILL DA,DIC,DINUM

               WRITE "."

MON       ;update monthly activity node

 +1        if '$DATA(^PSD(58.8,PSATEMP,1,PSADRG,5,0))

               SET ^(0)="^58.801A^^"

 +2        IF '$DATA(^PSD(58.8,PSATEMP,1,PSADRG,5,$EXTRACT(PSADT,1,5)*100,0))

               Begin DoDot:1

 +3                SET DIC="^PSD(58.8,"_PSATEMP_",1,"_PSADRG_",5,"

                   SET DIC(0)="LM"

 +4                SET DA(2)=PSATEMP

                   SET DA(1)=PSADRG

                   SET (X,DINUM)=($EXTRACT(PSADT,1,5)*100)

                   SET DLAYGO=58.8

                   DO ^DIC

                   KILL DIC,DINUM,DLAYGO

                   WRITE "."

                   SET DA=+Y

 +5                SET DIE="^PSD(58.8,"_PSATEMP_",1,"_PSADRG_",5,"

                   SET DA(2)=PSATEMP

                   SET DA(1)=PSADRG

                   SET DR="1////^S X="_+PSABAL(PSALCNT)

                   DO ^DIE

                   KILL DIE

 +6                SET X="T-1M"

                   DO ^%DT

 +7                SET DIC="^PSD(58.8,"_PSATEMP_",1,"_PSADRG_",5,"

                   SET DIC(0)="LM"

                   SET DA(2)=PSATEMP

                   SET DA(1)=PSADRG

                   SET (X,DINUM)=($EXTRACT(Y,1,5)*100)

                   SET DLAYGO=58.8

                   DO ^DIC

                   KILL DINUM,DLAYGO

               End DoDot:1

 +8       ;.S DIE=DIC,DR="3////^S X="_($P($G(^PSD(58.8,PSATEMP,1,PSADRG,0)),"^",4)-PSATQTY) K DIC D ^DIE K DA,DIE W "."

 +9        SET DA=($EXTRACT(PSADT,1,5)*100)

           SET PSANODE=$GET(^PSD(58.8,PSATEMP,1,PSADRG,5,DA,0))

           if '$DATA(PSANODE)

               QUIT

 +10       SET PSAREC=$PIECE(PSANODE,"^",3)

           SET PSADJ=$PIECE(PSANODE,"^",5)

           SET PSADISP=$PIECE(PSANODE,"^",6)

           SET PSARET=$PIECE(PSANODE,"^",7)

           SET PSATF=$PIECE(PSANODE,"^",9)+PSATQTY

 +11       SET PSABAL=$PIECE(PSANODE,"^",2)+PSAREC+PSADJ-PSADISP+PSARET+PSATF

 +12       SET DIE="^PSD(58.8,"_PSATEMP_",1,"_PSADRG_",5,"

           SET DA(2)=PSATEMP

           SET DA(1)=PSADRG

 +13       SET DR="13////^S X="_($PIECE($GET(^PSD(58.8,PSATEMP,1,PSADRG,5,DA,0)),"^",9)+PSATQTY)_";3////^S X="_PSABAL

 +14       DO ^DIE

           KILL DA,DIE

           WRITE "."

 +15       QUIT

CHK       ;check for valid bal

 +1        SET PSALES=0

           if PSATQTY>$PIECE(^PSD(58.8,PSAFROM,1,PSADRG,0),"^",4)

               Begin DoDot:1

 +2                WRITE $CHAR(7),!!,"=>   The drug balance is "_+$PIECE(^PSD(58.8,PSAFROM,1,PSADRG,0),"^",4)_".  You cannot transfer "_PSATQTY_" for this drug.",!

                   SET PSALES=1

 +3                WRITE "No action taken.",!

               End DoDot:1

 +4        QUIT

MSG       ;send mailman message with transfer info

 +1        KILL XMY,^TMP("PSATRAN",$JOB)

 +2        SET ^TMP("PSATRAN",$JOB,1,0)="Drug: "_PSADRGN

 +3        SET ^TMP("PSATRAN",$JOB,2,0)="Quantity  : "_PSATQTY_" ("_PSADU_")"

           SET ^TMP("PSATRAN",$JOB,3,0)="Pharmacist: "_PSADUZN

           SET ^TMP("PSATRAN",$JOB,4,0)=" "

 +4        SET ^TMP("PSATRAN",$JOB,5,0)="Transferred from:"

           SET ^TMP("PSATRAN",$JOB,6,0)=PSAFROMN

           SET ^TMP("PSATRAN",$JOB,7,0)=" "

 +5        SET ^TMP("PSATRAN",$JOB,8,0)="Transferred and Added to:"

           SET ^TMP("PSATRAN",$JOB,9,0)=PSATON

 +6        SET XMSUB="Drug Transfer Between Pharmacies"

           SET XMTEXT="^TMP(""PSATRAN"",$J,"

           SET XMDUZ="Drug Accountability System"

 +7        FOR PSAJJ=0:0

               SET PSAJJ=$ORDER(^XUSEC("PSAMGR",PSAJJ))

               if 'PSAJJ

                   QUIT

               SET XMY(PSAJJ)=""

 +8        if '$DATA(XMY)

               GOTO QUIT

           DO ^XMD

QUIT       KILL XMY,^TMP("PSATRAN",$JOB)

 +1        QUIT

PSATRAN1.m