| 1 | LRACF ;SLC/RWA - FORCE PAGES TO FULL ;2/19/91 10:10
|
|---|
| 2 | ;;5.2;LAB SERVICE;;Sep 27, 1994
|
|---|
| 3 | QUEUE S U="^"
|
|---|
| 4 | 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"
|
|---|
| 5 | W !,"Laboratory Site file and force their lab data onto a permanent cumulative page,",!,"making the data eligible for archiving.",!
|
|---|
| 6 | W !,"The parameter is set for ( ",+$P(^LAB(69.9,1,0),U,13)," ) days ",!
|
|---|
| 7 | WARN1 W !,"Are you sure you want to continue" S %=2 D YN^DICN Q:%=2!(%=-1) I %=0 G HELP
|
|---|
| 8 | S ZTRTN="ENT^LRACF",ZTDESC="Force Cumulative data to Archive",LRFG=0 D IO^LRWU Q
|
|---|
| 9 | ENT S U="^",LRFG=0
|
|---|
| 10 | S:$D(ZTQUEUED) ZTREQ="@" U IO S X="N",%DT="T" D ^%DT
|
|---|
| 11 | 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
|
|---|
| 12 | END K LRDAYS,LRDFN,LRDPF,LRFG,LRIDT,LRINO,LRNM,LRTXT,LRSPCM,LRSUB,LROPG,LRPG,LRPGE,LRPL
|
|---|
| 13 | Q
|
|---|
| 14 | 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
|
|---|
| 15 | 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
|
|---|
| 16 | KILL Q:LRFG=0 K ^LAC("LRAC",LRDFN),^LAC("LRKILL",LRDFN),^LAC("LGOT",LRDFN)
|
|---|
| 17 | I $Y>(IOSL-7) D HDR
|
|---|
| 18 | 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
|
|---|
| 19 | S LRFG=0 K ^TMP($J) Q
|
|---|
| 20 | CHECK I '$D(^LR(LRDFN,"CH",LRIDT,LRSUB)) Q
|
|---|
| 21 | 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)=""
|
|---|
| 22 | Q
|
|---|
| 23 | 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
|
|---|
| 24 | FIND ;Since Major Header and Page number is unknown this subroutine
|
|---|
| 25 | ;determines the major header and page number to be assigned.
|
|---|
| 26 | S LRSPCM=$P(^LR(LRDFN,"CH",LRIDT,0),"^",5)
|
|---|
| 27 | 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
|
|---|
| 28 | I LRPG="" S LRPG=$S('$D(^LR(LRDFN,"PG","MISC")):"MISC^1",1:"MISC^"_($P(^LR(LRDFN,"PG","MISC"),"^",2)+1))
|
|---|
| 29 | Q
|
|---|
| 30 | 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
|
|---|
| 31 | S LRPG=LRMH_"^"_1
|
|---|
| 32 | Q
|
|---|
| 33 | HDR W @IOF,!,?20,"***** INACTIVE PATIENTS FOR ARCHIVE*****",!!
|
|---|
| 34 | W "LRDFN"_" "_"PATIENT NAME"_" "_"PAGE FORCED TO PERMANENT"
|
|---|
| 35 | Q
|
|---|
| 36 | TEXT W ?57,LRTXT,! Q
|
|---|
| 37 | HELP W !!,"Enter 'Yes' to continue, 'No' or '^' to exit" W ! G WARN1
|
|---|
