LRACF ; IHS/DIR/FJE - FORCE PAGES TO FULL 10:10 ;
;;5.2;LR;**1013**;JUL 15, 2002
;
;;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
LRACF ; IHS/DIR/FJE - FORCE PAGES TO FULL 10:10 ;
+1 ;;5.2;LR;**1013**;JUL 15, 2002
+2 ;
+3 ;;5.2;LAB SERVICE;;Sep 27, 1994
QUEUE SET U="^"
WARN WRITE !,"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"
+1 WRITE !,"Laboratory Site file and force their lab data onto a permanent cumulative page,",!,"making the data eligible for archiving.",!
+2 WRITE !,"The parameter is set for ( ",+$PIECE(^LAB(69.9,1,0),U,13)," ) days ",!
WARN1 WRITE !,"Are you sure you want to continue"
SET %=2
DO YN^DICN
IF %=2!(%=-1)
QUIT
IF %=0
GOTO HELP
+1 SET ZTRTN="ENT^LRACF"
SET ZTDESC="Force Cumulative data to Archive"
SET LRFG=0
DO IO^LRWU
QUIT
ENT SET U="^"
SET LRFG=0
+1 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
USE IO
SET X="N"
SET %DT="T"
DO ^%DT
+2 IF '$LENGTH($PIECE(^LAB(69.9,1,0),U,13))
QUIT
SET X1=DT
SET X2=-$PIECE(^(0),U,13)
DO C^%DTC
SET LRDAYS=9999999-X_.5
DO HDR
SET LRDFN=0
FOR
SET LRDFN=$ORDER(^LR(LRDFN))
IF LRDFN<1
QUIT
DO IDT
END KILL LRDAYS,LRDFN,LRDPF,LRFG,LRIDT,LRINO,LRNM,LRTXT,LRSPCM,LRSUB,LROPG,LRPG,LRPGE,LRPL
+1 QUIT
IDT IF '$DATA(^LR(LRDFN,0))
QUIT
SET LRDPF=$PIECE(^(0),U,2)
SET DFN=$PIECE(^(0),U,3)
IF LRDPF'=2
QUIT
SET LRNM=$SELECT($DATA(^DPT(DFN,0)):$PIECE(^(0),U,1),1:"UNKNOWN")
IF $ORDER(^LR(LRDFN,"CH",0))<LRDAYS
QUIT
MORE SET LRIDT=0
FOR
SET LRIDT=$ORDER(^LRO(68,"AC",LRDFN,LRIDT))
IF LRIDT<1
QUIT
SET LRSUB=0
FOR
SET LRSUB=$ORDER(^LRO(68,"AC",LRDFN,LRIDT,LRSUB))
IF LRSUB<1
QUIT
IF LRSUB'=1
DO CHECK
KILL ^LRO(68,"AC",LRDFN,LRIDT,LRSUB),LRPG,LROPG,LRPGE
KILL IF LRFG=0
QUIT
KILL ^LAC("LRAC",LRDFN),^LAC("LRKILL",LRDFN),^LAC("LGOT",LRDFN)
+1 IF $Y>(IOSL-7)
DO HDR
+2 WRITE !!,LRDFN,?10,LRNM
SET LRTXT=""
FOR I=0:0
SET LRTXT=$ORDER(^TMP($JOB,LRTXT))
IF LRTXT=""
QUIT
SET ^LR(LRDFN,"PG",$PIECE(LRTXT,"^",1))=LRTXT
DO TEXT
+3 SET LRFG=0
KILL ^TMP($JOB)
QUIT
CHECK IF '$DATA(^LR(LRDFN,"CH",LRIDT,LRSUB))
QUIT
+1 SET LRFG=1
DO PAGE
IF LROPG=""
SET $PIECE(^LR(LRDFN,"CH",LRIDT,0),U,9)=LRPGE
SET LROPG=$PIECE(^(0),U,9)
IF LROPG'[LRPGE
SET $PIECE(^LR(LRDFN,"CH",LRIDT,0),U,9)=LROPG_";"_LRPGE
SET ^TMP($JOB,LRPG)=""
+2 QUIT
PAGE SET LRPG=""
DO FIND
SET LRPL=$FIND(LRPG,"^")
SET LRPGE=$EXTRACT(LRPG,1,LRPL-2)_":"_$EXTRACT(LRPG,LRPL,$LENGTH(LRPG))
SET LROPG=$PIECE(^LR(LRDFN,"CH",LRIDT,0),U,9)
QUIT
FIND ;Since Major Header and Page number is unknown this subroutine
+1 ;determines the major header and page number to be assigned.
+2 SET LRSPCM=$PIECE(^LR(LRDFN,"CH",LRIDT,0),"^",5)
+3 SET LRMH=0
FOR
SET LRMH=$ORDER(^LAB(64.5,"AC",LRSUB,1,LRMH))
IF 'LRMH
QUIT
SET LRSH=0
FOR
SET LRSH=$ORDER(^LAB(64.5,"AC",LRSUB,1,LRMH,LRSH))
IF 'LRSH
QUIT
SET LRTSTS=0
FOR
SET LRTSTS=$ORDER(^LAB(64.5,"AC",LRSUB,1,LRMH,LRSH,LRTSTS))
IF 'LRTSTS
QUIT
DO SPCM
+4 IF LRPG=""
SET LRPG=$SELECT('$DATA(^LR(LRDFN,"PG","MISC")):"MISC^1",1:"MISC^"_($PIECE(^LR(LRDFN,"PG","MISC"),"^",2)+1))
+5 QUIT
SPCM SET LRSPM1=$PIECE(^LAB(64.5,"AC",LRSUB,1,LRMH,LRSH,LRTSTS),"^",1)
IF LRSPCM'=LRSPM1
QUIT
IF $DATA(^LR(LRDFN,"PG",LRMH))
SET LRPG=LRMH_"^"_($PIECE(^LR(LRDFN,"PG",LRMH),"^",2)+1)
QUIT
+1 SET LRPG=LRMH_"^"_1
+2 QUIT
HDR WRITE @IOF,!,?20,"***** INACTIVE PATIENTS FOR ARCHIVE*****",!!
+1 WRITE "LRDFN"_" "_"PATIENT NAME"_" "_"PAGE FORCED TO PERMANENT"
+2 QUIT
TEXT WRITE ?57,LRTXT,!
QUIT
HELP WRITE !!,"Enter 'Yes' to continue, 'No' or '^' to exit"
WRITE !
GOTO WARN1
