Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSAUTL5

PSAUTL5.m

Go to the documentation of this file.
  1. 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
  1. ;This utility displays locations & allows user to select one, many, or
  1. ;all locations.
  1. K PSALOCA,PSAMNU
  1. S PSALOC=+$O(^PSD(58.8,"ADISP","P",0))
  1. I 'PSALOC W !!?5,"No Drug Accountability location has been created yet." S PSAOUT=1 G EXIT
  1. ;
  1. ORDER ;If more than one pharmacy location, collect them in alpha order.
  1. S (PSACNT,PSALOC)=0 W !
  1. F S PSALOC=+$O(^PSD(58.8,"ADISP","P",PSALOC)) Q:'PSALOC D
  1. .Q:'$D(^PSD(58.8,PSALOC,0))!($P($G(^PSD(58.8,PSALOC,0)),"^")="")
  1. .I +$G(^PSD(58.8,PSALOC,"I")),+^PSD(58.8,PSALOC,"I")'>DT Q
  1. .D SITES^PSAUTL1
  1. .S PSACNT=PSACNT+1,PSAONE=+PSALOC
  1. .S PSALOCA($P(^PSD(58.8,PSALOC,0),"^")_PSACOMB,PSALOC)=$P(^(0),"^",3)_"^"_$P(^(0),"^",10)_"^"_$P($G(^PSD(58.8,PSALOC,"I")),"^")
  1. 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
  1. S PSACHK=$O(PSALOCA("")) I PSACHK="" G EXIT
  1. G DISP
  1. ;
  1. ONE ;only one
  1. S PSALOC=PSAONE
  1. 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
  1. 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)
  1. G EXIT
  1. ;
  1. DISP ;Displays the available pharmacy locations.
  1. W ! S PSACNT=0,PSALOCN=""
  1. F S PSALOCN=$O(PSALOCA(PSALOCN)) Q:PSALOCN="" D
  1. .S PSALOC=0 F S PSALOC=+$O(PSALOCA(PSALOCN,PSALOC)) Q:'PSALOC D
  1. ..S PSACNT=PSACNT+1,PSAMNU(PSACNT,PSALOCN,PSALOC)=""
  1. ..W !,$J(PSACNT,2)
  1. ..W:$L(PSALOCN)>76 ?4,$P(PSALOCN,"(IP)",1)_"(IP)",!?21,$P(PSALOCN,"(IP)",2) W:$L(PSALOCN)<77 ?4,PSALOCN
  1. W !
  1. ;
  1. SELECT S DIR(0)="L^1:"_PSACNT,DIR("A")="Select PHARMACY LOCATION",DIR("??")="^D HELP^PSAUTL3"
  1. S DIR("?")="Enter the number of the pharmacy location"
  1. D ^DIR K DIR I 'Y S PSAOUT=1 G EXIT
  1. S PSASL=Y F PSAPCC=1:1 S PSANUM=+$P(PSASL,",",PSAPCC) Q:'PSANUM D
  1. .S PSALOCN=$O(PSAMNU(PSANUM,"")),PSALOC=+$O(PSAMNU(PSANUM,PSALOCN,0))
  1. .S PSALOC(PSALOCN,PSALOC)=PSALOCA(PSALOCN,PSALOC)
  1. ;
  1. EXIT ;Kills all variables except PSALOC array & PSAOUT
  1. ;K DIR,PSACOMB,PSAISIT,PSAISITN,PSAMNU,PSAONE,PSANUM,PSAOSIT,PSAOSITN,Y
  1. Q
  1. ;
  1. FROMHELP ;Extended help to 'Select Transfer from Pharmacy'
  1. W !?5,"Enter the number of the pharmacy location that will transfer the drugs to another pharmacy."
  1. Q
  1. HELP ;Extended help to 'Select PHARMACY LOCATION'
  1. 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."
  1. W !!?5,"For example: Enter 1,3 or 1-3,5."
  1. Q
  1. TOHELP ;Extended help to 'Select Transfer to Pharmacy'
  1. W !?5,"Enter the number of the pharmacy location that will receive the transferred the drugs."
  1. Q
  1. ;
  1. SETAORD ;Set logic for "AORD" X-Ref
  1. S PSADA(1)=$O(^PSD(58.811,"B",X,0))
  1. S PSADA=0 F S PSADA=$O(^PSD(58.811,PSADA(1),1,PSADA)) Q:'PSADA D
  1. .S ^PSD(58.811,"AORD",X,$P($G(^PSD(58.811,PSADA(1),1,PSADA,0)),"^"),PSADA(1),PSADA)=""
  1. K PSADA
  1. Q
  1. KILLAORD ;Kill logic for "AORD" X-Ref
  1. K ^PSD(58.811,"AORD",X)
  1. Q
  1. ;
  1. SLOC ;Set logic for "ALOC" X-Ref on Pharmacy Location & Master Vault fields
  1. Q:'+$P($G(^PSD(58.811,DA(1),1,DA,0)),"^",2)
  1. S ^PSD(58.811,"ALOC",X,+$P($G(^PSD(58.811,DA(1),1,DA,0)),"^",2),DA(1),DA)=""
  1. Q
  1. KLOC ;Kill logic for "ALOC" X-Ref on Pharmacy Location & Master Vault fields
  1. K ^PSD(58.811,"ALOC",X,+$P($G(^PSD(58.811,DA(1),1,DA,0)),"^",2),DA(1),DA)
  1. Q
  1. ;
  1. SLOCDT ;Set logic for "ALOC" X-Ref on Invoice Date field
  1. 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)=""
  1. 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)=""
  1. Q
  1. KLOCDT ;Kill logic for "ALOC" X-Ref
  1. K ^PSD(58.811,"ALOC",+$P($G(^PSD(58.811,DA(1),1,DA,0)),"^",5),X,DA(1),DA)
  1. K ^PSD(58.811,"ALOC",+$P($G(^PSD(58.811,DA(1),1,DA,0)),"^",12),X,DA(1),DA)
  1. Q