source: WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGBRJ.m@ 1080

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

initial load of WorldVistAEHR
File size: 4.2 KB
Line 
1PSGBRJ ;BIR/CML3-UD JANITOR (BACKGROUND TASKMAN JOB) ; 30 Jun 98 / 1:59 PM
2 ;;5.0; INPATIENT MEDICATIONS ;**12,50**;16 DEC 97
3 ;
4 ; Reference to ^PS(55 is supported by DBIA# 2191.
5 ; Reference to ^PS(59.7 is supported by DBIA# 2181.
6 ;
7LK ; kill off old labels
8 D NOW^%DTC S (PSGBRJDT,PSGDT)=%,^PS(53.42,PSGBRJDT,0)=PSGBRJDT,PSJACIVF=1
9 F PSGL1=1,2 D
10 .F PSGL2=0:0 S PSGL2=$O(^PS(53.41,PSGL1,1,PSGL2)) Q:'PSGL2 D
11 ..F PSGL3=0:0 S PSGL3=$O(^PS(53.41,PSGL1,1,PSGL2,1,PSGL3)) Q:'PSGL3 D
12 ...S PSGKD=$$LABELDT(PSGL3,PSGDT)
13 ...F PSGL4=1,2,3 F PSGL5=0:0 S PSGL5=$O(^PS(53.41,PSGL1,1,PSGL2,1,PSGL3,1,PSGL4,1,PSGL5)) Q:'PSGL5 D
14 ....S X=$P($G(^PS(53.41,PSGL1,1,PSGL2,1,PSGL3,1,PSGL4,1,PSGL5,0)),"^",3)
15 ....I X<PSGKD K DA S DIK="^PS(53.41,"_PSGL1_",1,"_PSGL2_",1,"_PSGL3_",1,"_PSGL4_",1,",DA(4)=PSGL1,DA(3)=PSGL2,DA(2)=PSGL3,DA(1)=PSGL4,DA=PSGL5 D ^DIK
16 ;
17AK ; kill off all orders in 53.1 that have gone active (into 55)
18 N PSJNO,PSJNOACT S PSJNOACT=1
19 S DIK="^PS(53.1," F PSGP=0:0 S PSGP=$O(^PS(53.1,"AS","A",PSGP)) Q:'PSGP F PSJNO=0:0 S PSJNO=$O(^PS(53.1,"AS","A",PSGP,PSJNO)) Q:'PSJNO S DA=PSJNO D ^DIK
20 ;
21DE ; kill off de orders in 53.1 that no longer tie to order in 55
22 S X="ORX" X ^%ZOSF("TEST") S PSGOERRF=$T
23 NEW PSJDA,ON K ^TMP($J)
24 F PSGP=0:0 S PSGP=$O(^PS(53.1,"AS","DE",PSGP)) Q:'PSGP F PSJDA=0:0 S PSJDA=$O(^PS(53.1,"AS","DE",PSGP,PSJDA)) Q:'PSJDA S ON=$P($G(^PS(53.1,PSJDA,0)),U,26) D
25 . I ON["A"!(ON["O")!(ON["U") S:'$D(^PS(55,PSGP,5,+ON,0)) ^TMP($J,PSJDA)=PSGP Q
26 . I ON["V" S:'$D(^PS(55,PSGP,"IV",+ON,0)) ^TMP($J,PSJDA)=PSGP Q
27 . I '$D(^PS(53.1,+ON,0)) S ^TMP($J,PSJDA)=PSGP Q
28 F PSJDA=0:0 S PSJDA=$O(^TMP($J,PSJDA)) Q:'PSJDA D:$D(^PS(53.1,PSJDA,0)) PDE(PSJDA,^TMP($J,PSJDA))
29 K ^TMP($J)
30 ;
31DK ; kill off dc'd orders in 53.1 around longer than life of labels
32 N PSJNOACT S PSJNOACT=1
33 S X="ORX" X ^%ZOSF("TEST") S PSGOERRF=$T
34 F PSGP=0:0 S PSGP=$O(^PS(53.1,"AS","D",PSGP)) Q:'PSGP D
35 .S PSGKD=$$LABELDT(PSGP,PSGDT) F DA=0:0 S DA=$O(^PS(53.1,"AS","D",PSGP,DA)) Q:'DA D
36 ..S S=$P($G(^PS(53.1,DA,0)),"^",9),ST=$P($G(^(2)),"^",3) I $S(S="U":1,S="P":1,1:ST<PSGKD) D ORPRG:PSGOERRF S DIK="^PS(53.1," D ^DIK
37 ;
38PLP ; purge pick lists that are filed away and older than auto purge days
39 I $D(^PS(59.7,1,63.5)),^(63.5) S X2=-^(63.5),X1=DT D C^%DTC S PSJX=X F Q=0:0 S Q=$O(^PS(53.5,"AO",Q)) Q:'Q F QQ=0:0 S QQ=$O(^PS(53.5,"AO",Q,QQ)) Q:'QQ!(QQ>PSJX) S Y=$O(^(QQ,0)) I Y D
40 .K DA,DIK,^PS(53.5,"AU",Y) S DIK="^PS(53.5,",DA=Y D ^DIK
41 F PSJX=0:0 S PSJX=$O(^PS(53.55,PSJX)) Q:'PSJX I '$D(^PS(53.5,PSJX)) K DA,DIK S DA=PSJX,DIK="^PS(53.55," D ^DIK
42 ;
43GLK ; kill off entries in ^PS(53.42) 20 days or more old
44 S X1=DT,X2=-20 D C^%DTC F D=0:0 S D=$O(^PS(53.42,D)) Q:'D!(D'<X) K ^(D)
45 ;
46UPARAM ; kill off entries in ^PS(53.45) INPATIENT USER PARAMETERS file if there is no corresponding entry in the NEW PERSON file or they have a TERMINATION DATE before today.
47 S DA=0 F S DA=$O(^PS(53.45,DA)) Q:'DA D
48 .I '$D(^VA(200,DA)) S DIK="^PS(53.45," D ^DIK K DIK Q
49 .S PSGX=$P(^VA(200,DA,0),"^",11),PSGX=$S(PSGX="":9999999,1:PSGX) I PSGX<DT S DIK="^PS(53.45," D ^DIK K DIK
50 ;
51DONE ;
52 S:$D(ZTQUEUED) ZTREQ="@"
53 D NOW^%DTC S $P(^PS(53.42,PSGBRJDT,0),"^",2)=%
54 D ENKV^PSGSETU K CA,D,DA,DFN,DIK,DND,GOTO,PSGL1,PSGL2,PSGL3,PSGL4,PSGL4,PSGKD,PSGOERRF,PSGX,PSJACIVF,PSJX,PSGBRJDT,S,ST,X1,X2 Q
55 ;
56ORPRG ;
57 ;*** COMMENT OUT FOR NOW. NEED TO GET BACK WITH MELANIE TO SEE
58 ;*** WHAT TO BE DONE WHEN WE PURGE INPATIENT MEDS ORDERS. 7/19/96.
59 ; removed old call to ORX routine!
60 Q
61LABELDT(PSGP,X1) ; Find patient's ward and get days to keep new labels.
62 S X=$G(^DPT(PSGP,.1)),X2=0 I X]"" S X=+$O(^DIC(42,"B",X,0)),X=+$O(^PS(59.6,"B",X,0)),X2=-$P($G(^PS(59.6,X,0)),U,11)
63 D C^%DTC
64 Q X
65 ;
66PDE(PSJDA1,PSGP) ;Remove all related pending orders with the "DE" status.
67 N DA,DIK,PDE,PSJNUM,PDEFLG,PSJ55,PSJNOACT S (PDEFLG,PSJ55)=0,PSJNOACT=1
68 F S PSJNUM=$P($G(^PS(53.1,PSJDA1,0)),U,25) Q:'+PSJNUM D Q:PSJ55
69 . I PSJNUM["A"!(PSJNUM["O")!(PSJNUM["U") S PSJ55=1 I $D(^PS(55,PSGP,5,+PSJNUM,0)) S PDEFLG=1 Q
70 . I PSJNUM["V" S PSJ55=1 I $D(^PS(55,PSGP,"IV",+PSJNUM,0)) S PDEFLG=1 Q
71 . S PDE(PSJDA1)="",PSJDA1=+PSJNUM
72 S:'PSJ55 PDE(PSJDA1)=""
73 I 'PDEFLG,$O(PDE(0)) F PSJDA1=0:0 S PSJDA1=$O(PDE(PSJDA1)) Q:'PSJDA1 I $D(^PS(53.1,PSJDA1,0)) S DA=PSJDA1 D ORPRG:PSGOERRF S DIK="^PS(53.1,",DA=+PSJDA1 D ^DIK K DA,DIK
74 Q
Note: See TracBrowser for help on using the repository browser.