LRAC1.m

LRAC1 ; IHS/DIR/FJE - CUMULATIVE CONT. 2/19/91 09:55 ;MAY 06, 2009 9:58 AM

 ;;5.2T1;LAB SERVICE;**1013,1026**;NOV 01, 1997

 ;

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

LRDFN S LRTNN=2

 ;F LRDFN=LRDFN:0 S LRDFN=$O(^LRO(69,LRDT,1,"AR",LRLLOC,LRNM,LRDFN)) K LRTRUE Q:LRDFN<1  I LRRE!('^(LRDFN)) S LRIL=1 D PAT S:LRLLOC["FILE ROOM" ^TMP($J,"SSN",$S(LRDPF=2:"A"_$E(SSN,10,11)_$E(SSN,8,9)_$E(SSN,1,3)_$E(SSN,5,6),1:LRNM),LRDFN)=""

 F LRDFN=LRDFN:0 S LRDFN=$O(^LRO(69,LRDT,1,"AR",LRLLOC,LRNM,LRDFN)) K LRTRUE Q:LRDFN<1  I LRRE!('^(LRDFN)) S LRIL=1 D PAT,IHS  ;IHS/ANMC/CLS 11/1/95

 Q

IHS ;IHS/ANMC/CLS 10/04/92 sort FILE ROOM by HRCN terminal digit order

 S:LRLLOC["FILE ROOM" HRCNT=HRCN+10000000,HRCNT=$E(HRCNT,7,8)_$E(HRCNT,5,6)_$E(HRCNT,3,4)_$E(HRCNT,2),^TMP($J,"HRCN",$S(LRDPF=2:"A"_HRCNT,1:LRNM),LRDFN)=""  ;IHS/ANMC/CLS 11/1/95

 Q

PAT ;from LRACM3

 Q:$D(^LR(LRDFN,0))[0

 S DFN=$P(^LR(LRDFN,0),U,3),LRDPF=+$P(^(0),U,2)

 ;D PT^LRX Q:LRLLOC["FILE ROOM"  S SSN=" "_SSN_" "

 D PT^LRX Q:LRLLOC["FILE ROOM"  S HRCN=" "_HRCN_" "  ;IHS/ANMC/CLS 11/1/95

PAT1 ;from LRACFILE

 L +^LAC(LRXLR,LRDFN) I '$D(^LAC(LRXLR,LRDFN,0)) S ^(0)=LRDFN,^LAC(LRXLR,"B",LRDFN,LRDFN)="",LRZO="^LAC("""_LRXLR_""",",LRZ1=64.7,LRZ3=LRDFN D Z^LRWU

 S:'$D(^LAC(LRXLR,LRDFN,"MISC",1,0)) ^(0)="MISCELLANEOUS TESTS^"

 D:'$D(LRCALE) LRCALE^LRAC2 DO:'LRRE FIDT DO ENT^LRAC3 K LRMISC

 ; I 'LRRE S $P(^LAC(LRXLR,LRDFN,0),U,2)=LRDT S:$D(LRRPTN) $P(^LAB(64.5,1,3,LRRPTN,0),U,4,6)=LRLLOC_U_LRNM_U_LRDFN S $P(^LRO(69,LRDT,1,"AR",LRLLOC,LRNM,LRDFN),U)=1

 ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1026 - Make sure LRLLOC variable exists

 I 'LRRE D

 . S $P(^LAC(LRXLR,LRDFN,0),U,2)=LRDT

 . S:$D(LRRPTN)&($G(LRLLOC)'="") $P(^LAB(64.5,1,3,LRRPTN,0),U,4,6)=LRLLOC_U_LRNM_U_LRDFN

 . S:$G(LRLLOC)'="" $P(^LRO(69,LRDT,1,"AR",LRLLOC,LRNM,LRDFN),U)=1

 ; ----- END IHS/OIT/MKK - LR*5.2*1026

 L -^LAC(LRXLR,LRDFN)

MICRO ;from LRACM3

 Q:'$D(^LRO(68,"MI",LRDFN))

 S LRZ=$P(^LAB(64.5,1,0),U,5)

 S:'$D(LRUNKNOW) LRUNKNOW=$P(^LAB(69.9,1,1),U,5)

 S (LRONESPC,LRONETST)="",LREND=0

 S LRWRDVEW="",LRSB=0 S LRIDT=0

 F  S LRIDT=$O(^LRO(68,"MI",LRDFN,LRIDT)) G:LRIDT<1 MIEND D ZIP,FORP

FORP I $D(^LR(LRDFN,"MI",LRIDT,0)) S LRII=0 F  S LRII=$O(^LRO(68,"MI",LRDFN,LRIDT,LRII)) Q:LRII<1  I $D(^LR(LRDFN,"MI",LRIDT,LRII)) S LRSB=LRII,LRZA=$P(^(LRII),U,2) D:(LRZ="F"&(LRZA="F"))!(LRZ="P") EN1^LRMIPC D FORP1

 Q

FORP1 S LRLLOC=LRNLOC S:'LRRE ^LAC("LRKILL",LRDFN,"MI",LRIDT,LRII)="",^LRO(68,"MI",LRDFN,LRIDT,LRII)=1

 Q

MIEND K %,A,A1,AGE,B,B1,DFN,DOB,DZ,I,J,LR2ORMOR,LRAA,LRACC,LRACN,LRAD,LRADM

 K LRADX,LRAFS,LRAX,LRBUG,LRCMNT,LRCOMTAB,LRCS,LRDCOM,LREF,LREND,LRIFN

 K LRLLT,LRMD,LRNLOC,LRNS,LROK,LRONESPC,LRONETST,LRORG,LRPRE,LRPRINT

 K LRPG,LRQU,LRRC,LRSPEC,LRSPZ,LRSSD,LRST,LRTK,LRTS,LRTSTS,LRTUS,LRUS

 K LRWRD,LRZ,LRZA,P,SEX,SSN,HRCN,X,Y  ;IHS/ANMC/CLS 11/1/95 HRCN

 Q

FIDT S LRIDT=0

 F  S LRIDT=$O(^LRO(68,"AC",LRDFN,LRIDT)) Q:LRIDT<1  D LRIDT^LRAC2

 Q

LRLTR ;from LRACM

 I $D(LRLOCB) S Y=$S(LRLOCB?1N.N&(LRLLOC?1N.N):1,LRLOCB?1N.N&(LRLLOC'?1N.N):2,LRLOCB'?1N.N&(LRLLOC'?1N.N):3,1:4) Q:Y=1&(LRLLOC>LRLOCB)!(Y=2)!(Y=3&(LRLLOC]LRLOCB))

 I LRLLOC["FILE ROOM",'LRRE,$P($G(^LAB(64.5,1,6)),U,2),'$P($G(^LAB(64.5,1,3,LRRPTN,.1)),U,3) Q

 ; If location contains "FILE ROOM", not a reprint, site using separate file room, and not a file room report then quit.

 W @IOF S LRLTR=$E(LRLLOC,1,4) D ^LRLTR S:'$D(LRTRUE) LRNM=-1

 D LRNM D:LRLLOC["FILE ROOM" ENT^LRACFILE Q

LRNM F Q=0:0 S:'$D(LRTRUE) LRNM=$O(^LRO(69,LRDT,1,"AR",LRLLOC,LRNM)) Q:LRNM=""  S:'$D(LRTRUE) LRDFN=0 D LRDFN I $D(LRNMA) Q:LRNMA=LRNM

 Q

ZIP I '$D(^LR(LRDFN,"MI",LRIDT,0)) K ^LRO(68,"MI",LRDFN,LRIDT) Q

 S LRNLOC=LRLLOC

 Q

LRLLOC F Q=0:0 S:'$D(LRTRUE) LRLLOC=$O(^LRO(69,LRDT,1,"AR",LRLLOC)) Q:LRLLOC=""  D LRLTR

 Q

ENT ;from LRACM1

 S:$D(ZTQUEUED) ZTREQ="@"

 I $D(IOP) S LRX=$S($D(DUZ(0)):DUZ(0),1:""),DUZ(0)="" D ^%ZIS S DUZ(0)=LRX K IOP

 I 'LRRE,'$P(^LAB(64.5,1,3,LRRPTN,0),U,7) S %DT="T",X="N" D ^%DT S $P(^LAB(64.5,1,3,LRRPTN,0),U,7)=Y

 U IO K ^TMP($J) D DT^LRX S LRCDT=LRDT0,LRAC=1

 G:LRRE DO S X=$P(^LAB(64.5,1,3,LRRPTN,0),U,4,8),Y=^(0),LRLLOC=$S(LRDT=LRLDT&($L($P(X,U,1))):$P(X,U,1),1:$P(Y,U,2)),LRLOCB=$P(Y,U,3)

 S LRNM=$S(LRDT=LRLDT&($L($P(X,U,2))):$P(X,U,2),1:-1)

 S LRDFN=$S(LRDT=LRLDT:$P(X,U,3),1:0)

 I $L(LRLLOC),$D(^LRO(69,LRDT,1,"AR",LRLLOC)) S LRTRUE=1

DO DO LRLLOC

END S LRLTR="END" W @IOF D ^LRLTR

 I '$D(LREN),'LRRE,'$P(^LAB(64.5,1,3,LRRPTN,0),U,8) S %DT="T",X="N" D ^%DT S $P(^LAB(64.5,1,3,LRRPTN,0),U,8)=Y

 D KILL K ^TMP($J),^TMP("LRLTR",$J) D ^%ZISC

 Q

KILL K LRG,LRADD,LRCNT,LRCTN,LRCTR,LRCTRR,LRDT,LRDT1,LRFALT,LRFD1,LRFDE

 K LRFFDT,LRIF,LRIPG,LRIV,LRKL,LRLTR,LRNOT,LRNUM,LRNX,LRNXSW,LRPG2,LRPPT

 K LRVAR,LRXLR,LRYDT,LRRPTN,X1,LRJ02

 Q

LRAC1     ; IHS/DIR/FJE - CUMULATIVE CONT. 2/19/91 09:55 ;MAY 06, 2009 9:58 AM

 +1       ;;5.2T1;LAB SERVICE;**1013,1026**;NOV 01, 1997

 +2       ;

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

LRDFN      SET LRTNN=2

 +1       ;F LRDFN=LRDFN:0 S LRDFN=$O(^LRO(69,LRDT,1,"AR",LRLLOC,LRNM,LRDFN)) K LRTRUE Q:LRDFN<1  I LRRE!('^(LRDFN)) S LRIL=1 D PAT S:LRLLOC["FILE ROOM" ^TMP($J,"SSN",$S(LRDPF=2:"A"_$E(SSN,10,11)_$E(SSN,8,9)_$E(SSN,1,3)_$E(SSN,5,6),1:LRNM),LRDFN)=""

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

           FOR LRDFN=LRDFN:0

               SET LRDFN=$ORDER(^LRO(69,LRDT,1,"AR",LRLLOC,LRNM,LRDFN))

               KILL LRTRUE

               IF LRDFN<1

                   QUIT 

               IF LRRE!('^(LRDFN))

                   SET LRIL=1

                   DO PAT

                   DO IHS

 +3        QUIT 

IHS       ;IHS/ANMC/CLS 10/04/92 sort FILE ROOM by HRCN terminal digit order

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

           IF LRLLOC["FILE ROOM"

               SET HRCNT=HRCN+10000000

               SET HRCNT=$EXTRACT(HRCNT,7,8)_$EXTRACT(HRCNT,5,6)_$EXTRACT(HRCNT,3,4)_$EXTRACT(HRCNT,2)

               SET ^TMP($JOB,"HRCN",$SELECT(LRDPF=2:"A"_HRCNT,1:LRNM),LRDFN)=""

 +2        QUIT 

PAT       ;from LRACM3

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

               QUIT 

 +2        SET DFN=$PIECE(^LR(LRDFN,0),U,3)

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

 +3       ;D PT^LRX Q:LRLLOC["FILE ROOM"  S SSN=" "_SSN_" "

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

           DO PT^LRX

           IF LRLLOC["FILE ROOM"

               QUIT 

           SET HRCN=" "_HRCN_" "

PAT1      ;from LRACFILE

 +1        LOCK +^LAC(LRXLR,LRDFN)

           IF '$DATA(^LAC(LRXLR,LRDFN,0))

               SET ^(0)=LRDFN

               SET ^LAC(LRXLR,"B",LRDFN,LRDFN)=""

               SET LRZO="^LAC("""_LRXLR_""","

               SET LRZ1=64.7

               SET LRZ3=LRDFN

               DO Z^LRWU

 +2        IF '$DATA(^LAC(LRXLR,LRDFN,"MISC",1,0))

               SET ^(0)="MISCELLANEOUS TESTS^"

 +3        IF '$DATA(LRCALE)

               DO LRCALE^LRAC2

           IF 'LRRE

               DO FIDT

           DO ENT^LRAC3

           KILL LRMISC

 +4       ; I 'LRRE S $P(^LAC(LRXLR,LRDFN,0),U,2)=LRDT S:$D(LRRPTN) $P(^LAB(64.5,1,3,LRRPTN,0),U,4,6)=LRLLOC_U_LRNM_U_LRDFN S $P(^LRO(69,LRDT,1,"AR",LRLLOC,LRNM,LRDFN),U)=1

 +5       ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1026 - Make sure LRLLOC variable exists

 +6        IF 'LRRE

               Begin DoDot:1

 +7                SET $PIECE(^LAC(LRXLR,LRDFN,0),U,2)=LRDT

 +8                IF $DATA(LRRPTN)&($GET(LRLLOC)'="")

                       SET $PIECE(^LAB(64.5,1,3,LRRPTN,0),U,4,6)=LRLLOC_U_LRNM_U_LRDFN

 +9                IF $GET(LRLLOC)'=""

                       SET $PIECE(^LRO(69,LRDT,1,"AR",LRLLOC,LRNM,LRDFN),U)=1

               End DoDot:1

 +10      ; ----- END IHS/OIT/MKK - LR*5.2*1026

 +11       LOCK -^LAC(LRXLR,LRDFN)

MICRO     ;from LRACM3

 +1        IF '$DATA(^LRO(68,"MI",LRDFN))

               QUIT 

 +2        SET LRZ=$PIECE(^LAB(64.5,1,0),U,5)

 +3        IF '$DATA(LRUNKNOW)

               SET LRUNKNOW=$PIECE(^LAB(69.9,1,1),U,5)

 +4        SET (LRONESPC,LRONETST)=""

           SET LREND=0

 +5        SET LRWRDVEW=""

           SET LRSB=0

           SET LRIDT=0

 +6        FOR 

               SET LRIDT=$ORDER(^LRO(68,"MI",LRDFN,LRIDT))

               IF LRIDT<1

                   GOTO MIEND

               DO ZIP

               DO FORP

FORP       IF $DATA(^LR(LRDFN,"MI",LRIDT,0))

               SET LRII=0

               FOR 

                   SET LRII=$ORDER(^LRO(68,"MI",LRDFN,LRIDT,LRII))

                   IF LRII<1

                       QUIT 

                   IF $DATA(^LR(LRDFN,"MI",LRIDT,LRII))

                       SET LRSB=LRII

                       SET LRZA=$PIECE(^(LRII),U,2)

                       IF (LRZ="F"&(LRZA="F"))!(LRZ="P")

                           DO EN1^LRMIPC

                       DO FORP1

 +1        QUIT 

FORP1      SET LRLLOC=LRNLOC

           IF 'LRRE

               SET ^LAC("LRKILL",LRDFN,"MI",LRIDT,LRII)=""

               SET ^LRO(68,"MI",LRDFN,LRIDT,LRII)=1

 +1        QUIT 

MIEND      KILL %,A,A1,AGE,B,B1,DFN,DOB,DZ,I,J,LR2ORMOR,LRAA,LRACC,LRACN,LRAD,LRADM

 +1        KILL LRADX,LRAFS,LRAX,LRBUG,LRCMNT,LRCOMTAB,LRCS,LRDCOM,LREF,LREND,LRIFN

 +2        KILL LRLLT,LRMD,LRNLOC,LRNS,LROK,LRONESPC,LRONETST,LRORG,LRPRE,LRPRINT

 +3        KILL LRPG,LRQU,LRRC,LRSPEC,LRSPZ,LRSSD,LRST,LRTK,LRTS,LRTSTS,LRTUS,LRUS

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

           KILL LRWRD,LRZ,LRZA,P,SEX,SSN,HRCN,X,Y

 +5        QUIT 

FIDT       SET LRIDT=0

 +1        FOR 

               SET LRIDT=$ORDER(^LRO(68,"AC",LRDFN,LRIDT))

               IF LRIDT<1

                   QUIT 

               DO LRIDT^LRAC2

 +2        QUIT 

LRLTR     ;from LRACM

 +1        IF $DATA(LRLOCB)

               SET Y=$SELECT(LRLOCB?1N.N&(LRLLOC?1N.N):1,LRLOCB?1N.N&(LRLLOC'?1N.N):2,LRLOCB'?1N.N&(LRLLOC'?1N.N):3,1:4)

               IF Y=1&(LRLLOC>LRLOCB)!(Y=2)!(Y=3&(LRLLOC]LRLOCB))

                   QUIT 

 +2        IF LRLLOC["FILE ROOM"

               IF 'LRRE

                   IF $PIECE($GET(^LAB(64.5,1,6)),U,2)

                       IF '$PIECE($GET(^LAB(64.5,1,3,LRRPTN,.1)),U,3)

                           QUIT 

 +3       ; If location contains "FILE ROOM", not a reprint, site using separate file room, and not a file room report then quit.

 +4        WRITE @IOF

           SET LRLTR=$EXTRACT(LRLLOC,1,4)

           DO ^LRLTR

           IF '$DATA(LRTRUE)

               SET LRNM=-1

 +5        DO LRNM

           IF LRLLOC["FILE ROOM"

               DO ENT^LRACFILE

           QUIT 

LRNM       FOR Q=0:0

               IF '$DATA(LRTRUE)

                   SET LRNM=$ORDER(^LRO(69,LRDT,1,"AR",LRLLOC,LRNM))

               IF LRNM=""

                   QUIT 

               IF '$DATA(LRTRUE)

                   SET LRDFN=0

               DO LRDFN

               IF $DATA(LRNMA)

                   IF LRNMA=LRNM

                       QUIT 

 +1        QUIT 

ZIP        IF '$DATA(^LR(LRDFN,"MI",LRIDT,0))

               KILL ^LRO(68,"MI",LRDFN,LRIDT)

               QUIT 

 +1        SET LRNLOC=LRLLOC

 +2        QUIT 

LRLLOC     FOR Q=0:0

               IF '$DATA(LRTRUE)

                   SET LRLLOC=$ORDER(^LRO(69,LRDT,1,"AR",LRLLOC))

               IF LRLLOC=""

                   QUIT 

               DO LRLTR

 +1        QUIT 

ENT       ;from LRACM1

 +1        IF $DATA(ZTQUEUED)

               SET ZTREQ="@"

 +2        IF $DATA(IOP)

               SET LRX=$SELECT($DATA(DUZ(0)):DUZ(0),1:"")

               SET DUZ(0)=""

               DO ^%ZIS

               SET DUZ(0)=LRX

               KILL IOP

 +3        IF 'LRRE

               IF '$PIECE(^LAB(64.5,1,3,LRRPTN,0),U,7)

                   SET %DT="T"

                   SET X="N"

                   DO ^%DT

                   SET $PIECE(^LAB(64.5,1,3,LRRPTN,0),U,7)=Y

 +4        USE IO

           KILL ^TMP($JOB)

           DO DT^LRX

           SET LRCDT=LRDT0

           SET LRAC=1

 +5        IF LRRE

               GOTO DO

           SET X=$PIECE(^LAB(64.5,1,3,LRRPTN,0),U,4,8)

           SET Y=^(0)

           SET LRLLOC=$SELECT(LRDT=LRLDT&($LENGTH($PIECE(X,U,1))):$PIECE(X,U,1),1:$PIECE(Y,U,2))

           SET LRLOCB=$PIECE(Y,U,3)

 +6        SET LRNM=$SELECT(LRDT=LRLDT&($LENGTH($PIECE(X,U,2))):$PIECE(X,U,2),1:-1)

 +7        SET LRDFN=$SELECT(LRDT=LRLDT:$PIECE(X,U,3),1:0)

 +8        IF $LENGTH(LRLLOC)

               IF $DATA(^LRO(69,LRDT,1,"AR",LRLLOC))

                   SET LRTRUE=1

DO         DO LRLLOC

END        SET LRLTR="END"

           WRITE @IOF

           DO ^LRLTR

 +1        IF '$DATA(LREN)

               IF 'LRRE

                   IF '$PIECE(^LAB(64.5,1,3,LRRPTN,0),U,8)

                       SET %DT="T"

                       SET X="N"

                       DO ^%DT

                       SET $PIECE(^LAB(64.5,1,3,LRRPTN,0),U,8)=Y

 +2        DO KILL

           KILL ^TMP($JOB),^TMP("LRLTR",$JOB)

           DO ^%ZISC

 +3        QUIT 

KILL       KILL LRG,LRADD,LRCNT,LRCTN,LRCTR,LRCTRR,LRDT,LRDT1,LRFALT,LRFD1,LRFDE

 +1        KILL LRFFDT,LRIF,LRIPG,LRIV,LRKL,LRLTR,LRNOT,LRNUM,LRNX,LRNXSW,LRPG2,LRPPT

 +2        KILL LRVAR,LRXLR,LRYDT,LRRPTN,X1,LRJ02

 +3        QUIT