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

PSALOCO.m

Go to the documentation of this file. 
  1. PSALOCO ;BIR/MNT,DB-Set Up/Edit a Pharmacy Location ;7/23/97
  1.  ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**21**; 10/24/97
  1.  ;
  1.  ;References to ^PS(59, are covered under IA #212
  1.  ;References to ^PS(59.4, are covered under IA #2505
  1.  ;PSALOC = Internal entry number for location
  1.  ;References to ^PSDRUG( are covered by IA #2095
  1.  ;PSALOCN = Location Name
  1.  ;PSALOCA(PSALOCN,PSALOC)=ip site ^ Op site ^ more op sites
  1.  ;
  1.  K PSALOC
  1. PSAOPT W @IOF,!!,?20,"<<<< PHARMACY LOCATION OPTION SCREEN >>>>",! F X=1:1:(IOM-2) W "="
  1.  W !!,"#   OPTION NAME",!,"---------------",!,"1.  CHANGE LOCATION TYPE",!,"2.  CHANGE LOCATION NAME",!,"3.  INPATIENT SITE SELECTION (not available for Outpatient locations)"
  1.  W !,"4.  OUTPATIENT SITE SELECTION (not available for Inpatient locations)"
  1.  W !,"5.  IV ROOM SETUP ",!,"6.  WARD SETUP"
  1.  W !,"7.  INACTIVATE PHARMACY LOCATION",!,"8.  ADD/EDIT DRUGS",!,"9.  SET MAINTAIN REORDER LEVELS FLAG"
  1.  W !,"10. REACTIVATE A PHARMACY LOCATION."
  1.  W !,"11. CREATE NEW PHARMACY LOCATION"
  1. OPTASK W !!,"Select Option Number: " R AN:DTIME G Q:AN["^" G Q:AN="" G HLP:"?"[AN I AN<1!(AN>11) W !,"Please enter a number between 1 & 11." K AN G OPTASK
  1.  S PSAOPT=AN I AN="10" G 10
  1.  I PSAOPT="11" G ADD^PSALOC
  1.  I $G(PSALOC)="" D ^PSALOC G Q:$G(PSALOC)'>0 G @PSAOPT
  1. 1 S PSAHDR="CHANGE LOCATION TYPE" D HDR
  1.  D ^PSALOC2
  1.  G NXT
  1. 2 S PSAHDR="CHANGE LOCATION NAME" D HDR
  1.  W !,"The new location name must at least contain : " S PSACHKR=$S($E(PSALOCN)="C":"COMBINED (IP/OP)",$E(PSALOCN)="I":"INPATIENT",1:"OUTPATIENT") W PSACHKR
  1. ASK2 R !,"Please enter the new name  : ",AN:DTIME G NXT:AN["^" I AN="" W " ??? " G ASK2
  1.  S PSALOCN1=AN I $E(PSALOCN1,1,$L(PSACHKR))'=PSACHKR W !,"Sorry, the new name must start with "_PSACHKR G ASK2
  1.  I $D(^PSD(58.8,"B",PSALOCN1)) W !,"Sorry, this name is already setup." K PSALOCN1 G ASK2
  1.  S $P(^PSD(58.8,PSALOC,0),"^")=PSALOCN1
  1.  K ^PSD(58.8,"B",PSALOCN,PSALOC)
  1.  S ^PSD(58.8,"B",PSALOCN1,PSALOC)=""
  1.  S PSALOCA(PSALOCN1,PSALOC)=PSALOCA(PSALOCN,PSALOC)
  1.  S PSALOCA(PSALOCN1,PSALOC)=PSALOCA(PSALOCN,PSALOC)
  1.  S PSAMNU(PSANUM,PSALOCN1,PSALOC)=PSAMNU(PSANUM,PSALOCN,PSALOC) K PSAMNU(PSANUM,PSALOCN,PSALOC)
  1.  S PSALOCN=PSALOCN1 K PSALOCN1
  1.  G NXT
  1. 3 S PSAHDR="INPATIENT SITE SELECTION" D HDR
  1.  I $E(PSALOCN)="O" W !!,"Sorry, Inpatient Site association is not permitted for an Outpatient Location" G QUIT3
  1.  I $P($G(PSALOCA(PSALOCN,PSALOC)),"^")="" S (PSA(1),PSA(2))=0 G INP
  1.  S PSAISIT=$P($G(PSALOCA(PSALOCN,PSALOC)),"^")
  1.  S PSAISIT(1)=$P($G(^PS(59.4,PSAISIT,0)),"^") ;Inpatient Site Name
  1.  W !,"Inpatient Site          : ",$P($G(^PS(59.4,$P($G(PSALOCA(PSALOCN,PSALOC)),"^"),0)),"^")
  1.  W !,"Change this site? NO// " R AN:DTIME I AN["^" G QUIT3
  1.  S:AN="" AN="N" S AN=$E(AN) I "NnyY"'[AN W !,"Answer 'Y' for yes to change which Inpatient Site is associated with this",!,"pharmacy location.",!  D EOP G 3
  1.  I "nN"[AN G QUIT3
  1.  S PSAIVCHG=1
  1.  S (PSA(1),PSA(2))=0
  1. INP S PSA(1)=$O(^PS(59.4,PSA(1))) G INPQ:PSA(1)'>0 I $P($G(^PS(59.4,PSA(1),0)),"^",26)=1 S PSA(2)=PSA(2)+1,PSAB=PSA(1)
  1.  G INP
  1. INPQ ;End loop through inpatient file
  1.  I PSA(2)<1 W !,"An Inpatient Site has not been identified for AR/WS.",!,"AR/WS dispensing data cannot be gathered" G QUIT3
  1.  S:PSA(2)=1 PSAISIT=PSAB
  1.  I $G(PSAIVCHG)=1,PSA(2)=1 W !,"Sorry, but this is the only inpatient site in the Inpatient Site file ? ",! G QUIT3
  1.  D:PSA(2)>1  I Y<1 S PSAOU=1 G QUIT3
  1.  .W !!,"Because there is more than one Inpatient Site at this facility, I need you to",! S DIC="^PS(59.4,",DIC(0)="AEQMZ",DIC("A")="Select an AR/WS Inpatient Site Name : ",DIC("S")="I $P($G(^(0)),U,26)=1" D ^DIC S PSAISIT=+Y
  1.  .K DIC S:$D(DUOUT)!($D(DTOUT))!(X="") PSAERR=1 Q
  1.  .I PSAITY=3&(Y<1) S PSAOU=1 S PSAERR=1 Q
  1.  .S PSAISIT=+Y
  1.  I $G(PSAERR)=1 G QUIT3
  1.  S PSALOCI=0 F  S PSALOCI=$O(^PSD(58.8,"ASITE",PSAISIT,"P",PSALOCI)) Q:'PSALOCI  I '$P($G(^PSD(58.8,PSALOCI,"I")),"^") W !,"Already Assigned to : "_$P($G(^PSD(58.8,PSALOCI,0)),"^") S PSAERR=1
  1.  I $G(PSAERR)'>0,$G(PSAISIT)>0,$G(PSALOC)>0 S DIE="^PSD(58.8,",DA=PSALOC,DR="2////^S X=PSAISIT" D ^DIE S $P(PSALOCA(PSALOCN,PSALOC),"^")=PSAISIT
  1.  ;
  1. QUIT3 G NXT
  1. 4 S PSAHDR="OUTPATIENT SITE SELECTION" D HDR
  1.  I $E(PSALOCN)="I" W !!,"Sorry, Outpatient Site association is not permitted for an Inpatient Location.",! G QUIT4
  1.  I $G(PSAITY)=1 G QUIT4
  1.  S PSAOSIT=$P($G(PSALOCA(PSALOCN,PSALOC)),"^",2)
  1.  W !!,"Outpatient site selection affects the collection of dispensing data.",!,"When a prescription is released through Outpatient pharmacy, the data is stored "
  1.  W !,"then retrieved by the Drug Accountability back-ground job that runs each night.",!!
  1.  ;
  1. OPASK ;get Outpatient site(s)
  1.  I $G(PSAOSIT)'="" S PSAOSIT(1)=$P($G(^PS(59,PSAOSIT,0)),"^")
  1.  W !,"Primary Outpatient Site         : ",$S($G(PSAOSIT)="":"Unknown",1:$G(PSAOSIT(1)))
  1.  D OPSITES I $O(PSAOSIT(1))'="" W !,"Secondary Site(s)               : " F X=2:1 Q:$G(PSAOSIT(X))=""  I PSAOSIT(X)'=PSAOSIT W ?34,$P($G(^PS(59,PSAOSIT(X),0)),"^"),!
  1.  K DIC,DA,DO,DR,DIR,DIE
  1.  S DIC(0)="AEQMZL",DA(1)=PSALOC,DIC="^PSD(58.8,PSALOC,7,",DIC("A")="Select Outpatient Site: " D ^DIC
  1.  I +Y'>0 G QUIT4
  1.  ;Check for existence of op site in PSALOCA(PSALOCN,PSALOC)
  1.  S DA=+Y
  1.  S PSAOSIT=+Y,PSAOSIT(1)=Y(0,0),DIE="^PSD(58.8,PSALOC,7,",DR="1" D ^DIE
  1.  ;
  1.  I $P($G(PSALOCA(PSALOCN,PSALOC)),"^",2)="" S $P(PSALOCA(PSALOCN,PSALOC),"^",2)=PSAOSIT G QUIT4
  1.  S NOMATCH=0,CNTR=1 F X=2:1 Q:$G(PSAOSIT(X))=""  S CNTR=$G(CNTR)+1 I PSAOSIT(X)=+PSAOSIT S NOMATCH=1
  1.  I $G(NOMATCH)=0 S $P(PSALOCA(PSALOCN,PSALOC),"^",(CNTR+1))=+PSAOSIT
  1.  ;
  1. QUIT4 G NXT
  1. 5 S PSAHDR="IV ROOM SETUP" D HDR
  1.  D IV^PSAENTO
  1. QUIT5 G NXT
  1. 6 S PSAHDR="WARD LOCATION SETUP" D HDR
  1.  I $G(PSAISIT)'>0,$P(PSALOCA(PSALOCN,PSALOC),"^")'="" S PSAISIT=$P(PSALOCA(PSALOCN,PSALOC),"^")
  1.  I $G(PSAISIT)'>0 W !!,"Sorry, I cannot find an Inpatient Site associated with this location.",! G WARDQ
  1.  I $O(^PSD(58.8,+PSALOC,3,0))="" W !,"No wards are currently assigned to this location."
  1.  S PSAWARD=0 I $O(^PSD(58.8,+PSALOC,3,0)) W !,PSALOCN," is set up to gather AR/WS dispensing data for : ",!!,$P($G(^PS(59.4,+PSAISIT,0)),U),"," D
  1.  .S PSA(3)=0 F  S PSA(3)=$O(^PSD(58.8,+PSALOC,3,+PSA(3))) Q:'PSA(3)  W:$X+10>IOM ! W $P($G(^DIC(42,+PSA(3),0)),U),$S($O(^PSD(58.8,+PSALOC,3,+PSA(3))):", ",1:".")
  1. EDTWRD ;Edit Wards 
  1.  R !!,"Do you want to add/edit the wards accociated with this location? NO // ",AN:DTIME G WARDQ:AN["^" I AN="" S AN="N"
  1.  S AN=$E(AN) I "yYnN"'[AN W !,"Answer Yes, and we'll loop through the ward file, and either add new wards,",!,"or delete wards already associated with this location. " G EDTWRD
  1.  I "Nn"[AN G WARDQ
  1.  S PSAWARD=0
  1. WARDLP S PSAWARD=$O(^DIC(42,PSAWARD)) G WARDQ:PSAWARD'>0 W !,$P($G(^DIC(42,PSAWARD,0)),"^")
  1.  I '$D(^PSD(58.8,PSALOC,3,PSAWARD,0)) G WARD1
  1. WARDASK R ?25,"Remove association with location? NO // ",AN:DTIME I AN["^" S PSAERR=1 G WARDQ
  1.  I AN="" G WARDLP
  1.  I "YyNn"'[AN W !
  1.  I "yY"[AN W ?(IOM-9),"removed" S DIK="^PSD(58.8,+PSALOC,3,",DIC(0)="AEMQ",DA(1)=PSALOC,DA=PSAWARD D ^DIK
  1.  G WARDLP
  1.  ;
  1. WARD1 ;not currently assigned
  1.  I $D(^PSD(58.8,"AB",PSAWARD)),$O(^PSD(58.8,"AB",PSAWARD,0))'=PSALOC W ?30,"This ward is already associated with : "_$P($G(^PSD(58.8,$O(^PSD(58.8,"AB",PSAWARD,0)),0)),"^") G WARDLP
  1.  R ?40,"Add to location ? NO // : ",AN:DTIME G WARDQ:AN["^" I AN="" G WARDLP
  1.  S AN=$E(AN) I "nNyY"'[AN W !,"Do you want to add this ward to this location?" K AN G WARD1
  1.  I "Nn"[AN G WARDLP
  1.  W ?(IOM-7),"Adding" S (DINUM,X)=PSAWARD,DIC="^PSD(58.8,+PSALOC,3,",DA(1)=PSALOC,DIC(0)="LNX" D FILE^DICN
  1.  G WARDLP
  1. WARDQ ;
  1.  G NXT
  1. 7 S PSAHDR="EDIT INACTIVATION DATA" D HDR
  1.  S DIE="^PSD(58.8,",DA=PSALOC,DR="4" D ^DIE
  1.  G NXT
  1. 8 S PSAHDR="ADD/EDIT DRUGS FOR LOCATION" D HDR
  1.  I $O(^PSD(58.8,PSALOC,1,0))>0 G 83
  1. 81 R !,"Do you want to transfer drugs from another location? NO// ",AN:DTIME G Q:AN["^" S AN=$E(AN) I "nN"[AN G 83
  1.  I "YyNn"'[AN W !,"Answer 'Y'es to transfer all the drugs from another location to this location.",!,"Please note that the drugs will be inactivated in the old location." G 81
  1. 82 R !,"Transfer the drug's balance, stock level, etc., as well? YES // ",AN:DTIME G Q:AN["^" S AN=$E(AN) I "nN"'[AN S PSATFER=0
  1.  I "YyNn"'[AN W !!,"Answer 'Y'es to transfer all the current information about the drug to the new",!," location.",!! G 82
  1.  I "Yy"[AN S PSATFER=1
  1. 811 S PSALOCB=PSALOC K PSALOC D ^PSALOC G Q:$G(PSALOC)'>0 S PSALOC2=PSALOC,PSALOC=PSALOCB K PSALOCB I PSALOC2=PSALOC W !!,"Sorry, that is the current location." D EOP G 811
  1.  S X1=0 F  S X1=$O(^PSD(58.8,PSALOC2,1,X1)) Q:X1'>0  W !,$P($G(^PSDRUG(X1,0)),"^") D
  1.  .S ^PSD(58.8,PSALOC,1,X1,0)=X1 I $G(PSATFER)=1 S ^PSD(58.8,PSALOC,1,X1,0)=^PSD(58.8,PSALOC2,1,X1,0)
  1.  .S ^PSD(58.8,PSALOC,1,"B",X1,X1)="" ;drug xref
  1.  D EOP G NXT
  1. 83 K DIC,DIR S PSAOPT="PSALOC" D GETDRUG^PSADRUGP K PSAOPT
  1.  G NXT
  1. 9 S PSAHDR="SET/DELETE MAINTAIN REORDER LEVELS FLAG"
  1.  S DIE="^PSD(58.8,",DA=PSALOC,DR=34 D ^DIE K DA,DIE
  1.  G NXT
  1. 10 S DIC(0)="AEQMZ",DIC="^PSD(58.8,",DIC("A")="Select Inactive Pharmacy Location: ",DIC("S")="I $D(^PSD(58.8,+Y,""I""))"
  1.  D ^DIC G Q:+Y'>0 S DIE="^PSD(58.8,",DA=+Y,DR="4" D ^DIE
  1.  I $P($G(^PSD(58.8,DA,"I")),"^")="" K ^PSD(58.8,DA,"I") W !,$P(^PSD(58.8,DA,0),"^"),"   Reactivated."
  1.  Q
  1. PSA10 S PSAHDR="SETUP RECIPIENTS OF MAILMESSAGE" W @IOF,!,PSAHDR_" SCREEN",! F X=1:1:(IOM-1) W "="
  1.  D PSASETUP^PSALOC1,EOP Q
  1. HLP W !!,"Display help for which item # ?" R AN:DTIME G PSALOCO:"^"[AN I AN<1!(AN>10) G OPTASK
  1.  S X="PSAHLP"_AN_"^PSALOC1" D @X G OPTASK
  1. EOP F X=$Y:1:(IOSL-5) W !
  1.  R !,"Press RETURN/ENTER to continue: ",AN:DTIME
  1.  Q
  1. Q G EXIT^PSALOC
  1. HDR S PSAHDR=PSAHDR_" SCREEN" W @IOF,!,PSAHDR_" for : "_PSALOCN,! F X=1:1:(IOM-1) W "="
  1.  ;
  1.  W ! Q
  1. NXT D EOP G PSALOCO
  1. OPSITES ;
  1.  F X=2:1 Q:'$D(PSAOSIT(X))  K PSAOSIT(X)
  1.  F X=2:1 Q:$P($G(PSALOCA(PSALOCN,PSALOC)),"^",X)=""  S PSAOSIT(X)=$P($G(PSALOCA(PSALOCN,PSALOC)),"^",X)
  1.  Q
  1. ADD S X6=$$MG^XMBGRP(PSAGROUP,0,DUZ,0,.XMY,,0)
  1.  W !,$S($G(X6)>0:"Ok, addition completed.",1:"error in adding users ? "),!
  1.  Q