source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRACF.m@ 1006

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

initial load of WorldVistAEHR

File size: 2.8 KB
Line 
1LRACF ;SLC/RWA - FORCE PAGES TO FULL ;2/19/91 10:10
2 ;;5.2;LAB SERVICE;;Sep 27, 1994
3QUEUE S U="^"
4WARN 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 ",!
7WARN1 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
9ENT 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
12END K LRDAYS,LRDFN,LRDPF,LRFG,LRIDT,LRINO,LRNM,LRTXT,LRSPCM,LRSUB,LROPG,LRPG,LRPGE,LRPL
13 Q
14IDT 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
15MORE 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
16KILL 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
20CHECK 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
23PAGE 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
24FIND ;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
30SPCM 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
33HDR W @IOF,!,?20,"***** INACTIVE PATIENTS FOR ARCHIVE*****",!!
34 W "LRDFN"_" "_"PATIENT NAME"_" "_"PAGE FORCED TO PERMANENT"
35 Q
36TEXT W ?57,LRTXT,! Q
37HELP W !!,"Enter 'Yes' to continue, 'No' or '^' to exit" W ! G WARN1
Note: See TracBrowser for help on using the repository browser.