38 lines
2.8 KiB
Mathematica
38 lines
2.8 KiB
Mathematica
LRACF ;SLC/RWA - FORCE PAGES TO FULL ;2/19/91 10:10
|
|
;;5.2;LAB SERVICE;;Sep 27, 1994
|
|
QUEUE S U="^"
|
|
WARN W !,"This option will identify patients who have been inactive for the specified",!,"period of time defined in the GRACE PERIOD FOR INACTIVITY field of the"
|
|
W !,"Laboratory Site file and force their lab data onto a permanent cumulative page,",!,"making the data eligible for archiving.",!
|
|
W !,"The parameter is set for ( ",+$P(^LAB(69.9,1,0),U,13)," ) days ",!
|
|
WARN1 W !,"Are you sure you want to continue" S %=2 D YN^DICN Q:%=2!(%=-1) I %=0 G HELP
|
|
S ZTRTN="ENT^LRACF",ZTDESC="Force Cumulative data to Archive",LRFG=0 D IO^LRWU Q
|
|
ENT S U="^",LRFG=0
|
|
S:$D(ZTQUEUED) ZTREQ="@" U IO S X="N",%DT="T" D ^%DT
|
|
Q:'$L($P(^LAB(69.9,1,0),U,13)) S X1=DT,X2=-$P(^(0),U,13) D C^%DTC S LRDAYS=9999999-X_.5 D HDR S LRDFN=0 F S LRDFN=$O(^LR(LRDFN)) Q:LRDFN<1 D IDT
|
|
END K LRDAYS,LRDFN,LRDPF,LRFG,LRIDT,LRINO,LRNM,LRTXT,LRSPCM,LRSUB,LROPG,LRPG,LRPGE,LRPL
|
|
Q
|
|
IDT Q:'$D(^LR(LRDFN,0)) S LRDPF=$P(^(0),U,2),DFN=$P(^(0),U,3) Q:LRDPF'=2 S LRNM=$S($D(^DPT(DFN,0)):$P(^(0),U,1),1:"UNKNOWN") Q:$O(^LR(LRDFN,"CH",0))<LRDAYS
|
|
MORE S LRIDT=0 F S LRIDT=$O(^LRO(68,"AC",LRDFN,LRIDT)) Q:LRIDT<1 S LRSUB=0 F S LRSUB=$O(^LRO(68,"AC",LRDFN,LRIDT,LRSUB)) Q:LRSUB<1 D:LRSUB'=1 CHECK K ^LRO(68,"AC",LRDFN,LRIDT,LRSUB),LRPG,LROPG,LRPGE
|
|
KILL Q:LRFG=0 K ^LAC("LRAC",LRDFN),^LAC("LRKILL",LRDFN),^LAC("LGOT",LRDFN)
|
|
I $Y>(IOSL-7) D HDR
|
|
W !!,LRDFN,?10,LRNM S LRTXT="" F I=0:0 S LRTXT=$O(^TMP($J,LRTXT)) Q:LRTXT="" S ^LR(LRDFN,"PG",$P(LRTXT,"^",1))=LRTXT D TEXT
|
|
S LRFG=0 K ^TMP($J) Q
|
|
CHECK I '$D(^LR(LRDFN,"CH",LRIDT,LRSUB)) Q
|
|
S LRFG=1 D PAGE S:LROPG="" $P(^LR(LRDFN,"CH",LRIDT,0),U,9)=LRPGE,LROPG=$P(^(0),U,9) S:LROPG'[LRPGE $P(^LR(LRDFN,"CH",LRIDT,0),U,9)=LROPG_";"_LRPGE S ^TMP($J,LRPG)=""
|
|
Q
|
|
PAGE S LRPG="" D FIND S LRPL=$F(LRPG,"^"),LRPGE=$E(LRPG,1,LRPL-2)_":"_$E(LRPG,LRPL,$L(LRPG)),LROPG=$P(^LR(LRDFN,"CH",LRIDT,0),U,9) Q
|
|
FIND ;Since Major Header and Page number is unknown this subroutine
|
|
;determines the major header and page number to be assigned.
|
|
S LRSPCM=$P(^LR(LRDFN,"CH",LRIDT,0),"^",5)
|
|
S LRMH=0 F S LRMH=$O(^LAB(64.5,"AC",LRSUB,1,LRMH)) Q:'LRMH S LRSH=0 F S LRSH=$O(^LAB(64.5,"AC",LRSUB,1,LRMH,LRSH)) Q:'LRSH S LRTSTS=0 F S LRTSTS=$O(^LAB(64.5,"AC",LRSUB,1,LRMH,LRSH,LRTSTS)) Q:'LRTSTS D SPCM
|
|
I LRPG="" S LRPG=$S('$D(^LR(LRDFN,"PG","MISC")):"MISC^1",1:"MISC^"_($P(^LR(LRDFN,"PG","MISC"),"^",2)+1))
|
|
Q
|
|
SPCM S LRSPM1=$P(^LAB(64.5,"AC",LRSUB,1,LRMH,LRSH,LRTSTS),"^",1) Q:LRSPCM'=LRSPM1 I $D(^LR(LRDFN,"PG",LRMH)) S LRPG=LRMH_"^"_($P(^LR(LRDFN,"PG",LRMH),"^",2)+1) Q
|
|
S LRPG=LRMH_"^"_1
|
|
Q
|
|
HDR W @IOF,!,?20,"***** INACTIVE PATIENTS FOR ARCHIVE*****",!!
|
|
W "LRDFN"_" "_"PATIENT NAME"_" "_"PAGE FORCED TO PERMANENT"
|
|
Q
|
|
TEXT W ?57,LRTXT,! Q
|
|
HELP W !!,"Enter 'Yes' to continue, 'No' or '^' to exit" W ! G WARN1
|