- 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