PSATRAN ;BIR/JMB-Transfer Drugs between Pharmacies ;8/21/97
;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;; 10/24/97
;
I $D(^XUSEC("PSAMGR",DUZ)),'$D(^XUSEC("PSJ RPHARM",DUZ)) W !!,"** Contact your Pharmacy Coordinator for access to transfer drugs between",!,?4,"pharmacies. PSAMGR and PSJ RPHARM security keys are required.",! Q
S PSADUZ=DUZ,PSADUZN=$P($G(^VA(200,PSADUZ,0)),"^") D SIG^XUSESIG G:X1="" EXIT
FROM ;select FROM pharmacy
S (PSADD,PSACNT,PSAOUT)=0,PSASLN="",$P(PSASLN,"-",80)="",PSATRAN="F"
D ^PSAUTL3 G:PSAOUT EXIT S PSACHK=$O(PSALOC(""))
I PSACHK="",'PSALOC W !,"There are no active pharmacy locations." G EXIT
S PSAFROM=+PSALOC,PSAFROMN=PSALOCN
DRUG ;select drug
I '$O(^PSD(58.8,PSAFROM,1,0)) W !!,"There are no drugs in the transferring pharmacy.",!! G EXIT
W @IOF,!,PSAFROMN
K DA,DIC S DIC("W")="W:$P(^PSDRUG(Y,0),""^"",9) "" N/F"" I $P(^PSD(58.8,PSAFROM,1,Y,0),""^"",14)]"""",$P(^(0),""^"",14)'>DT W $C(7),"" *** INACTIVE ***"""
S DIC("A")="Select DRUG: ",DA(1)=+PSAFROM,DIC(0)="QEAM",DIC="^PSD(58.8,"_PSAFROM_",1,"
D ^DIC K DIC G:Y<0 FROM I ($D(DTOUT))!($D(DUOUT)) G EXIT
G:Y<0 FROM
S PSADRG=+Y,PSADRGN=$P($G(^PSDRUG(PSADRG,0)),"^"),PSABAL=+$P($G(^PSD(58.8,PSAFROM,1,PSADRG,0)),"^",4)
I PSABAL'>0 W $C(7),!!,PSADRGN," has a "_$S(PSABAL=0:"zero",1:"negative")_" balance.",!,"Select another drug to transfer." G DRUG
QTY ;enter quantity
S PSADU=$S($P($G(^PSDRUG(PSADRG,660)),"^",8)'="":$P($G(^PSDRUG(PSADRG,660)),"^",8),1:"Unknown")
W !!,?5,"Dispense Unit: ",PSADU,?35,"Current Balance: "_PSABAL,!
S DIR(0)="NO^1:"_PSABAL_":0",DIR("A")="Enter Quantity to Transfer",DIR("?")="Enter a whole number between 1 and "_PSABAL,DIR("??")="^D QTYHELP^PSATRAN"
D ^DIR K DIR I $G(DIRUT) D MSG G DRUG
S PSATQTY=+Y D TO
;
CHK I '$D(^PSD(58.8,PSATO,1,PSADRG,0)) W $C(7),!!,PSATON," does not stock ",PSADRGN,"!",! D ADD G:'PSADD DRUG
ASK ;ask ok
W !,PSASLN,!,$P($G(^PSDRUG(PSADRG,0)),"^"),!,"Transferring: ",PSATQTY," (",$P($G(^PSDRUG(PSADRG,660)),"^",8),")",!!,"From: ",PSAFROMN,!,"To : ",PSATON,!,PSASLN,!
K DIR,DIRUT S DIR(0)="Y",DIR("A")="OK to post",DIR("B")="Yes",DIR("?")="Answer 'YES' to post this transfer, 'NO' or '^' to quit.",DIR("??")="^D HELP^PSATRAN"
D ^DIR K DIR I 'Y!$D(DIRUT) D MSG G DRUG
D:PSADD ADD1 D ^PSATRAN1 G:'PSAOUT DRUG
;
EXIT I $O(^TMP("PSASIG",$J,0)) D
.W ! S DIR(0)="Y",DIR("A")="Print transfer signature sheets",DIR("B")="Y",DIR("?",1)="Enter YES to print transfer signature sheets for the transfers just entered."
.S DIR("?")="Enter NO to bypass printing the sheets then exit the option.",DIR("??")="^D PRINTYN^PSATRAN" D ^DIR K DIR Q:$G(DIRUT)!('+Y)
.D ^PSASIG
;
KILL K %,DA,DIC,DIE,DINUM,DIR,DIRUT,DTOUT,DUOUT,PSABAL,PSACHK,PSACNT,PSADD,PSADISP,PSADJ,PSADRG,PSADRGN,PSADT,PSADU,PSADUZ,PSADUZN,PSAFRDA,PSAFROM,PSAFROMN
K PSAJJ,PSALCNT,PSALES,PSALOC,PSALOCA,PSALOCN,PSANODE,PSARDT,PSAREC,PSAREPRT,PSARET,PSASEL,PSASLN,PSAOUT
K PSATEMP,PSATF,PSATODA,PSATO,PSATON,PSATQTY,PSATRAN,X,X1,X2,XMDUZ,XMSUB,XMTEXT,XMY,Y,YY
Q
MSG W $C(7),!!,"No action taken.",! H 1
Q
ADD ;ask to add drug
K DIR,DIRUT S DIR(0)="Y",DIR("A")="Do you want to continue",DIR("?")="Answer 'YES' to continue with this transfer, 'NO' or '^' to quit.",DIR("??")="^D HELP^PSATRAN"
D ^DIR K DIR I $G(DIRUT) D MSG Q
S PSADD=+Y
Q
ADD1 ;add drug
Q:$D(^PSD(58.8,PSATO,1,PSADRG,0))
S:'$D(^PSD(58.8,PSATO,1,0)) ^PSD(58.8,PSATO,1,0)="^58.8001IP^^"
K DA,DD,DO S DIC(0)="L",DIC="^PSD(58.8,"_+PSATO_",1,",DA(1)=+PSATO,(X,DINUM)=+PSADRG D FILE^DICN K DA,DIC
Q
;
TO ;transfer TO pharmacy
K PSALOCA(PSAFROMN),DA
S PSACNT=0,PSATON="" F S PSATON=$O(PSALOCA(PSATON)) Q:PSATON="" S PSACNT=PSACNT+1
I PSACNT=1 S PSATON=$O(PSALOCA("")),PSATO=+$O(PSALOCA(PSATON,0)) Q:'$G(PSAREPRT)
;
S PSACNT=0,PSATRAN="T" W ! D DISP^PSAUTL3 G:PSAOUT EXIT S PSACNT=0,PSACHK=$O(PSALOC(""))
S PSATO=+PSALOC,PSATON=PSALOCN
Q
HELP ;Extended help for 'Do you want to continue?'
W !?5,"Enter YES if it is okay to transfer this drug. Enter NO to abort the transfer."
Q
PRINTYN ;Extended help for 'Print transfer signature sheets?'
W !?5,"Enter YES if you want to print sheets that can be carried with the drugs",!?5,"to the receiving pharmacy for signature. The person signing the sheet is",!?5,"signing that he/she received the drug(s)."
W !!?5,"Enter NO if you do not want to print the signature sheets. You will exit",!?5,"from the option."
Q
QTYHELP ;Extended help for 'Enter Quantity to Transfer'
W !?5,"Enter the number of dispense units to be transferred out of the",!?5,"pharmacy location. Enter a whole number between 1 and "_PSABAL_"."
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSATRAN 4640 printed Sep 23, 2025@19:26:42 Page 2
PSATRAN ;BIR/JMB-Transfer Drugs between Pharmacies ;8/21/97
+1 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;; 10/24/97
+2 ;
+3 IF $DATA(^XUSEC("PSAMGR",DUZ))
IF '$DATA(^XUSEC("PSJ RPHARM",DUZ))
WRITE !!,"** Contact your Pharmacy Coordinator for access to transfer drugs between",!,?4,"pharmacies. PSAMGR and PSJ RPHARM security keys are required.",!
QUIT
+4 SET PSADUZ=DUZ
SET PSADUZN=$PIECE($GET(^VA(200,PSADUZ,0)),"^")
DO SIG^XUSESIG
if X1=""
GOTO EXIT
FROM ;select FROM pharmacy
+1 SET (PSADD,PSACNT,PSAOUT)=0
SET PSASLN=""
SET $PIECE(PSASLN,"-",80)=""
SET PSATRAN="F"
+2 DO ^PSAUTL3
if PSAOUT
GOTO EXIT
SET PSACHK=$ORDER(PSALOC(""))
+3 IF PSACHK=""
IF 'PSALOC
WRITE !,"There are no active pharmacy locations."
GOTO EXIT
+4 SET PSAFROM=+PSALOC
SET PSAFROMN=PSALOCN
DRUG ;select drug
+1 IF '$ORDER(^PSD(58.8,PSAFROM,1,0))
WRITE !!,"There are no drugs in the transferring pharmacy.",!!
GOTO EXIT
+2 WRITE @IOF,!,PSAFROMN
+3 KILL DA,DIC
SET DIC("W")="W:$P(^PSDRUG(Y,0),""^"",9) "" N/F"" I $P(^PSD(58.8,PSAFROM,1,Y,0),""^"",14)]"""",$P(^(0),""^"",14)'>DT W $C(7),"" *** INACTIVE ***"""
+4 SET DIC("A")="Select DRUG: "
SET DA(1)=+PSAFROM
SET DIC(0)="QEAM"
SET DIC="^PSD(58.8,"_PSAFROM_",1,"
+5 DO ^DIC
KILL DIC
if Y<0
GOTO FROM
IF ($DATA(DTOUT))!($DATA(DUOUT))
GOTO EXIT
+6 if Y<0
GOTO FROM
+7 SET PSADRG=+Y
SET PSADRGN=$PIECE($GET(^PSDRUG(PSADRG,0)),"^")
SET PSABAL=+$PIECE($GET(^PSD(58.8,PSAFROM,1,PSADRG,0)),"^",4)
+8 IF PSABAL'>0
WRITE $CHAR(7),!!,PSADRGN," has a "_$SELECT(PSABAL=0:"zero",1:"negative")_" balance.",!,"Select another drug to transfer."
GOTO DRUG
QTY ;enter quantity
+1 SET PSADU=$SELECT($PIECE($GET(^PSDRUG(PSADRG,660)),"^",8)'="":$PIECE($GET(^PSDRUG(PSADRG,660)),"^",8),1:"Unknown")
+2 WRITE !!,?5,"Dispense Unit: ",PSADU,?35,"Current Balance: "_PSABAL,!
+3 SET DIR(0)="NO^1:"_PSABAL_":0"
SET DIR("A")="Enter Quantity to Transfer"
SET DIR("?")="Enter a whole number between 1 and "_PSABAL
SET DIR("??")="^D QTYHELP^PSATRAN"
+4 DO ^DIR
KILL DIR
IF $GET(DIRUT)
DO MSG
GOTO DRUG
+5 SET PSATQTY=+Y
DO TO
+6 ;
CHK IF '$DATA(^PSD(58.8,PSATO,1,PSADRG,0))
WRITE $CHAR(7),!!,PSATON," does not stock ",PSADRGN,"!",!
DO ADD
if 'PSADD
GOTO DRUG
ASK ;ask ok
+1 WRITE !,PSASLN,!,$PIECE($GET(^PSDRUG(PSADRG,0)),"^"),!,"Transferring: ",PSATQTY," (",$PIECE($GET(^PSDRUG(PSADRG,660)),"^",8),")",!!,"From: ",PSAFROMN,!,"To : ",PSATON,!,PSASLN,!
+2 KILL DIR,DIRUT
SET DIR(0)="Y"
SET DIR("A")="OK to post"
SET DIR("B")="Yes"
SET DIR("?")="Answer 'YES' to post this transfer, 'NO' or '^' to quit."
SET DIR("??")="^D HELP^PSATRAN"
+3 DO ^DIR
KILL DIR
IF 'Y!$DATA(DIRUT)
DO MSG
GOTO DRUG
+4 if PSADD
DO ADD1
DO ^PSATRAN1
if 'PSAOUT
GOTO DRUG
+5 ;
EXIT IF $ORDER(^TMP("PSASIG",$JOB,0))
Begin DoDot:1
+1 WRITE !
SET DIR(0)="Y"
SET DIR("A")="Print transfer signature sheets"
SET DIR("B")="Y"
SET DIR("?",1)="Enter YES to print transfer signature sheets for the transfers just entered."
+2 SET DIR("?")="Enter NO to bypass printing the sheets then exit the option."
SET DIR("??")="^D PRINTYN^PSATRAN"
DO ^DIR
KILL DIR
if $GET(DIRUT)!('+Y)
QUIT
+3 DO ^PSASIG
End DoDot:1
+4 ;
KILL KILL %,DA,DIC,DIE,DINUM,DIR,DIRUT,DTOUT,DUOUT,PSABAL,PSACHK,PSACNT,PSADD,PSADISP,PSADJ,PSADRG,PSADRGN,PSADT,PSADU,PSADUZ,PSADUZN,PSAFRDA,PSAFROM,PSAFROMN
+1 KILL PSAJJ,PSALCNT,PSALES,PSALOC,PSALOCA,PSALOCN,PSANODE,PSARDT,PSAREC,PSAREPRT,PSARET,PSASEL,PSASLN,PSAOUT
+2 KILL PSATEMP,PSATF,PSATODA,PSATO,PSATON,PSATQTY,PSATRAN,X,X1,X2,XMDUZ,XMSUB,XMTEXT,XMY,Y,YY
+3 QUIT
MSG WRITE $CHAR(7),!!,"No action taken.",!
HANG 1
+1 QUIT
ADD ;ask to add drug
+1 KILL DIR,DIRUT
SET DIR(0)="Y"
SET DIR("A")="Do you want to continue"
SET DIR("?")="Answer 'YES' to continue with this transfer, 'NO' or '^' to quit."
SET DIR("??")="^D HELP^PSATRAN"
+2 DO ^DIR
KILL DIR
IF $GET(DIRUT)
DO MSG
QUIT
+3 SET PSADD=+Y
+4 QUIT
ADD1 ;add drug
+1 if $DATA(^PSD(58.8,PSATO,1,PSADRG,0))
QUIT
+2 if '$DATA(^PSD(58.8,PSATO,1,0))
SET ^PSD(58.8,PSATO,1,0)="^58.8001IP^^"
+3 KILL DA,DD,DO
SET DIC(0)="L"
SET DIC="^PSD(58.8,"_+PSATO_",1,"
SET DA(1)=+PSATO
SET (X,DINUM)=+PSADRG
DO FILE^DICN
KILL DA,DIC
+4 QUIT
+5 ;
TO ;transfer TO pharmacy
+1 KILL PSALOCA(PSAFROMN),DA
+2 SET PSACNT=0
SET PSATON=""
FOR
SET PSATON=$ORDER(PSALOCA(PSATON))
if PSATON=""
QUIT
SET PSACNT=PSACNT+1
+3 IF PSACNT=1
SET PSATON=$ORDER(PSALOCA(""))
SET PSATO=+$ORDER(PSALOCA(PSATON,0))
if '$GET(PSAREPRT)
QUIT
+4 ;
+5 SET PSACNT=0
SET PSATRAN="T"
WRITE !
DO DISP^PSAUTL3
if PSAOUT
GOTO EXIT
SET PSACNT=0
SET PSACHK=$ORDER(PSALOC(""))
+6 SET PSATO=+PSALOC
SET PSATON=PSALOCN
+7 QUIT
HELP ;Extended help for 'Do you want to continue?'
+1 WRITE !?5,"Enter YES if it is okay to transfer this drug. Enter NO to abort the transfer."
+2 QUIT
PRINTYN ;Extended help for 'Print transfer signature sheets?'
+1 WRITE !?5,"Enter YES if you want to print sheets that can be carried with the drugs",!?5,"to the receiving pharmacy for signature. The person signing the sheet is",!?5,"signing that he/she received the drug(s)."
+2 WRITE !!?5,"Enter NO if you do not want to print the signature sheets. You will exit",!?5,"from the option."
+3 QUIT
QTYHELP ;Extended help for 'Enter Quantity to Transfer'
+1 WRITE !?5,"Enter the number of dispense units to be transferred out of the",!?5,"pharmacy location. Enter a whole number between 1 and "_PSABAL_"."
+2 QUIT
