PSAUTL3 ;BIR/JMB-Upload and Process Prime Vendor Invoice Data Utility - CONT'D ;7/23/97
;;3.0;DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**49**; 10/24/97
;This utility displays locations & allows user to select one, many, or
;all locations.
;
S PSALOC=+$O(^PSD(58.8,"ADISP","P",0))
I 'PSALOC W !!?5,"No Drug Accountability location has been created yet." S PSAOUT=1 G EXIT
;
ORDER ;If more than one pharmacy location, collect them in alpha order.
S (PSACNT,PSALOC)=0 W !
F S PSALOC=+$O(^PSD(58.8,"ADISP","P",PSALOC)) Q:'PSALOC D
.Q:'$D(^PSD(58.8,PSALOC,0))!($P($G(^PSD(58.8,PSALOC,0)),"^")="")
.I +$G(^PSD(58.8,PSALOC,"I")),+^PSD(58.8,PSALOC,"I")'>DT Q
.I '$D(PSATRAN) Q:'$O(^PSD(58.8,PSALOC,1,0))
.;VMP OIFO BAY PINES;ELR;PSA*3*49
.S (PSAOSIT,PSAOSITN)=""
.D SITES^PSAUTL1
.S PSACNT=PSACNT+1,PSAONE=+PSALOC
.S PSALOCA($P(^PSD(58.8,PSALOC,0),"^")_PSACOMB,PSALOC)=$P(^(0),"^",3)_"^"_$P(^(0),"^",10)_"^"_$P($G(^PSD(58.8,PSALOC,"I")),"^")
I PSACNT=1 G:$G(PSATRAN)="" ONE W !?5,"There is only one active pharmacy location.",!?5,"There must be at least two to transfer drugs." S PSAOUT=1 Q
S PSACHK=$O(PSALOCA("")) I PSACHK="" G EXIT
G DISP
;
ONE ;only one
S PSALOC=PSAONE
I '$D(^PSD(58.8,PSALOC,0))!($P($G(^PSD(58.8,PSALOC,0)),"^")="") W !,"There are no Drug Accountability pharmacy locations with data." Q
S PSALOCN="",PSALOCN=$O(PSALOCA(PSALOCN)) Q:PSALOCN="" S PSALOC=0,PSALOC=+$O(PSALOCA(PSALOCN,PSALOC)) Q:'PSALOC S PSALOC(PSALOCN,PSALOC)=PSALOCA(PSALOCN,PSALOC)
G EXIT
;
DISP ;Displays the available pharmacy locations.
W @IOF,!
W:$G(PSATRAN)="F" "Choose the pharmacy location transferring the drugs:"
W:$G(PSATRAN)="T" "Choose the pharmacy location receiving the transferred drugs:"
W:$G(PSATRAN)="" "Choose one or many pharmacy locations:"
W ! S PSACNT=0,PSALOCN=""
F S PSALOCN=$O(PSALOCA(PSALOCN)) Q:PSALOCN="" D
.S PSALOC=0 F S PSALOC=+$O(PSALOCA(PSALOCN,PSALOC)) Q:'PSALOC D
..S PSACNT=PSACNT+1,PSAMENU(PSACNT,PSALOCN,PSALOC)=""
..W !,$J(PSACNT,2)
..W:$L(PSALOCN)>76 ?4,$P(PSALOCN,"(IP)",1)_"(IP)",!?21,$P(PSALOCN,"(IP)",2) W:$L(PSALOCN)<77 ?4,PSALOCN
W !
;
SELECT I $G(PSATRAN)="" S DIR(0)="L^1:"_PSACNT,DIR("A")="Select PHARMACY LOCATION",DIR("??")="^D HELP^PSAUTL3"
I $G(PSATRAN)="F"!($G(PSATRAN)="T") S DIR(0)="N^1:"_PSACNT D
.I $G(PSATRAN)="F" S DIR("A")="Select Transfer from Pharmacy",DIR("??")="^D FROMHELP^PSAUTL3"
.I $G(PSATRAN)="T" S DIR(0)="N^1:"_PSACNT,DIR("A")="Select Transfer to Pharmacy",DIR("??")="^D TOHELP^PSAUTL3"
S DIR("?")="Enter the number(s) of the pharmacy location"
D ^DIR K DIR I 'Y S PSAOUT=1 G EXIT
S PSASEL=Y F PSAPC=1:1 S PSANUM=+$P(PSASEL,",",PSAPC) Q:'PSANUM D
.S PSALOCN=$O(PSAMENU(PSANUM,"")),PSALOC=+$O(PSAMENU(PSANUM,PSALOCN,0))
.S PSALOC(PSALOCN,PSALOC)=PSALOCA(PSALOCN,PSALOC)
;
EXIT ;Kills all variables except PSALOC array & PSAOUT
K DIR,PSACOMB,PSAISIT,PSAISITN,PSAMENU,PSAONE,PSANUM,PSAOSIT,PSAOSITN,PSAPC,Y
Q
;
FROMHELP ;Extended help to 'Select Transfer from Pharmacy'
W !?5,"Enter the number of the pharmacy location that will transfer the drugs to another pharmacy."
Q
HELP ;Extended help to 'Select PHARMACY LOCATION'
W !?5,"Enter the number of the pharmacy location you want to select.",!?5,"If you want more than one pharmacy location, enter the numbers",!?5,"separated by a comma."
W !!?5,"For example: Enter 1,3 or 1-3,5."
Q
TOHELP ;Extended help to 'Select Transfer to Pharmacy'
W !?5,"Enter the number of the pharmacy location that will receive the transferred the drugs."
Q
;
SETAORD ;Set logic for "AORD" X-Ref
S PSADA(1)=$O(^PSD(58.811,"B",X,0))
S PSADA=0 F S PSADA=$O(^PSD(58.811,PSADA(1),1,PSADA)) Q:'PSADA D
.S ^PSD(58.811,"AORD",X,$P($G(^PSD(58.811,PSADA(1),1,PSADA,0)),"^"),PSADA(1),PSADA)=""
K PSADA
Q
KILLAORD ;Kill logic for "AORD" X-Ref
K ^PSD(58.811,"AORD",X)
Q
;
SLOC ;Set logic for "ALOC" X-Ref on Pharmacy Location & Master Vault fields
Q:'+$P($G(^PSD(58.811,DA(1),1,DA,0)),"^",2)
S ^PSD(58.811,"ALOC",X,+$P($G(^PSD(58.811,DA(1),1,DA,0)),"^",2),DA(1),DA)=""
Q
KLOC ;Kill logic for "ALOC" X-Ref on Pharmacy Location & Master Vault fields
K ^PSD(58.811,"ALOC",X,+$P($G(^PSD(58.811,DA(1),1,DA,0)),"^",2),DA(1),DA)
Q
;
SLOCDT ;Set logic for "ALOC" X-Ref on Invoice Date field
S:+$P($G(^PSD(58.811,DA(1),1,DA,0)),"^",5) ^PSD(58.811,"ALOC",+$P($G(^PSD(58.811,DA(1),1,DA,0)),"^",5),X,DA(1),DA)=""
S:+$P($G(^PSD(58.811,DA(1),1,DA,0)),"^",12) ^PSD(58.811,"ALOC",+$P($G(^PSD(58.811,DA(1),1,DA,0)),"^",12),X,DA(1),DA)=""
Q
KLOCDT ;Kill logic for "ALOC" X-Ref
K ^PSD(58.811,"ALOC",+$P($G(^PSD(58.811,DA(1),1,DA,0)),"^",5),X,DA(1),DA)
K ^PSD(58.811,"ALOC",+$P($G(^PSD(58.811,DA(1),1,DA,0)),"^",12),X,DA(1),DA)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSAUTL3 4756 printed Apr 09, 2024@20:54:49 Page 2
PSAUTL3 ;BIR/JMB-Upload and Process Prime Vendor Invoice Data Utility - CONT'D ;7/23/97
+1 ;;3.0;DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**49**; 10/24/97
+2 ;This utility displays locations & allows user to select one, many, or
+3 ;all locations.
+4 ;
+5 SET PSALOC=+$ORDER(^PSD(58.8,"ADISP","P",0))
+6 IF 'PSALOC
WRITE !!?5,"No Drug Accountability location has been created yet."
SET PSAOUT=1
GOTO EXIT
+7 ;
ORDER ;If more than one pharmacy location, collect them in alpha order.
+1 SET (PSACNT,PSALOC)=0
WRITE !
+2 FOR
SET PSALOC=+$ORDER(^PSD(58.8,"ADISP","P",PSALOC))
if 'PSALOC
QUIT
Begin DoDot:1
+3 if '$DATA(^PSD(58.8,PSALOC,0))!($PIECE($GET(^PSD(58.8,PSALOC,0)),"^")="")
QUIT
+4 IF +$GET(^PSD(58.8,PSALOC,"I"))
IF +^PSD(58.8,PSALOC,"I")'>DT
QUIT
+5 IF '$DATA(PSATRAN)
if '$ORDER(^PSD(58.8,PSALOC,1,0))
QUIT
+6 ;VMP OIFO BAY PINES;ELR;PSA*3*49
+7 SET (PSAOSIT,PSAOSITN)=""
+8 DO SITES^PSAUTL1
+9 SET PSACNT=PSACNT+1
SET PSAONE=+PSALOC
+10 SET PSALOCA($PIECE(^PSD(58.8,PSALOC,0),"^")_PSACOMB,PSALOC)=$PIECE(^(0),"^",3)_"^"_$PIECE(^(0),"^",10)_"^"_$PIECE($GET(^PSD(58.8,PSALOC,"I")),"^")
End DoDot:1
+11 IF PSACNT=1
if $GET(PSATRAN)=""
GOTO ONE
WRITE !?5,"There is only one active pharmacy location.",!?5,"There must be at least two to transfer drugs."
SET PSAOUT=1
QUIT
+12 SET PSACHK=$ORDER(PSALOCA(""))
IF PSACHK=""
GOTO EXIT
+13 GOTO DISP
+14 ;
ONE ;only one
+1 SET PSALOC=PSAONE
+2 IF '$DATA(^PSD(58.8,PSALOC,0))!($PIECE($GET(^PSD(58.8,PSALOC,0)),"^")="")
WRITE !,"There are no Drug Accountability pharmacy locations with data."
QUIT
+3 SET PSALOCN=""
SET PSALOCN=$ORDER(PSALOCA(PSALOCN))
if PSALOCN=""
QUIT
SET PSALOC=0
SET PSALOC=+$ORDER(PSALOCA(PSALOCN,PSALOC))
if 'PSALOC
QUIT
SET PSALOC(PSALOCN,PSALOC)=PSALOCA(PSALOCN,PSALOC)
+4 GOTO EXIT
+5 ;
DISP ;Displays the available pharmacy locations.
+1 WRITE @IOF,!
+2 if $GET(PSATRAN)="F"
WRITE "Choose the pharmacy location transferring the drugs:"
+3 if $GET(PSATRAN)="T"
WRITE "Choose the pharmacy location receiving the transferred drugs:"
+4 if $GET(PSATRAN)=""
WRITE "Choose one or many pharmacy locations:"
+5 WRITE !
SET PSACNT=0
SET PSALOCN=""
+6 FOR
SET PSALOCN=$ORDER(PSALOCA(PSALOCN))
if PSALOCN=""
QUIT
Begin DoDot:1
+7 SET PSALOC=0
FOR
SET PSALOC=+$ORDER(PSALOCA(PSALOCN,PSALOC))
if 'PSALOC
QUIT
Begin DoDot:2
+8 SET PSACNT=PSACNT+1
SET PSAMENU(PSACNT,PSALOCN,PSALOC)=""
+9 WRITE !,$JUSTIFY(PSACNT,2)
+10 if $LENGTH(PSALOCN)>76
WRITE ?4,$PIECE(PSALOCN,"(IP)",1)_"(IP)",!?21,$PIECE(PSALOCN,"(IP)",2)
if $LENGTH(PSALOCN)<77
WRITE ?4,PSALOCN
End DoDot:2
End DoDot:1
+11 WRITE !
+12 ;
SELECT IF $GET(PSATRAN)=""
SET DIR(0)="L^1:"_PSACNT
SET DIR("A")="Select PHARMACY LOCATION"
SET DIR("??")="^D HELP^PSAUTL3"
+1 IF $GET(PSATRAN)="F"!($GET(PSATRAN)="T")
SET DIR(0)="N^1:"_PSACNT
Begin DoDot:1
+2 IF $GET(PSATRAN)="F"
SET DIR("A")="Select Transfer from Pharmacy"
SET DIR("??")="^D FROMHELP^PSAUTL3"
+3 IF $GET(PSATRAN)="T"
SET DIR(0)="N^1:"_PSACNT
SET DIR("A")="Select Transfer to Pharmacy"
SET DIR("??")="^D TOHELP^PSAUTL3"
End DoDot:1
+4 SET DIR("?")="Enter the number(s) of the pharmacy location"
+5 DO ^DIR
KILL DIR
IF 'Y
SET PSAOUT=1
GOTO EXIT
+6 SET PSASEL=Y
FOR PSAPC=1:1
SET PSANUM=+$PIECE(PSASEL,",",PSAPC)
if 'PSANUM
QUIT
Begin DoDot:1
+7 SET PSALOCN=$ORDER(PSAMENU(PSANUM,""))
SET PSALOC=+$ORDER(PSAMENU(PSANUM,PSALOCN,0))
+8 SET PSALOC(PSALOCN,PSALOC)=PSALOCA(PSALOCN,PSALOC)
End DoDot:1
+9 ;
EXIT ;Kills all variables except PSALOC array & PSAOUT
+1 KILL DIR,PSACOMB,PSAISIT,PSAISITN,PSAMENU,PSAONE,PSANUM,PSAOSIT,PSAOSITN,PSAPC,Y
+2 QUIT
+3 ;
FROMHELP ;Extended help to 'Select Transfer from Pharmacy'
+1 WRITE !?5,"Enter the number of the pharmacy location that will transfer the drugs to another pharmacy."
+2 QUIT
HELP ;Extended help to 'Select PHARMACY LOCATION'
+1 WRITE !?5,"Enter the number of the pharmacy location you want to select.",!?5,"If you want more than one pharmacy location, enter the numbers",!?5,"separated by a comma."
+2 WRITE !!?5,"For example: Enter 1,3 or 1-3,5."
+3 QUIT
TOHELP ;Extended help to 'Select Transfer to Pharmacy'
+1 WRITE !?5,"Enter the number of the pharmacy location that will receive the transferred the drugs."
+2 QUIT
+3 ;
SETAORD ;Set logic for "AORD" X-Ref
+1 SET PSADA(1)=$ORDER(^PSD(58.811,"B",X,0))
+2 SET PSADA=0
FOR
SET PSADA=$ORDER(^PSD(58.811,PSADA(1),1,PSADA))
if 'PSADA
QUIT
Begin DoDot:1
+3 SET ^PSD(58.811,"AORD",X,$PIECE($GET(^PSD(58.811,PSADA(1),1,PSADA,0)),"^"),PSADA(1),PSADA)=""
End DoDot:1
+4 KILL PSADA
+5 QUIT
KILLAORD ;Kill logic for "AORD" X-Ref
+1 KILL ^PSD(58.811,"AORD",X)
+2 QUIT
+3 ;
SLOC ;Set logic for "ALOC" X-Ref on Pharmacy Location & Master Vault fields
+1 if '+$PIECE($GET(^PSD(58.811,DA(1),1,DA,0)),"^",2)
QUIT
+2 SET ^PSD(58.811,"ALOC",X,+$PIECE($GET(^PSD(58.811,DA(1),1,DA,0)),"^",2),DA(1),DA)=""
+3 QUIT
KLOC ;Kill logic for "ALOC" X-Ref on Pharmacy Location & Master Vault fields
+1 KILL ^PSD(58.811,"ALOC",X,+$PIECE($GET(^PSD(58.811,DA(1),1,DA,0)),"^",2),DA(1),DA)
+2 QUIT
+3 ;
SLOCDT ;Set logic for "ALOC" X-Ref on Invoice Date field
+1 if +$PIECE($GET(^PSD(58.811,DA(1),1,DA,0)),"^",5)
SET ^PSD(58.811,"ALOC",+$PIECE($GET(^PSD(58.811,DA(1),1,DA,0)),"^",5),X,DA(1),DA)=""
+2 if +$PIECE($GET(^PSD(58.811,DA(1),1,DA,0)),"^",12)
SET ^PSD(58.811,"ALOC",+$PIECE($GET(^PSD(58.811,DA(1),1,DA,0)),"^",12),X,DA(1),DA)=""
+3 QUIT
KLOCDT ;Kill logic for "ALOC" X-Ref
+1 KILL ^PSD(58.811,"ALOC",+$PIECE($GET(^PSD(58.811,DA(1),1,DA,0)),"^",5),X,DA(1),DA)
+2 KILL ^PSD(58.811,"ALOC",+$PIECE($GET(^PSD(58.811,DA(1),1,DA,0)),"^",12),X,DA(1),DA)
+3 QUIT
