PSAUTL5 ;BIR/JMB-Upload and Process Prime Vendor Invoice Data Utility - CONT'D ;7/23/97
;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**21**; 10/24/97
;This utility displays locations & allows user to select one, many, or
;all locations.
K PSALOCA,PSAMNU
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
.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 ! 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,PSAMNU(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 S DIR(0)="L^1:"_PSACNT,DIR("A")="Select PHARMACY LOCATION",DIR("??")="^D HELP^PSAUTL3"
S DIR("?")="Enter the number of the pharmacy location"
D ^DIR K DIR I 'Y S PSAOUT=1 G EXIT
S PSASL=Y F PSAPCC=1:1 S PSANUM=+$P(PSASL,",",PSAPCC) Q:'PSANUM D
.S PSALOCN=$O(PSAMNU(PSANUM,"")),PSALOC=+$O(PSAMNU(PSANUM,PSALOCN,0))
.S PSALOC(PSALOCN,PSALOC)=PSALOCA(PSALOCN,PSALOC)
;
EXIT ;Kills all variables except PSALOC array & PSAOUT
;K DIR,PSACOMB,PSAISIT,PSAISITN,PSAMNU,PSAONE,PSANUM,PSAOSIT,PSAOSITN,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[HPSAUTL5 4131 printed Dec 13, 2024@01:50:58 Page 2
PSAUTL5 ;BIR/JMB-Upload and Process Prime Vendor Invoice Data Utility - CONT'D ;7/23/97
+1 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**21**; 10/24/97
+2 ;This utility displays locations & allows user to select one, many, or
+3 ;all locations.
+4 KILL PSALOCA,PSAMNU
+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 DO SITES^PSAUTL1
+6 SET PSACNT=PSACNT+1
SET PSAONE=+PSALOC
+7 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
+8 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
+9 SET PSACHK=$ORDER(PSALOCA(""))
IF PSACHK=""
GOTO EXIT
+10 GOTO DISP
+11 ;
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 !
SET PSACNT=0
SET PSALOCN=""
+2 FOR
SET PSALOCN=$ORDER(PSALOCA(PSALOCN))
if PSALOCN=""
QUIT
Begin DoDot:1
+3 SET PSALOC=0
FOR
SET PSALOC=+$ORDER(PSALOCA(PSALOCN,PSALOC))
if 'PSALOC
QUIT
Begin DoDot:2
+4 SET PSACNT=PSACNT+1
SET PSAMNU(PSACNT,PSALOCN,PSALOC)=""
+5 WRITE !,$JUSTIFY(PSACNT,2)
+6 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
+7 WRITE !
+8 ;
SELECT SET DIR(0)="L^1:"_PSACNT
SET DIR("A")="Select PHARMACY LOCATION"
SET DIR("??")="^D HELP^PSAUTL3"
+1 SET DIR("?")="Enter the number of the pharmacy location"
+2 DO ^DIR
KILL DIR
IF 'Y
SET PSAOUT=1
GOTO EXIT
+3 SET PSASL=Y
FOR PSAPCC=1:1
SET PSANUM=+$PIECE(PSASL,",",PSAPCC)
if 'PSANUM
QUIT
Begin DoDot:1
+4 SET PSALOCN=$ORDER(PSAMNU(PSANUM,""))
SET PSALOC=+$ORDER(PSAMNU(PSANUM,PSALOCN,0))
+5 SET PSALOC(PSALOCN,PSALOC)=PSALOCA(PSALOCN,PSALOC)
End DoDot:1
+6 ;
EXIT ;Kills all variables except PSALOC array & PSAOUT
+1 ;K DIR,PSACOMB,PSAISIT,PSAISITN,PSAMNU,PSAONE,PSANUM,PSAOSIT,PSAOSITN,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
