LRCHIVE.m

LRCHIVE ; IHS/DIR/FJE - REMOVE OLD DATA FROM PT. FILE 8/10/89 11:11 ;

 ;;5.2;LR;**1013**;JUL 15, 2002

 ;

 ;;5.2;LAB SERVICE;;Sep 27, 1994

 Q  ;C2=NUMBER OF PT, C3=NUMBER OF DATES

MOVE S LRCNT=$P(^LR(LRDFN,LRSS,0),U,3,4) S:LRSS="CH" ^LAR("Z",LRDFN,LRSS,0)="^63.999904D^"_LRCNT S:LRSS="MI" ^LAR("Z",LRDFN,LRSS,0)="^63.999905DA^"_LRCNT S %X="^LR(LRDFN,LRSS,LRIDT,",%Y="^LAR(""Z"",LRDFN,LRSS,LRIDT," D %XY^%RCR

 ;S:C1 C2=C2+1,C1=0,^LAR("Z",LRDFN,0)=^LR(LRDFN,0),^LAR("Z","B",LRDFN,LRDFN)="",^LAR("NAME",PNM,LRDFN)="",^LAR("SSN",SSN,LRDFN)="" S C3=C3+1 Q

 S:C1 C2=C2+1,C1=0,^LAR("Z",LRDFN,0)=^LR(LRDFN,0),^LAR("Z","B",LRDFN,LRDFN)="",^LAR("NAME",PNM,LRDFN)="",^LAR("HRCN",HRCN,LRDFN)="" S C3=C3+1 Q  ;IHS/ANMC/CLS 11/1/95 left "SSN" but not used in ^LRCHIVD, killed in ^LRCHIV

PT ;S PNM="unk",SSN="unk"

 S PNM="unk",SSN="unk",HRCN="unk"  ;IHS/ANMC/CLS 11/1/95

 Q:LRDPF<1  D DEM^LRX

 ;S:SSN="" SSN="unk" S:PNM="" PNM="unk" Q

 S:SSN="" SSN="unk" S:PNM="" PNM="unk" S:HRCN=""!("??") HRCN="unk" Q  ;IHS/ANMC/CLS 11/1/95

DFN ;from LRCHIV

 S LRDFN=$O(^LR(LRDFN)) G TEND:LRDFN'>0 W "."

 G NO0:$D(^LR(LRDFN,0))[0 S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3) I +LRDPF=2

 S C1=1 D PT

 F LRSS="CH","MI" I $D(^LR(LRDFN,LRSS,0)) D LAB

 S ^LAB(69.9,1,"LRDFN")=LRDFN G DFN

TEND W !!,"SEARCH PASS DONE" D STAMP^LRX W !,"Total patient count: ",C2,". Specimen count: ",C3,! K LRDFN Q

LAB S LRIDT=$O(^LR(LRDFN,LRSS,$S(LRSS="MI":LR(3),1:LR(2)))) Q:LRIDT<1  S LRIDT=LRIDT-.1

LAB1 S LRIDT=$O(^LR(LRDFN,LRSS,LRIDT)) I LRIDT<1 D UPDT^LRCHIVK Q

 IF $D(^LR(LRDFN,LRSS,LRIDT,0))[0 U IO W !,"BAD DATA ",LRDFN,LRSS,LRIDT," KILLED" K ^LR(LRDFN,LRSS,LRIDT) G LAB1

 S LRDAT=^LR(LRDFN,LRSS,LRIDT,0)

 IF LRSS="CH",'$P(LRDAT,U,3) U IO W !,"KILLED UNVERIFIED DATA ",LRDFN,LRSS,LRIDT K ^LR(LRDFN,LRSS,LRIDT) G LAB1

 IF $O(^LR(LRDFN,LRSS,LRIDT,0))="" U IO W !,"KILLED HEADER WITH NO DATA ",LRDFN,LRSS,LRIDT K ^LR(LRDFN,LRSS,LRIDT) G LAB1

 I LRSS="CH",LRDPF=2,'$L($P(LRDAT,U,9)) G LAB1 ;NOT ON CUM CHART PAGE

 D MOVE

 G LAB1

RCC ;REMOVE CONTROL CHAR.

 S X=LRDAT,LRDAT="" F I=1:1:$L(X) S LRDAT=LRDAT_$S($A(X,I)>126:"",$A(X,I)>31:$E(X,I),1:"")

 S ^LR(LRDFN,LRSS,LRIDT,I1)=LRDAT Q

NO0 U IO W !,"NO 0 NODE FOR ^LR(",LRDFN G DFN

LRCHIVE   ; IHS/DIR/FJE - REMOVE OLD DATA FROM PT. FILE 8/10/89 11:11 ;

 +1       ;;5.2;LR;**1013**;JUL 15, 2002

 +2       ;

 +3       ;;5.2;LAB SERVICE;;Sep 27, 1994

 +4       ;C2=NUMBER OF PT, C3=NUMBER OF DATES

           QUIT 

MOVE       SET LRCNT=$PIECE(^LR(LRDFN,LRSS,0),U,3,4)

           IF LRSS="CH"

               SET ^LAR("Z",LRDFN,LRSS,0)="^63.999904D^"_LRCNT

           IF LRSS="MI"

               SET ^LAR("Z",LRDFN,LRSS,0)="^63.999905DA^"_LRCNT

           SET %X="^LR(LRDFN,LRSS,LRIDT,"

           SET %Y="^LAR(""Z"",LRDFN,LRSS,LRIDT,"

           DO %XY^%RCR

 +1       ;S:C1 C2=C2+1,C1=0,^LAR("Z",LRDFN,0)=^LR(LRDFN,0),^LAR("Z","B",LRDFN,LRDFN)="",^LAR("NAME",PNM,LRDFN)="",^LAR("SSN",SSN,LRDFN)="" S C3=C3+1 Q

 +2       ;IHS/ANMC/CLS 11/1/95 left "SSN" but not used in ^LRCHIVD, killed in ^LRCHIV

           IF C1

               SET C2=C2+1

               SET C1=0

               SET ^LAR("Z",LRDFN,0)=^LR(LRDFN,0)

               SET ^LAR("Z","B",LRDFN,LRDFN)=""

               SET ^LAR("NAME",PNM,LRDFN)=""

               SET ^LAR("HRCN",HRCN,LRDFN)=""

           SET C3=C3+1

           QUIT 

PT        ;S PNM="unk",SSN="unk"

 +1       ;IHS/ANMC/CLS 11/1/95

           SET PNM="unk"

           SET SSN="unk"

           SET HRCN="unk"

 +2        IF LRDPF<1

               QUIT 

           DO DEM^LRX

 +3       ;S:SSN="" SSN="unk" S:PNM="" PNM="unk" Q

 +4       ;IHS/ANMC/CLS 11/1/95

           IF SSN=""

               SET SSN="unk"

           IF PNM=""

               SET PNM="unk"

           IF HRCN=""!("??")

               SET HRCN="unk"

           QUIT 

DFN       ;from LRCHIV

 +1        SET LRDFN=$ORDER(^LR(LRDFN))

           IF LRDFN'>0

               GOTO TEND

           WRITE "."

 +2        IF $DATA(^LR(LRDFN,0))[0

               GOTO NO0

           SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)

           SET DFN=$PIECE(^(0),U,3)

           IF +LRDPF=2

 +3        SET C1=1

           DO PT

 +4        FOR LRSS="CH","MI"

               IF $DATA(^LR(LRDFN,LRSS,0))

                   DO LAB

 +5        SET ^LAB(69.9,1,"LRDFN")=LRDFN

           GOTO DFN

TEND       WRITE !!,"SEARCH PASS DONE"

           DO STAMP^LRX

           WRITE !,"Total patient count: ",C2,". Specimen count: ",C3,!

           KILL LRDFN

           QUIT 

LAB        SET LRIDT=$ORDER(^LR(LRDFN,LRSS,$SELECT(LRSS="MI":LR(3),1:LR(2))))

           IF LRIDT<1

               QUIT 

           SET LRIDT=LRIDT-.1

LAB1       SET LRIDT=$ORDER(^LR(LRDFN,LRSS,LRIDT))

           IF LRIDT<1

               DO UPDT^LRCHIVK

               QUIT 

 +1        IF $DATA(^LR(LRDFN,LRSS,LRIDT,0))[0

               USE IO

               WRITE !,"BAD DATA ",LRDFN,LRSS,LRIDT," KILLED"

               KILL ^LR(LRDFN,LRSS,LRIDT)

               GOTO LAB1

 +2        SET LRDAT=^LR(LRDFN,LRSS,LRIDT,0)

 +3        IF LRSS="CH"

               IF '$PIECE(LRDAT,U,3)

                   USE IO

                   WRITE !,"KILLED UNVERIFIED DATA ",LRDFN,LRSS,LRIDT

                   KILL ^LR(LRDFN,LRSS,LRIDT)

                   GOTO LAB1

 +4        IF $ORDER(^LR(LRDFN,LRSS,LRIDT,0))=""

               USE IO

               WRITE !,"KILLED HEADER WITH NO DATA ",LRDFN,LRSS,LRIDT

               KILL ^LR(LRDFN,LRSS,LRIDT)

               GOTO LAB1

 +5       ;NOT ON CUM CHART PAGE

           IF LRSS="CH"

               IF LRDPF=2

                   IF '$LENGTH($PIECE(LRDAT,U,9))

                       GOTO LAB1

 +6        DO MOVE

 +7        GOTO LAB1

RCC       ;REMOVE CONTROL CHAR.

 +1        SET X=LRDAT

           SET LRDAT=""

           FOR I=1:1:$LENGTH(X)

               SET LRDAT=LRDAT_$SELECT($ASCII(X,I)>126:"",$ASCII(X,I)>31:$EXTRACT(X,I),1:"")

 +2        SET ^LR(LRDFN,LRSS,LRIDT,I1)=LRDAT

           QUIT 

NO0        USE IO

           WRITE !,"NO 0 NODE FOR ^LR(",LRDFN

           GOTO DFN