source: WorldVistAEHR/trunk/r/CONTROLLED_SUBSTANCES-PSD/PSDUTL.m@ 1096

Last change on this file since 1096 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 4.0 KB
RevLine 
[613]1PSDUTL ;BIR/CML,JPW,LTL-Utility Routine for FileMan Functions ; 21 Dec 94
2 ;;3.0; CONTROLLED SUBSTANCES ;;13 Feb 97
3INACT ;check for inactive date on drug for 'D' x-ref (file 58.8)
4 K PSDFLAG I '$D(^PSD(58.8,DA(2),1,DA(1),"I")) S PSDFLAG=1 Q
5 S:$O(^PSD(58.8,DA(2),1,DA(1),"I"))>DT PSDFLAG=1
6 Q
7DELR ;deletes inactivation reason when inactivation date deleted
8 I $D(^PSD(58.8,DA(1),1,DA,0)),'$P(^(0),"^",14) S $P(^(0),"^",15,16)="^"
9 Q
10IG ;reset sort keys for inventory groups
11 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
12 K INVGRP
13 Q
14IGSET 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
15 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
16 K D,D0,DA,D1,DIC,DIE,DQ,DR,X,CNT,NAOU,NAOULP,NSK,SK
17 Q
18NAOU ;checks for NAOU inpatient site
19 S SITE=0
20 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
21 K X
22 Q
23STAT ;sets order status cross-reference in file 58.85 (field 6)
24 N PSDNL,PSDD,PSDREQ S PSDNL=$P(^PSD(58.85,DA,0),"^",3),PSDD=$P(^(0),"^",4),PSDREQ=$P(^(0),"^",5)
25 Q:'PSDNL!('PSDD)!('PSDREQ)
26 S ^PSD(58.85,"AC",X,PSDNL,PSDD,PSDREQ,DA)=""
27 Q
28KSTAT ;kills order status cross-reference in file 58.85 (field 6)
29 N PSDNL,PSDD,PSDREQ S PSDNL=$P(^PSD(58.85,DA,0),"^",3),PSDD=$P(^(0),"^",4),PSDREQ=$P(^(0),"^",5)
30 Q:'PSDNL!('PSDD)!('PSDREQ)
31 K ^PSD(58.85,"AC",X,PSDNL,PSDD,PSDREQ,DA)
32 Q
33REQ ;sets request # x-ref in file 58.85 (field 4)
34 N PSDNL,PSDD S PSDNL=$P(^PSD(58.85,DA,0),"^",3),PSDD=$P(^(0),"^",4)
35 Q:'PSDNL!('PSDD)
36 S ^PSD(58.85,"AD",PSDNL,PSDD,X,DA)=""
37 Q
38KREQ ;kills request # x-ref in file 58.85 (field 4)
39 N PSDNL,PSDD S PSDNL=$P(^PSD(58.85,DA,0),"^",3),PSDD=$P(^(0),"^",4)
40 Q:'PSDNL!('PSDD)
41 K ^PSD(58.85,"AD",PSDNL,PSDD,X,DA)
42 Q
43SAD ;sets 'AD' xref in file 58.81 (field 10)
44 S PSDNL=+$P(^PSD(58.81,DA,0),"^",18) I 'PSDNL K PSDNL Q
45 S ^PSD(58.81,"AD",X,PSDNL,DA)="" K PSDNL
46 Q
47KAD ;kills 'AD' x-ref in file 58.81 (field 10)
48 S PSDNL=+$P(^PSD(58.81,DA,0),"^",18) I 'PSDNL K PSDNL Q
49 K ^PSD(58.81,"AD",X,PSDNL,DA),PSDNL
50 Q
51SAF ;set 'AF' x-ref on field 3 in 58.81
52 S PSDNL=$P(^PSD(58.81,DA,0),"^",3),PSDTYPE=$P(^(0),"^",2)
53 I 'PSDNL!('PSDTYPE) K PSDNL,PSDTYPE Q
54 S ^PSD(58.81,"AF",X,PSDNL,PSDTYPE,DA)="" K PSDNL,PSDTYPE
55 Q
56KAF ;kill 'AF' x-ref on field 3 in 58.81
57 S PSDNL=$P(^PSD(58.81,DA,0),"^",3),PSDTYPE=$P(^(0),"^",2)
58 I 'PSDNL!('PSDTYPE) K PSDNL,PSDTYPE Q
59 K ^PSD(58.81,"AF",X,PSDNL,PSDTYPE,DA),PSDNL,PSDTYPE
60 Q
61SAFL ;set 'AF' (for loc) on field 3 in 58.81
62 S PSDATT=$P(^PSD(58.81,DA,0),"^",4),PSDTYPE=$P(^(0),"^",2)
63 I 'PSDATT!('PSDTYPE) K PSDATT,PSDTYPE Q
64 S ^PSD(58.81,"AF",PSDATT,X,PSDTYPE,DA)="" K PSDATT,PSDTYPE
65 Q
66KAFL ;kill 'AF' (for loc) on field 3 in 58.81
67 S PSDATT=$P(^PSD(58.81,DA,0),"^",4),PSDTYPE=$P(^(0),"^",2)
68 I 'PSDATT!('PSDTYPE) K PSDATT,PSDTYPE Q
69 K ^PSD(58.81,"AF",PSDATT,X,PSDTYPE,DA),PSDATT,PSDTYPE
70 Q
71SASITE ;set 'ASITE' x-ref on field 2 in 58.8
72 Q:$P(^PSD(58.8,DA,0),"^",2)=""
73 S PSDTYPE=$P(^PSD(58.8,DA,0),"^",2)
74 S ^PSD(58.8,"ASITE",X,PSDTYPE,DA)="" K PSDTYPE
75 Q
76KASITE ;kill 'ASITE' x-ref on field 2 in 58.8
77 Q:$P(^PSD(58.8,DA,0),"^",2)=""
78 S PSDTYPE=$P(^PSD(58.8,DA,0),"^",2)
79 K ^PSD(58.8,"ASITE",X,PSDTYPE,DA),PSDTYPE
80 Q
81SASITE1 ;set 'ASITE' x-ref on field 1
82 S PSDDS=$P(^PSD(58.8,DA,0),"^",3) I 'PSDDS K PSDDS Q
83 S ^PSD(58.8,"ASITE",PSDDS,X,DA)="" K PSDDS
84 Q
85KASITE1 ;k 'ASITE' on field 1 in 58.8
86 S PSDDS=$P(^PSD(58.8,DA,0),"^",3) I 'PSDDS K PSDDS Q
87 K ^PSD(58.8,"ASITE",PSDDS,X,DA),PSDDS
88 Q
89SAFT ;set 'AF' field 1 in 58.81
90 S PSDNL=$P(^PSD(58.81,DA,0),"^",3),PSDATT=$P(^(0),"^",4)
91 I 'PSDNL!('PSDATT) K PSDNL,PSDATT Q
92 S ^PSD(58.81,"AF",PSDATT,PSDNL,X,DA)="" K PSDATT,PSDNL
93 Q
94KAFT ;kill 'AF' field 1 in 58.81
95 S PSDNL=$P(^PSD(58.81,DA,0),"^",3),PSDATT=$P(^(0),"^",4)
96 I 'PSDNL!('PSDATT) K PSDNL,PSDATT Q
97 K ^PSD(58.81,"AF",PSDATT,PSDNL,X,DA),PSDATT,PSDNL
98 Q
Note: See TracBrowser for help on using the repository browser.