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

PSDUTL.m

Go to the documentation of this file.
  1. PSDUTL ;BIR/CML,JPW,LTL-Utility Routine for FileMan Functions ; 21 Dec 94
  1. ;;3.0; CONTROLLED SUBSTANCES ;;13 Feb 97
  1. INACT ;check for inactive date on drug for 'D' x-ref (file 58.8)
  1. K PSDFLAG I '$D(^PSD(58.8,DA(2),1,DA(1),"I")) S PSDFLAG=1 Q
  1. S:$O(^PSD(58.8,DA(2),1,DA(1),"I"))>DT PSDFLAG=1
  1. Q
  1. DELR ;deletes inactivation reason when inactivation date deleted
  1. I $D(^PSD(58.8,DA(1),1,DA,0)),'$P(^(0),"^",14) S $P(^(0),"^",15,16)="^"
  1. Q
  1. IG ;reset sort keys for inventory groups
  1. F INVGRP=0:0 S INVGRP=$O(^PSI(58.2,INVGRP)) Q:'INVGRP I $O(^PSI(58.2,INVGRP,3,"D",0)) W "." D IGSET
  1. K INVGRP
  1. Q
  1. IGSET S CNT=0 F SK=0:0 S SK=$O(^PSI(58.2,INVGRP,3,"D",SK)) Q:'SK S NAOU=$O(^PSI(58.2,INVGRP,3,"D",SK,0)),CNT=CNT+1,NAOULP(CNT)=NAOU
  1. F SK=0:0 S SK=$O(NAOULP(SK)) Q:'SK S NSK=SK*100,DA(1)=INVGRP,DA=NAOULP(SK),DIE="^PSI(58.2,"_DA(1)_",3,",DR="2///"_NSK D ^DIE K DIE
  1. K D,D0,DA,D1,DIC,DIE,DQ,DR,X,CNT,NAOU,NAOULP,NSK,SK
  1. Q
  1. NAOU ;checks for NAOU inpatient site
  1. S SITE=0
  1. I '$P($G(^PSD(58.8,PSDA,0)),"^",3) W !!,"You must define a CS inpatient site for this NAOU.",!,"Use the 'Create the Narcotic Area of Use' option to add this data.",!!,"Press <RET> to continue " R X:DTIME S SITE=1 W @IOF
  1. K X
  1. Q
  1. STAT ;sets order status cross-reference in file 58.85 (field 6)
  1. N PSDNL,PSDD,PSDREQ S PSDNL=$P(^PSD(58.85,DA,0),"^",3),PSDD=$P(^(0),"^",4),PSDREQ=$P(^(0),"^",5)
  1. Q:'PSDNL!('PSDD)!('PSDREQ)
  1. S ^PSD(58.85,"AC",X,PSDNL,PSDD,PSDREQ,DA)=""
  1. Q
  1. KSTAT ;kills order status cross-reference in file 58.85 (field 6)
  1. N PSDNL,PSDD,PSDREQ S PSDNL=$P(^PSD(58.85,DA,0),"^",3),PSDD=$P(^(0),"^",4),PSDREQ=$P(^(0),"^",5)
  1. Q:'PSDNL!('PSDD)!('PSDREQ)
  1. K ^PSD(58.85,"AC",X,PSDNL,PSDD,PSDREQ,DA)
  1. Q
  1. REQ ;sets request # x-ref in file 58.85 (field 4)
  1. N PSDNL,PSDD S PSDNL=$P(^PSD(58.85,DA,0),"^",3),PSDD=$P(^(0),"^",4)
  1. Q:'PSDNL!('PSDD)
  1. S ^PSD(58.85,"AD",PSDNL,PSDD,X,DA)=""
  1. Q
  1. KREQ ;kills request # x-ref in file 58.85 (field 4)
  1. N PSDNL,PSDD S PSDNL=$P(^PSD(58.85,DA,0),"^",3),PSDD=$P(^(0),"^",4)
  1. Q:'PSDNL!('PSDD)
  1. K ^PSD(58.85,"AD",PSDNL,PSDD,X,DA)
  1. Q
  1. SAD ;sets 'AD' xref in file 58.81 (field 10)
  1. S PSDNL=+$P(^PSD(58.81,DA,0),"^",18) I 'PSDNL K PSDNL Q
  1. S ^PSD(58.81,"AD",X,PSDNL,DA)="" K PSDNL
  1. Q
  1. KAD ;kills 'AD' x-ref in file 58.81 (field 10)
  1. S PSDNL=+$P(^PSD(58.81,DA,0),"^",18) I 'PSDNL K PSDNL Q
  1. K ^PSD(58.81,"AD",X,PSDNL,DA),PSDNL
  1. Q
  1. SAF ;set 'AF' x-ref on field 3 in 58.81
  1. S PSDNL=$P(^PSD(58.81,DA,0),"^",3),PSDTYPE=$P(^(0),"^",2)
  1. I 'PSDNL!('PSDTYPE) K PSDNL,PSDTYPE Q
  1. S ^PSD(58.81,"AF",X,PSDNL,PSDTYPE,DA)="" K PSDNL,PSDTYPE
  1. Q
  1. KAF ;kill 'AF' x-ref on field 3 in 58.81
  1. S PSDNL=$P(^PSD(58.81,DA,0),"^",3),PSDTYPE=$P(^(0),"^",2)
  1. I 'PSDNL!('PSDTYPE) K PSDNL,PSDTYPE Q
  1. K ^PSD(58.81,"AF",X,PSDNL,PSDTYPE,DA),PSDNL,PSDTYPE
  1. Q
  1. SAFL ;set 'AF' (for loc) on field 3 in 58.81
  1. S PSDATT=$P(^PSD(58.81,DA,0),"^",4),PSDTYPE=$P(^(0),"^",2)
  1. I 'PSDATT!('PSDTYPE) K PSDATT,PSDTYPE Q
  1. S ^PSD(58.81,"AF",PSDATT,X,PSDTYPE,DA)="" K PSDATT,PSDTYPE
  1. Q
  1. KAFL ;kill 'AF' (for loc) on field 3 in 58.81
  1. S PSDATT=$P(^PSD(58.81,DA,0),"^",4),PSDTYPE=$P(^(0),"^",2)
  1. I 'PSDATT!('PSDTYPE) K PSDATT,PSDTYPE Q
  1. K ^PSD(58.81,"AF",PSDATT,X,PSDTYPE,DA),PSDATT,PSDTYPE
  1. Q
  1. SASITE ;set 'ASITE' x-ref on field 2 in 58.8
  1. Q:$P(^PSD(58.8,DA,0),"^",2)=""
  1. S PSDTYPE=$P(^PSD(58.8,DA,0),"^",2)
  1. S ^PSD(58.8,"ASITE",X,PSDTYPE,DA)="" K PSDTYPE
  1. Q
  1. KASITE ;kill 'ASITE' x-ref on field 2 in 58.8
  1. Q:$P(^PSD(58.8,DA,0),"^",2)=""
  1. S PSDTYPE=$P(^PSD(58.8,DA,0),"^",2)
  1. K ^PSD(58.8,"ASITE",X,PSDTYPE,DA),PSDTYPE
  1. Q
  1. SASITE1 ;set 'ASITE' x-ref on field 1
  1. S PSDDS=$P(^PSD(58.8,DA,0),"^",3) I 'PSDDS K PSDDS Q
  1. S ^PSD(58.8,"ASITE",PSDDS,X,DA)="" K PSDDS
  1. Q
  1. KASITE1 ;k 'ASITE' on field 1 in 58.8
  1. S PSDDS=$P(^PSD(58.8,DA,0),"^",3) I 'PSDDS K PSDDS Q
  1. K ^PSD(58.8,"ASITE",PSDDS,X,DA),PSDDS
  1. Q
  1. SAFT ;set 'AF' field 1 in 58.81
  1. S PSDNL=$P(^PSD(58.81,DA,0),"^",3),PSDATT=$P(^(0),"^",4)
  1. I 'PSDNL!('PSDATT) K PSDNL,PSDATT Q
  1. S ^PSD(58.81,"AF",PSDATT,PSDNL,X,DA)="" K PSDATT,PSDNL
  1. Q
  1. KAFT ;kill 'AF' field 1 in 58.81
  1. S PSDNL=$P(^PSD(58.81,DA,0),"^",3),PSDATT=$P(^(0),"^",4)
  1. I 'PSDNL!('PSDATT) K PSDNL,PSDATT Q
  1. K ^PSD(58.81,"AF",PSDATT,PSDNL,X,DA),PSDATT,PSDNL
  1. Q