LRAC1 ;SLC/DCM/MILW/JMC - CUMULATIVE CONT. ;2/19/91 09:55 ;
;;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)=""
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_" "
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
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,X,Y
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAC1 3795 printed Nov 22, 2024@17:16:09 Page 2
LRAC1 ;SLC/DCM/MILW/JMC - CUMULATIVE CONT. ;2/19/91 09:55 ;
+1 ;;5.2;LAB SERVICE;;Sep 27, 1994
LRDFN SET LRTNN=2
+1 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
if LRLLOC["FILE ROOM"
SET ^TMP($JOB,"SSN",$SELECT(LRDPF=2:"A"_$EXTRACT(SSN,10,11)_$EXTRACT(SSN,8,9)_$EXTRACT(SSN,1,3)_$EXTRACT(SSN,5,6),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 DO PT^LRX
if LRLLOC["FILE ROOM"
QUIT
SET SSN=" "_SSN_" "
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 IF 'LRRE
SET $PIECE(^LAC(LRXLR,LRDFN,0),U,2)=LRDT
if $DATA(LRRPTN)
SET $PIECE(^LAB(64.5,1,3,LRRPTN,0),U,4,6)=LRLLOC_U_LRNM_U_LRDFN
SET $PIECE(^LRO(69,LRDT,1,"AR",LRLLOC,LRNM,LRDFN),U)=1
+5 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 KILL LRWRD,LRZ,LRZA,P,SEX,SSN,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
