PSDUTL ;BIR/CML,JPW,LTL-Utility Routine for FileMan Functions ; 21 Dec 94
;;3.0; CONTROLLED SUBSTANCES ;;13 Feb 97
INACT ;check for inactive date on drug for 'D' x-ref (file 58.8)
K PSDFLAG I '$D(^PSD(58.8,DA(2),1,DA(1),"I")) S PSDFLAG=1 Q
S:$O(^PSD(58.8,DA(2),1,DA(1),"I"))>DT PSDFLAG=1
Q
DELR ;deletes inactivation reason when inactivation date deleted
I $D(^PSD(58.8,DA(1),1,DA,0)),'$P(^(0),"^",14) S $P(^(0),"^",15,16)="^"
Q
IG ;reset sort keys for inventory groups
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
K INVGRP
Q
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
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
K D,D0,DA,D1,DIC,DIE,DQ,DR,X,CNT,NAOU,NAOULP,NSK,SK
Q
NAOU ;checks for NAOU inpatient site
S SITE=0
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
K X
Q
STAT ;sets order status cross-reference in file 58.85 (field 6)
N PSDNL,PSDD,PSDREQ S PSDNL=$P(^PSD(58.85,DA,0),"^",3),PSDD=$P(^(0),"^",4),PSDREQ=$P(^(0),"^",5)
Q:'PSDNL!('PSDD)!('PSDREQ)
S ^PSD(58.85,"AC",X,PSDNL,PSDD,PSDREQ,DA)=""
Q
KSTAT ;kills order status cross-reference in file 58.85 (field 6)
N PSDNL,PSDD,PSDREQ S PSDNL=$P(^PSD(58.85,DA,0),"^",3),PSDD=$P(^(0),"^",4),PSDREQ=$P(^(0),"^",5)
Q:'PSDNL!('PSDD)!('PSDREQ)
K ^PSD(58.85,"AC",X,PSDNL,PSDD,PSDREQ,DA)
Q
REQ ;sets request # x-ref in file 58.85 (field 4)
N PSDNL,PSDD S PSDNL=$P(^PSD(58.85,DA,0),"^",3),PSDD=$P(^(0),"^",4)
Q:'PSDNL!('PSDD)
S ^PSD(58.85,"AD",PSDNL,PSDD,X,DA)=""
Q
KREQ ;kills request # x-ref in file 58.85 (field 4)
N PSDNL,PSDD S PSDNL=$P(^PSD(58.85,DA,0),"^",3),PSDD=$P(^(0),"^",4)
Q:'PSDNL!('PSDD)
K ^PSD(58.85,"AD",PSDNL,PSDD,X,DA)
Q
SAD ;sets 'AD' xref in file 58.81 (field 10)
S PSDNL=+$P(^PSD(58.81,DA,0),"^",18) I 'PSDNL K PSDNL Q
S ^PSD(58.81,"AD",X,PSDNL,DA)="" K PSDNL
Q
KAD ;kills 'AD' x-ref in file 58.81 (field 10)
S PSDNL=+$P(^PSD(58.81,DA,0),"^",18) I 'PSDNL K PSDNL Q
K ^PSD(58.81,"AD",X,PSDNL,DA),PSDNL
Q
SAF ;set 'AF' x-ref on field 3 in 58.81
S PSDNL=$P(^PSD(58.81,DA,0),"^",3),PSDTYPE=$P(^(0),"^",2)
I 'PSDNL!('PSDTYPE) K PSDNL,PSDTYPE Q
S ^PSD(58.81,"AF",X,PSDNL,PSDTYPE,DA)="" K PSDNL,PSDTYPE
Q
KAF ;kill 'AF' x-ref on field 3 in 58.81
S PSDNL=$P(^PSD(58.81,DA,0),"^",3),PSDTYPE=$P(^(0),"^",2)
I 'PSDNL!('PSDTYPE) K PSDNL,PSDTYPE Q
K ^PSD(58.81,"AF",X,PSDNL,PSDTYPE,DA),PSDNL,PSDTYPE
Q
SAFL ;set 'AF' (for loc) on field 3 in 58.81
S PSDATT=$P(^PSD(58.81,DA,0),"^",4),PSDTYPE=$P(^(0),"^",2)
I 'PSDATT!('PSDTYPE) K PSDATT,PSDTYPE Q
S ^PSD(58.81,"AF",PSDATT,X,PSDTYPE,DA)="" K PSDATT,PSDTYPE
Q
KAFL ;kill 'AF' (for loc) on field 3 in 58.81
S PSDATT=$P(^PSD(58.81,DA,0),"^",4),PSDTYPE=$P(^(0),"^",2)
I 'PSDATT!('PSDTYPE) K PSDATT,PSDTYPE Q
K ^PSD(58.81,"AF",PSDATT,X,PSDTYPE,DA),PSDATT,PSDTYPE
Q
SASITE ;set 'ASITE' x-ref on field 2 in 58.8
Q:$P(^PSD(58.8,DA,0),"^",2)=""
S PSDTYPE=$P(^PSD(58.8,DA,0),"^",2)
S ^PSD(58.8,"ASITE",X,PSDTYPE,DA)="" K PSDTYPE
Q
KASITE ;kill 'ASITE' x-ref on field 2 in 58.8
Q:$P(^PSD(58.8,DA,0),"^",2)=""
S PSDTYPE=$P(^PSD(58.8,DA,0),"^",2)
K ^PSD(58.8,"ASITE",X,PSDTYPE,DA),PSDTYPE
Q
SASITE1 ;set 'ASITE' x-ref on field 1
S PSDDS=$P(^PSD(58.8,DA,0),"^",3) I 'PSDDS K PSDDS Q
S ^PSD(58.8,"ASITE",PSDDS,X,DA)="" K PSDDS
Q
KASITE1 ;k 'ASITE' on field 1 in 58.8
S PSDDS=$P(^PSD(58.8,DA,0),"^",3) I 'PSDDS K PSDDS Q
K ^PSD(58.8,"ASITE",PSDDS,X,DA),PSDDS
Q
SAFT ;set 'AF' field 1 in 58.81
S PSDNL=$P(^PSD(58.81,DA,0),"^",3),PSDATT=$P(^(0),"^",4)
I 'PSDNL!('PSDATT) K PSDNL,PSDATT Q
S ^PSD(58.81,"AF",PSDATT,PSDNL,X,DA)="" K PSDATT,PSDNL
Q
KAFT ;kill 'AF' field 1 in 58.81
S PSDNL=$P(^PSD(58.81,DA,0),"^",3),PSDATT=$P(^(0),"^",4)
I 'PSDNL!('PSDATT) K PSDNL,PSDATT Q
K ^PSD(58.81,"AF",PSDATT,PSDNL,X,DA),PSDATT,PSDNL
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSDUTL 4187 printed Oct 16, 2024@17:50:07 Page 2
PSDUTL ;BIR/CML,JPW,LTL-Utility Routine for FileMan Functions ; 21 Dec 94
+1 ;;3.0; CONTROLLED SUBSTANCES ;;13 Feb 97
INACT ;check for inactive date on drug for 'D' x-ref (file 58.8)
+1 KILL PSDFLAG
IF '$DATA(^PSD(58.8,DA(2),1,DA(1),"I"))
SET PSDFLAG=1
QUIT
+2 if $ORDER(^PSD(58.8,DA(2),1,DA(1),"I"))>DT
SET PSDFLAG=1
+3 QUIT
DELR ;deletes inactivation reason when inactivation date deleted
+1 IF $DATA(^PSD(58.8,DA(1),1,DA,0))
IF '$PIECE(^(0),"^",14)
SET $PIECE(^(0),"^",15,16)="^"
+2 QUIT
IG ;reset sort keys for inventory groups
+1 FOR INVGRP=0:0
SET INVGRP=$ORDER(^PSI(58.2,INVGRP))
if 'INVGRP
QUIT
IF $ORDER(^PSI(58.2,INVGRP,3,"D",0))
WRITE "."
DO IGSET
+2 KILL INVGRP
+3 QUIT
IGSET SET CNT=0
FOR SK=0:0
SET SK=$ORDER(^PSI(58.2,INVGRP,3,"D",SK))
if 'SK
QUIT
SET NAOU=$ORDER(^PSI(58.2,INVGRP,3,"D",SK,0))
SET CNT=CNT+1
SET NAOULP(CNT)=NAOU
+1 FOR SK=0:0
SET SK=$ORDER(NAOULP(SK))
if 'SK
QUIT
SET NSK=SK*100
SET DA(1)=INVGRP
SET DA=NAOULP(SK)
SET DIE="^PSI(58.2,"_DA(1)_",3,"
SET DR="2///"_NSK
DO ^DIE
KILL DIE
+2 KILL D,D0,DA,D1,DIC,DIE,DQ,DR,X,CNT,NAOU,NAOULP,NSK,SK
+3 QUIT
NAOU ;checks for NAOU inpatient site
+1 SET SITE=0
+2 IF '$PIECE($GET(^PSD(58.8,PSDA,0)),"^",3)
WRITE !!,"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 "
READ X:DTIME
SET SITE=1
WRITE @IOF
+3 KILL X
+4 QUIT
STAT ;sets order status cross-reference in file 58.85 (field 6)
+1 NEW PSDNL,PSDD,PSDREQ
SET PSDNL=$PIECE(^PSD(58.85,DA,0),"^",3)
SET PSDD=$PIECE(^(0),"^",4)
SET PSDREQ=$PIECE(^(0),"^",5)
+2 if 'PSDNL!('PSDD)!('PSDREQ)
QUIT
+3 SET ^PSD(58.85,"AC",X,PSDNL,PSDD,PSDREQ,DA)=""
+4 QUIT
KSTAT ;kills order status cross-reference in file 58.85 (field 6)
+1 NEW PSDNL,PSDD,PSDREQ
SET PSDNL=$PIECE(^PSD(58.85,DA,0),"^",3)
SET PSDD=$PIECE(^(0),"^",4)
SET PSDREQ=$PIECE(^(0),"^",5)
+2 if 'PSDNL!('PSDD)!('PSDREQ)
QUIT
+3 KILL ^PSD(58.85,"AC",X,PSDNL,PSDD,PSDREQ,DA)
+4 QUIT
REQ ;sets request # x-ref in file 58.85 (field 4)
+1 NEW PSDNL,PSDD
SET PSDNL=$PIECE(^PSD(58.85,DA,0),"^",3)
SET PSDD=$PIECE(^(0),"^",4)
+2 if 'PSDNL!('PSDD)
QUIT
+3 SET ^PSD(58.85,"AD",PSDNL,PSDD,X,DA)=""
+4 QUIT
KREQ ;kills request # x-ref in file 58.85 (field 4)
+1 NEW PSDNL,PSDD
SET PSDNL=$PIECE(^PSD(58.85,DA,0),"^",3)
SET PSDD=$PIECE(^(0),"^",4)
+2 if 'PSDNL!('PSDD)
QUIT
+3 KILL ^PSD(58.85,"AD",PSDNL,PSDD,X,DA)
+4 QUIT
SAD ;sets 'AD' xref in file 58.81 (field 10)
+1 SET PSDNL=+$PIECE(^PSD(58.81,DA,0),"^",18)
IF 'PSDNL
KILL PSDNL
QUIT
+2 SET ^PSD(58.81,"AD",X,PSDNL,DA)=""
KILL PSDNL
+3 QUIT
KAD ;kills 'AD' x-ref in file 58.81 (field 10)
+1 SET PSDNL=+$PIECE(^PSD(58.81,DA,0),"^",18)
IF 'PSDNL
KILL PSDNL
QUIT
+2 KILL ^PSD(58.81,"AD",X,PSDNL,DA),PSDNL
+3 QUIT
SAF ;set 'AF' x-ref on field 3 in 58.81
+1 SET PSDNL=$PIECE(^PSD(58.81,DA,0),"^",3)
SET PSDTYPE=$PIECE(^(0),"^",2)
+2 IF 'PSDNL!('PSDTYPE)
KILL PSDNL,PSDTYPE
QUIT
+3 SET ^PSD(58.81,"AF",X,PSDNL,PSDTYPE,DA)=""
KILL PSDNL,PSDTYPE
+4 QUIT
KAF ;kill 'AF' x-ref on field 3 in 58.81
+1 SET PSDNL=$PIECE(^PSD(58.81,DA,0),"^",3)
SET PSDTYPE=$PIECE(^(0),"^",2)
+2 IF 'PSDNL!('PSDTYPE)
KILL PSDNL,PSDTYPE
QUIT
+3 KILL ^PSD(58.81,"AF",X,PSDNL,PSDTYPE,DA),PSDNL,PSDTYPE
+4 QUIT
SAFL ;set 'AF' (for loc) on field 3 in 58.81
+1 SET PSDATT=$PIECE(^PSD(58.81,DA,0),"^",4)
SET PSDTYPE=$PIECE(^(0),"^",2)
+2 IF 'PSDATT!('PSDTYPE)
KILL PSDATT,PSDTYPE
QUIT
+3 SET ^PSD(58.81,"AF",PSDATT,X,PSDTYPE,DA)=""
KILL PSDATT,PSDTYPE
+4 QUIT
KAFL ;kill 'AF' (for loc) on field 3 in 58.81
+1 SET PSDATT=$PIECE(^PSD(58.81,DA,0),"^",4)
SET PSDTYPE=$PIECE(^(0),"^",2)
+2 IF 'PSDATT!('PSDTYPE)
KILL PSDATT,PSDTYPE
QUIT
+3 KILL ^PSD(58.81,"AF",PSDATT,X,PSDTYPE,DA),PSDATT,PSDTYPE
+4 QUIT
SASITE ;set 'ASITE' x-ref on field 2 in 58.8
+1 if $PIECE(^PSD(58.8,DA,0),"^",2)=""
QUIT
+2 SET PSDTYPE=$PIECE(^PSD(58.8,DA,0),"^",2)
+3 SET ^PSD(58.8,"ASITE",X,PSDTYPE,DA)=""
KILL PSDTYPE
+4 QUIT
KASITE ;kill 'ASITE' x-ref on field 2 in 58.8
+1 if $PIECE(^PSD(58.8,DA,0),"^",2)=""
QUIT
+2 SET PSDTYPE=$PIECE(^PSD(58.8,DA,0),"^",2)
+3 KILL ^PSD(58.8,"ASITE",X,PSDTYPE,DA),PSDTYPE
+4 QUIT
SASITE1 ;set 'ASITE' x-ref on field 1
+1 SET PSDDS=$PIECE(^PSD(58.8,DA,0),"^",3)
IF 'PSDDS
KILL PSDDS
QUIT
+2 SET ^PSD(58.8,"ASITE",PSDDS,X,DA)=""
KILL PSDDS
+3 QUIT
KASITE1 ;k 'ASITE' on field 1 in 58.8
+1 SET PSDDS=$PIECE(^PSD(58.8,DA,0),"^",3)
IF 'PSDDS
KILL PSDDS
QUIT
+2 KILL ^PSD(58.8,"ASITE",PSDDS,X,DA),PSDDS
+3 QUIT
SAFT ;set 'AF' field 1 in 58.81
+1 SET PSDNL=$PIECE(^PSD(58.81,DA,0),"^",3)
SET PSDATT=$PIECE(^(0),"^",4)
+2 IF 'PSDNL!('PSDATT)
KILL PSDNL,PSDATT
QUIT
+3 SET ^PSD(58.81,"AF",PSDATT,PSDNL,X,DA)=""
KILL PSDATT,PSDNL
+4 QUIT
KAFT ;kill 'AF' field 1 in 58.81
+1 SET PSDNL=$PIECE(^PSD(58.81,DA,0),"^",3)
SET PSDATT=$PIECE(^(0),"^",4)
+2 IF 'PSDNL!('PSDATT)
KILL PSDNL,PSDATT
QUIT
+3 KILL ^PSD(58.81,"AF",PSDATT,PSDNL,X,DA),PSDATT,PSDNL
+4 QUIT
