PSGBRJ ;BIR/CML3-UD JANITOR (BACKGROUND TASKMAN JOB) ; 6/4/10 9:57am
;;5.0;INPATIENT MEDICATIONS;**12,50,244,317,432**;16 DEC 97;Build 18
;
; Reference to ^PS(55 is supported by DBIA# 2191.
; Reference to ^PS(59.7 is supported by DBIA# 2181.
;
LK ; kill off old labels
D NOW^%DTC S (PSGBRJDT,PSGDT)=%,^PS(53.42,PSGBRJDT,0)=PSGBRJDT,PSJACIVF=1
F PSGL1=1,2 D
.F PSGL2=0:0 S PSGL2=$O(^PS(53.41,PSGL1,1,PSGL2)) Q:'PSGL2 D
..F PSGL3=0:0 S PSGL3=$O(^PS(53.41,PSGL1,1,PSGL2,1,PSGL3)) Q:'PSGL3 D
...S PSGKD=$$LABELDT(PSGL3,PSGDT)
...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
....S X=$P($G(^PS(53.41,PSGL1,1,PSGL2,1,PSGL3,1,PSGL4,1,PSGL5,0)),"^",3)
....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
;
AK ; kill off all orders in 53.1 that have gone active (into 55)
N PSJNO,PSJNOACT,ON100 S PSJNOACT=1
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
. S ON100=+$P($G(^PS(53.1,DA,0)),U,21) I '$D(^XTMP("ORLK-"_$G(ON100))) D ^DIK ;*PSJ*5*244 - Check for lock
;
DE ; kill off de orders in 53.1 that no longer tie to order in 55
S X="ORX" X ^%ZOSF("TEST") S PSGOERRF=$T
NEW PSJDA,ON K ^TMP($J)
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
. I ON["A"!(ON["O")!(ON["U") S:'$D(^PS(55,PSGP,5,+ON,0)) ^TMP($J,PSJDA)=PSGP Q
. I ON["V" S:'$D(^PS(55,PSGP,"IV",+ON,0)) ^TMP($J,PSJDA)=PSGP Q
. I '$D(^PS(53.1,+ON,0)) S ^TMP($J,PSJDA)=PSGP Q
F PSJDA=0:0 S PSJDA=$O(^TMP($J,PSJDA)) Q:'PSJDA D:$D(^PS(53.1,PSJDA,0)) PDE(PSJDA,^TMP($J,PSJDA))
K ^TMP($J)
;
DK ; kill off dc'd orders in 53.1 around longer than life of labels
N PSJNOACT S PSJNOACT=1
S X="ORX" X ^%ZOSF("TEST") S PSGOERRF=$T
F PSGP=0:0 S PSGP=$O(^PS(53.1,"AS","D",PSGP)) Q:'PSGP D
.S PSGKD=$$LABELDT(PSGP,PSGDT) F DA=0:0 S DA=$O(^PS(53.1,"AS","D",PSGP,DA)) Q:'DA D
..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
;
PLP ; purge pick lists that are filed away and older than auto purge days
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
.K DA,DIK,^PS(53.5,"AU",Y) S DIK="^PS(53.5,",DA=Y D ^DIK
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
;
GLK ; kill off entries in ^PS(53.42) 20 days or more old
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)
;
UPARAM ; 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.
S DA=0 F S DA=$O(^PS(53.45,DA)) Q:'DA D
.I '$D(^VA(200,DA)) S DIK="^PS(53.45," D ^DIK K DIK Q
.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
;
NVK ; *PSJ*5*244 - kill discontinued orders from non-verified X-refs
N DFN,ON,PSGREF,X
S PSGREF(1)="ANV",PSGREF(2)="APV",PSGREF(3)="ANIV",PSGREF(4)="APIV"
F X=1:1:4 D
. F DFN=0:0 S DFN=$O(^PS(55,PSGREF(X),DFN)) Q:'DFN D
.. F ON=0:0 S ON=$O(^PS(55,PSGREF(X),DFN,ON)) Q:'ON D
... I $P($G(^PS(55,DFN,5,ON,0)),U,9)["D" K ^PS(55,PSGREF(X),DFN,ON)
;
PADE ; *317 - kill messages older than 90 days
N D,PDT,PDI S X1=DT,X2=-90 D C^%DTC S D=0,PDT=X,DIK="^PS(58.72,"
F S D=$O(^PS(58.72,"B",D)) Q:'D!(D>PDT) D
.S PDI=0 F S PDI=$O(^PS(58.72,"B",D,PDI)) Q:'PDI S DA=PDI D ^DIK
Q
;
DONE ;
S:$D(ZTQUEUED) ZTREQ="@"
D NOW^%DTC S $P(^PS(53.42,PSGBRJDT,0),"^",2)=%
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
;
ORPRG ;
;*** COMMENT OUT FOR NOW. NEED TO GET BACK WITH MELANIE TO SEE
;*** WHAT TO BE DONE WHEN WE PURGE INPATIENT MEDS ORDERS. 7/19/96.
; removed old call to ORX routine!
Q
LABELDT(PSGP,X1) ; Find patient's ward and get days to keep new labels.
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)
D C^%DTC
Q X
;
PDE(PSJDA1,PSGP) ;Remove all related pending orders with the "DE" status.
N DA,DIK,PDE,PSJNUM,PDEFLG,PSJ55,PSJNOACT S (PDEFLG,PSJ55)=0,PSJNOACT=1
F S PSJNUM=$P($G(^PS(53.1,PSJDA1,0)),U,25) Q:'+PSJNUM D Q:PSJ55
. I PSJNUM["A"!(PSJNUM["O")!(PSJNUM["U") S PSJ55=1 I $D(^PS(55,PSGP,5,+PSJNUM,0)) S PDEFLG=1 Q
. I PSJNUM["V" S PSJ55=1 I $D(^PS(55,PSGP,"IV",+PSJNUM,0)) S PDEFLG=1 Q
. S PDE(PSJDA1)="",PSJDA1=+PSJNUM
S:'PSJ55 PDE(PSJDA1)=""
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
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGBRJ 5096 printed Oct 16, 2024@18:01:38 Page 2
PSGBRJ ;BIR/CML3-UD JANITOR (BACKGROUND TASKMAN JOB) ; 6/4/10 9:57am
+1 ;;5.0;INPATIENT MEDICATIONS;**12,50,244,317,432**;16 DEC 97;Build 18
+2 ;
+3 ; Reference to ^PS(55 is supported by DBIA# 2191.
+4 ; Reference to ^PS(59.7 is supported by DBIA# 2181.
+5 ;
LK ; kill off old labels
+1 DO NOW^%DTC
SET (PSGBRJDT,PSGDT)=%
SET ^PS(53.42,PSGBRJDT,0)=PSGBRJDT
SET PSJACIVF=1
+2 FOR PSGL1=1,2
Begin DoDot:1
+3 FOR PSGL2=0:0
SET PSGL2=$ORDER(^PS(53.41,PSGL1,1,PSGL2))
if 'PSGL2
QUIT
Begin DoDot:2
+4 FOR PSGL3=0:0
SET PSGL3=$ORDER(^PS(53.41,PSGL1,1,PSGL2,1,PSGL3))
if 'PSGL3
QUIT
Begin DoDot:3
+5 SET PSGKD=$$LABELDT(PSGL3,PSGDT)
+6 FOR PSGL4=1,2,3
FOR PSGL5=0:0
SET PSGL5=$ORDER(^PS(53.41,PSGL1,1,PSGL2,1,PSGL3,1,PSGL4,1,PSGL5))
if 'PSGL5
QUIT
Begin DoDot:4
+7 SET X=$PIECE($GET(^PS(53.41,PSGL1,1,PSGL2,1,PSGL3,1,PSGL4,1,PSGL5,0)),"^",3)
+8 IF X<PSGKD
KILL DA
SET DIK="^PS(53.41,"_PSGL1_",1,"_PSGL2_",1,"_PSGL3_",1,"_PSGL4_",1,"
SET DA(4)=PSGL1
SET DA(3)=PSGL2
SET DA(2)=PSGL3
SET DA(1)=PSGL4
SET DA=PSGL5
DO ^DIK
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+9 ;
AK ; kill off all orders in 53.1 that have gone active (into 55)
+1 NEW PSJNO,PSJNOACT,ON100
SET PSJNOACT=1
+2 SET DIK="^PS(53.1,"
FOR PSGP=0:0
SET PSGP=$ORDER(^PS(53.1,"AS","A",PSGP))
if 'PSGP
QUIT
FOR PSJNO=0:0
SET PSJNO=$ORDER(^PS(53.1,"AS","A",PSGP,PSJNO))
if 'PSJNO
QUIT
SET DA=PSJNO
Begin DoDot:1
+3 ;*PSJ*5*244 - Check for lock
SET ON100=+$PIECE($GET(^PS(53.1,DA,0)),U,21)
IF '$DATA(^XTMP("ORLK-"_$GET(ON100)))
DO ^DIK
End DoDot:1
+4 ;
DE ; kill off de orders in 53.1 that no longer tie to order in 55
+1 SET X="ORX"
XECUTE ^%ZOSF("TEST")
SET PSGOERRF=$TEST
+2 NEW PSJDA,ON
KILL ^TMP($JOB)
+3 FOR PSGP=0:0
SET PSGP=$ORDER(^PS(53.1,"AS","DE",PSGP))
if 'PSGP
QUIT
FOR PSJDA=0:0
SET PSJDA=$ORDER(^PS(53.1,"AS","DE",PSGP,PSJDA))
if 'PSJDA
QUIT
SET ON=$PIECE($GET(^PS(53.1,PSJDA,0)),U,26)
Begin DoDot:1
+4 IF ON["A"!(ON["O")!(ON["U")
if '$DATA(^PS(55,PSGP,5,+ON,0))
SET ^TMP($JOB,PSJDA)=PSGP
QUIT
+5 IF ON["V"
if '$DATA(^PS(55,PSGP,"IV",+ON,0))
SET ^TMP($JOB,PSJDA)=PSGP
QUIT
+6 IF '$DATA(^PS(53.1,+ON,0))
SET ^TMP($JOB,PSJDA)=PSGP
QUIT
End DoDot:1
+7 FOR PSJDA=0:0
SET PSJDA=$ORDER(^TMP($JOB,PSJDA))
if 'PSJDA
QUIT
if $DATA(^PS(53.1,PSJDA,0))
DO PDE(PSJDA,^TMP($JOB,PSJDA))
+8 KILL ^TMP($JOB)
+9 ;
DK ; kill off dc'd orders in 53.1 around longer than life of labels
+1 NEW PSJNOACT
SET PSJNOACT=1
+2 SET X="ORX"
XECUTE ^%ZOSF("TEST")
SET PSGOERRF=$TEST
+3 FOR PSGP=0:0
SET PSGP=$ORDER(^PS(53.1,"AS","D",PSGP))
if 'PSGP
QUIT
Begin DoDot:1
+4 SET PSGKD=$$LABELDT(PSGP,PSGDT)
FOR DA=0:0
SET DA=$ORDER(^PS(53.1,"AS","D",PSGP,DA))
if 'DA
QUIT
Begin DoDot:2
+5 SET S=$PIECE($GET(^PS(53.1,DA,0)),"^",9)
SET ST=$PIECE($GET(^(2)),"^",3)
IF $SELECT(S="U":1,S="P":1,1:ST<PSGKD)
if PSGOERRF
DO ORPRG
SET DIK="^PS(53.1,"
DO ^DIK
End DoDot:2
End DoDot:1
+6 ;
PLP ; purge pick lists that are filed away and older than auto purge days
+1 IF $DATA(^PS(59.7,1,63.5))
IF ^(63.5)
SET X2=-^(63.5)
SET X1=DT
DO C^%DTC
SET PSJX=X
FOR Q=0:0
SET Q=$ORDER(^PS(53.5,"AO",Q))
if 'Q
QUIT
FOR QQ=0:0
SET QQ=$ORDER(^PS(53.5,"AO",Q,QQ))
if 'QQ!(QQ>PSJX)
QUIT
SET Y=$ORDER(^(QQ,0))
IF Y
Begin DoDot:1
+2 KILL DA,DIK,^PS(53.5,"AU",Y)
SET DIK="^PS(53.5,"
SET DA=Y
DO ^DIK
End DoDot:1
+3 FOR PSJX=0:0
SET PSJX=$ORDER(^PS(53.55,PSJX))
if 'PSJX
QUIT
IF '$DATA(^PS(53.5,PSJX))
KILL DA,DIK
SET DA=PSJX
SET DIK="^PS(53.55,"
DO ^DIK
+4 ;
GLK ; kill off entries in ^PS(53.42) 20 days or more old
+1 SET X1=DT
SET X2=-20
DO C^%DTC
FOR D=0:0
SET D=$ORDER(^PS(53.42,D))
if 'D!(D'<X)
QUIT
KILL ^(D)
+2 ;
UPARAM ; 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.
+1 SET DA=0
FOR
SET DA=$ORDER(^PS(53.45,DA))
if 'DA
QUIT
Begin DoDot:1
+2 IF '$DATA(^VA(200,DA))
SET DIK="^PS(53.45,"
DO ^DIK
KILL DIK
QUIT
+3 SET PSGX=$PIECE(^VA(200,DA,0),"^",11)
SET PSGX=$SELECT(PSGX="":9999999,1:PSGX)
IF PSGX<DT
SET DIK="^PS(53.45,"
DO ^DIK
KILL DIK
End DoDot:1
+4 ;
NVK ; *PSJ*5*244 - kill discontinued orders from non-verified X-refs
+1 NEW DFN,ON,PSGREF,X
+2 SET PSGREF(1)="ANV"
SET PSGREF(2)="APV"
SET PSGREF(3)="ANIV"
SET PSGREF(4)="APIV"
+3 FOR X=1:1:4
Begin DoDot:1
+4 FOR DFN=0:0
SET DFN=$ORDER(^PS(55,PSGREF(X),DFN))
if 'DFN
QUIT
Begin DoDot:2
+5 FOR ON=0:0
SET ON=$ORDER(^PS(55,PSGREF(X),DFN,ON))
if 'ON
QUIT
Begin DoDot:3
+6 IF $PIECE($GET(^PS(55,DFN,5,ON,0)),U,9)["D"
KILL ^PS(55,PSGREF(X),DFN,ON)
End DoDot:3
End DoDot:2
End DoDot:1
+7 ;
PADE ; *317 - kill messages older than 90 days
+1 NEW D,PDT,PDI
SET X1=DT
SET X2=-90
DO C^%DTC
SET D=0
SET PDT=X
SET DIK="^PS(58.72,"
+2 FOR
SET D=$ORDER(^PS(58.72,"B",D))
if 'D!(D>PDT)
QUIT
Begin DoDot:1
+3 SET PDI=0
FOR
SET PDI=$ORDER(^PS(58.72,"B",D,PDI))
if 'PDI
QUIT
SET DA=PDI
DO ^DIK
End DoDot:1
+4 QUIT
+5 ;
DONE ;
+1 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 DO NOW^%DTC
SET $PIECE(^PS(53.42,PSGBRJDT,0),"^",2)=%
+3 DO ENKV^PSGSETU
KILL CA,D,DA,DFN,DIK,DND,GOTO,PSGL1,PSGL2,PSGL3,PSGL4,PSGL4,PSGKD,PSGOERRF,PSGX,PSJACIVF,PSJX,PSGBRJDT,S,ST,X1,X2
QUIT
+4 ;
ORPRG ;
+1 ;*** COMMENT OUT FOR NOW. NEED TO GET BACK WITH MELANIE TO SEE
+2 ;*** WHAT TO BE DONE WHEN WE PURGE INPATIENT MEDS ORDERS. 7/19/96.
+3 ; removed old call to ORX routine!
+4 QUIT
LABELDT(PSGP,X1) ; Find patient's ward and get days to keep new labels.
+1 SET X=$GET(^DPT(PSGP,.1))
SET X2=0
IF X]""
SET X=+$ORDER(^DIC(42,"B",X,0))
SET X=+$ORDER(^PS(59.6,"B",X,0))
SET X2=-$PIECE($GET(^PS(59.6,X,0)),U,11)
+2 DO C^%DTC
+3 QUIT X
+4 ;
PDE(PSJDA1,PSGP) ;Remove all related pending orders with the "DE" status.
+1 NEW DA,DIK,PDE,PSJNUM,PDEFLG,PSJ55,PSJNOACT
SET (PDEFLG,PSJ55)=0
SET PSJNOACT=1
+2 FOR
SET PSJNUM=$PIECE($GET(^PS(53.1,PSJDA1,0)),U,25)
if '+PSJNUM
QUIT
Begin DoDot:1
+3 IF PSJNUM["A"!(PSJNUM["O")!(PSJNUM["U")
SET PSJ55=1
IF $DATA(^PS(55,PSGP,5,+PSJNUM,0))
SET PDEFLG=1
QUIT
+4 IF PSJNUM["V"
SET PSJ55=1
IF $DATA(^PS(55,PSGP,"IV",+PSJNUM,0))
SET PDEFLG=1
QUIT
+5 SET PDE(PSJDA1)=""
SET PSJDA1=+PSJNUM
End DoDot:1
if PSJ55
QUIT
+6 if 'PSJ55
SET PDE(PSJDA1)=""
+7 IF 'PDEFLG
IF $ORDER(PDE(0))
FOR PSJDA1=0:0
SET PSJDA1=$ORDER(PDE(PSJDA1))
if 'PSJDA1
QUIT
IF $DATA(^PS(53.1,PSJDA1,0))
SET DA=PSJDA1
if PSGOERRF
DO ORPRG
SET DIK="^PS(53.1,"
SET DA=+PSJDA1
DO ^DIK
KILL DA,DIK
+8 QUIT
+9 ;
