LRACKL ;DALOI/DCM/JMC/RLM-CHUTES & LADDERS; 2/16/88 16:15
;;5.2;LAB SERVICE;**272**;Sep 27, 1994
; Reference to ^%DTC supported by IA # 10000
; Reference to H^%DTC supported by IA # 10000
; Reference to YMD^%DTC supported by IA # 10000
; Reference to ^%RCR supported by IA # 10022
; Reference to IX^DIC supported by IA # 10006
LR1 K ^LRO(69,DT,1,"AR",LRLLOC,PNM,LRDFN) S ^LRO(69,LRDT,1,"AR",LRLLOC,PNM,LRDFN)=""
Q
SHUF F I=0:0 S LRLLOC=$O(^LRO(69,DT,1,"AR",LRLLOC)) Q:LRLLOC="" S PNM=-1 F J=0:0 S PNM=$O(^LRO(69,DT,1,"AR",LRLLOC,PNM)) Q:PNM="" S LRDFN=0 F S LRDFN=$O(^LRO(69,DT,1,"AR",LRLLOC,PNM,LRDFN)) Q:LRDFN<1 D LR1
Q
PT1 ;
I $G(LRLLOC)="UNKNOWN" S LRLLOC=$G(^LR(LRDFN,.1))
I $G(LRLLOC)="" S LRLLOC="UNKNOWN"
S DIC="^SC(",DIC(0)="XZ",D="C",X=LRLLOC D IX^DIC S LRFLOC=$S(+Y>0:$S($P(Y(0),U,3)="W":LRLLOC,1:""),1:"") K LRLLIN S:+Y>0 LRLLIN=+Y
;I Y'>0 S ^TMP("LR","T-CUME",LRLLOC)=$G(LRDT)_U_$G(LRDFN)_U_$G(LRPPT)
I $G(LRLLIN)'>0 D ^LRAC14
S DFN=$P(^LR(LRDFN,0),U,3),LRDPF=$P(^(0),U,2) D PT^LRX S LRFLOC=$S(LRDPF=2&($L(LRWRD)):LRWRD,1:LRFLOC),SSN=$S($D(SSN(2)):SSN(2),1:SSN),PNM=$E(PNM,1,20)
I $L(LRFLOC) S LRSLOC=LRLLOC,LRLLOC=LRFLOC D DPT^LRWU S LRFLOC=LRLLOC,LRLLOC=LRSLOC
I $L(LRFLOC) S:'S1!(S1=1) ^TMP($J,"N",LRFLOC,LRPPT,LRDFN)="" Q
Q:S1=1 I S2 D DIC^LRACKL1 Q
S ^TMP($J,"N",LRLLOC,LRPPT,LRDFN)=""
Q
PT ;
S LRPPT=""
F S LRPPT=$O(^LRO(69,LRDT,1,"AR",LRLLOC,LRPPT)) Q:LRPPT="" S LRDFN=0 F S LRDFN=$O(^LRO(69,LRDT,1,"AR",LRLLOC,LRPPT,LRDFN)) Q:LRDFN<1 Q:'$D(^LR(LRDFN,0))!($D(^TMP($J,LRDFN))) S ^TMP($J,LRDFN)="" D PT1
Q
LRKL2 I $D(^LRO(68,"AC",LRDFN,LRIDTSB,LRKL2)),^(LRKL2)'="" K ^LRO(68,"AC",LRDFN,LRIDTSB,LRKL2)
Q
LRKL1 S LRKL1=0 F S LRKL1=$O(^LAC("LRKILL",LRDFN,LRMH,LRSH,LRKL,LRKL1)) Q:LRKL1<1 S LRKL2=$P(^(LRKL1),U,1) D LRKL2
Q
LRKL S LRKL=0 F S LRKL=$O(^LAC("LRKILL",LRDFN,LRMH,LRSH,LRKL)) Q:LRKL<1 S LRUTKL=$P(^(LRKL,0),U,2),LRIDTSB=$P(^(0),U,3) K ^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,1,LRUTKL) D LRKL1
I $O(^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,1,0))="" K ^(0)
I $O(^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,0))="" K ^(0)
Q
LRMH S LRMH=0 F S LRMH=$O(^LAC("LRKILL",LRDFN,LRMH)) Q:LRMH<1 S LRSH=0 F S LRSH=$O(^LAC("LRKILL",LRDFN,LRMH,LRSH)) Q:LRSH<1 D LRKL
I LRMH="MI" D MICRO S LRMH=$O(^LAC("LRKILL",LRDFN,"MI"))
I LRMH="MISC" D MISC
Q
SB S LRKL1=0 F S LRKL1=$O(^LAC("LRKILL",LRDFN,LRMH,1,LRKL,LRKL1)) Q:LRKL1<1 S LRKL2=$P(^(LRKL1),U,1) D LRKL2 K ^LAC(LRXLR,LRDFN,"MISC",1,1,LRKL,1,LRKL1)
I $O(^LAC(LRXLR,LRDFN,LRMH,1,1,LRKL,1,0))<1 K ^LAC(LRXLR,LRDFN,LRMH,1,1,LRKL)
Q
MISC S LRKL=0 F S LRKL=$O(^LAC("LRKILL",LRDFN,LRMH,1,LRKL)) Q:LRKL<1 S LRIDTSB=$P(^(LRKL,0),U,1) D SB
Q
MICRO S LRKL=0 F S LRKL=$O(^LAC("LRKILL",LRDFN,LRMH,LRKL)) Q:LRKL<1 S LRKL3=0 F S LRKL3=$O(^LAC("LRKILL",LRDFN,LRMH,LRKL,LRKL3)) Q:LRKL3<1 K ^LRO(68,"MI",LRDFN,LRKL,LRKL3)
Q
DFN S LRDFN=0 F S LRDFN=$O(^LAC("LRKILL",LRDFN)) Q:LRDFN<1 D LRMH
Q
AR K ^TMP($J) S S1=$P(^LAB(64.5,1,0),U,6),S2=$P(^(0),U,4) F J=0:0 S LRLLOC=$O(^LRO(69,LRDT,1,"AR",LRLLOC)) Q:LRLLOC="" S LRPPT=-1 D PT
K ^LRO(69,LRDT,1,"AR") S %X="^TMP($J,""N"",",%Y="^LRO(69,"_LRDT_",1,""AR""," D %XY^%RCR
K LRNLOC,LRLLOC,LRPPT,LRDFN,LRFLOC,DFN,DIC,DIC(0),S1,S2,X,Y,^TMP($J)
Q
LAST Q:'$L(LRLDT) S LRNWT=$P(^LAB(64.5,1,0),U,3)
S X1=LRDT,X2=LRNWT D ^%DTC I X>1 S LRCVT=X-1 F I=1:1:LRCVT S X=LRNWT D H^%DTC S %H=%H+1 D YMD^%DTC S LRNWT=X,%X="^LRO(69,LRNWT,1,""AR"",",%Y="^LRO(69,LRDT,1,""AR""," D %XY^%RCR
D SHUF K LRNWT,%X,%Y,%H,X,LRCVT
Q
ENT ;from LRAC
K ^TMP("TEMPLE") S LRCNTCUM=0
S LRLLOC=-1,U="^" D LAST,AR I '$D(^LAC("LRKILL")) D ALGOT K:$D(^LAC("LGOT")) ^LAC("LGOT") D:$D(^LAB(64.5,"AZ")) ENT^LRAC8 Q
D DFN
END D ALGOT K ^LAC("LRKILL"),^LAC("LGOT"),LRDPF,LRDFN,LRMH,LRSH,LRKL,LRKL1,LRKL2,LRKL3,LRIDTSB,LRUTKL,LRSLOC D:$D(^LAB(64.5,"AZ")) ENT^LRAC8
;
K ^TMP("LR","T-CUME")
K ^TMP("LR","LRCNT-CUME"),^TMP("LR","NO-LRLLIN"),^TMP("LR","LR-NO-LOC")
Q
ALGOT I $D(^LAC("LGOT")) S I="" F S I=$O(^LAC("LGOT",I)) Q:I<1 S K="" F S K=$O(^LAC("LGOT",I,K)) Q:K="" S:K="MISC" ^LAC("LRAC",I,"MISC",1,.5)=0 S:K'="MISC" ^LAC("LRAC",I,1,K,.5)=0
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRACKL 4103 printed Apr 09, 2024@21:22:12 Page 2
LRACKL ;DALOI/DCM/JMC/RLM-CHUTES & LADDERS; 2/16/88 16:15
+1 ;;5.2;LAB SERVICE;**272**;Sep 27, 1994
+2 ; Reference to ^%DTC supported by IA # 10000
+3 ; Reference to H^%DTC supported by IA # 10000
+4 ; Reference to YMD^%DTC supported by IA # 10000
+5 ; Reference to ^%RCR supported by IA # 10022
+6 ; Reference to IX^DIC supported by IA # 10006
LR1 KILL ^LRO(69,DT,1,"AR",LRLLOC,PNM,LRDFN)
SET ^LRO(69,LRDT,1,"AR",LRLLOC,PNM,LRDFN)=""
+1 QUIT
SHUF FOR I=0:0
SET LRLLOC=$ORDER(^LRO(69,DT,1,"AR",LRLLOC))
if LRLLOC=""
QUIT
SET PNM=-1
FOR J=0:0
SET PNM=$ORDER(^LRO(69,DT,1,"AR",LRLLOC,PNM))
if PNM=""
QUIT
SET LRDFN=0
FOR
SET LRDFN=$ORDER(^LRO(69,DT,1,"AR",LRLLOC,PNM,LRDFN))
if LRDFN<1
QUIT
DO LR1
+1 QUIT
PT1 ;
+1 IF $GET(LRLLOC)="UNKNOWN"
SET LRLLOC=$GET(^LR(LRDFN,.1))
+2 IF $GET(LRLLOC)=""
SET LRLLOC="UNKNOWN"
+3 SET DIC="^SC("
SET DIC(0)="XZ"
SET D="C"
SET X=LRLLOC
DO IX^DIC
SET LRFLOC=$SELECT(+Y>0:$SELECT($PIECE(Y(0),U,3)="W":LRLLOC,1:""),1:"")
KILL LRLLIN
if +Y>0
SET LRLLIN=+Y
+4 ;I Y'>0 S ^TMP("LR","T-CUME",LRLLOC)=$G(LRDT)_U_$G(LRDFN)_U_$G(LRPPT)
+5 IF $GET(LRLLIN)'>0
DO ^LRAC14
+6 SET DFN=$PIECE(^LR(LRDFN,0),U,3)
SET LRDPF=$PIECE(^(0),U,2)
DO PT^LRX
SET LRFLOC=$SELECT(LRDPF=2&($LENGTH(LRWRD)):LRWRD,1:LRFLOC)
SET SSN=$SELECT($DATA(SSN(2)):SSN(2),1:SSN)
SET PNM=$EXTRACT(PNM,1,20)
+7 IF $LENGTH(LRFLOC)
SET LRSLOC=LRLLOC
SET LRLLOC=LRFLOC
DO DPT^LRWU
SET LRFLOC=LRLLOC
SET LRLLOC=LRSLOC
+8 IF $LENGTH(LRFLOC)
if 'S1!(S1=1)
SET ^TMP($JOB,"N",LRFLOC,LRPPT,LRDFN)=""
QUIT
+9 if S1=1
QUIT
IF S2
DO DIC^LRACKL1
QUIT
+10 SET ^TMP($JOB,"N",LRLLOC,LRPPT,LRDFN)=""
+11 QUIT
PT ;
+1 SET LRPPT=""
+2 FOR
SET LRPPT=$ORDER(^LRO(69,LRDT,1,"AR",LRLLOC,LRPPT))
if LRPPT=""
QUIT
SET LRDFN=0
FOR
SET LRDFN=$ORDER(^LRO(69,LRDT,1,"AR",LRLLOC,LRPPT,LRDFN))
if LRDFN<1
QUIT
if '$DATA(^LR(LRDFN,0))!($DATA(^TMP($JOB,LRDFN)))
QUIT
SET ^TMP($JOB,LRDFN)=""
DO PT1
+3 QUIT
LRKL2 IF $DATA(^LRO(68,"AC",LRDFN,LRIDTSB,LRKL2))
IF ^(LRKL2)'=""
KILL ^LRO(68,"AC",LRDFN,LRIDTSB,LRKL2)
+1 QUIT
LRKL1 SET LRKL1=0
FOR
SET LRKL1=$ORDER(^LAC("LRKILL",LRDFN,LRMH,LRSH,LRKL,LRKL1))
if LRKL1<1
QUIT
SET LRKL2=$PIECE(^(LRKL1),U,1)
DO LRKL2
+1 QUIT
LRKL SET LRKL=0
FOR
SET LRKL=$ORDER(^LAC("LRKILL",LRDFN,LRMH,LRSH,LRKL))
if LRKL<1
QUIT
SET LRUTKL=$PIECE(^(LRKL,0),U,2)
SET LRIDTSB=$PIECE(^(0),U,3)
KILL ^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,1,LRUTKL)
DO LRKL1
+1 IF $ORDER(^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,1,0))=""
KILL ^(0)
+2 IF $ORDER(^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,0))=""
KILL ^(0)
+3 QUIT
LRMH SET LRMH=0
FOR
SET LRMH=$ORDER(^LAC("LRKILL",LRDFN,LRMH))
if LRMH<1
QUIT
SET LRSH=0
FOR
SET LRSH=$ORDER(^LAC("LRKILL",LRDFN,LRMH,LRSH))
if LRSH<1
QUIT
DO LRKL
+1 IF LRMH="MI"
DO MICRO
SET LRMH=$ORDER(^LAC("LRKILL",LRDFN,"MI"))
+2 IF LRMH="MISC"
DO MISC
+3 QUIT
SB SET LRKL1=0
FOR
SET LRKL1=$ORDER(^LAC("LRKILL",LRDFN,LRMH,1,LRKL,LRKL1))
if LRKL1<1
QUIT
SET LRKL2=$PIECE(^(LRKL1),U,1)
DO LRKL2
KILL ^LAC(LRXLR,LRDFN,"MISC",1,1,LRKL,1,LRKL1)
+1 IF $ORDER(^LAC(LRXLR,LRDFN,LRMH,1,1,LRKL,1,0))<1
KILL ^LAC(LRXLR,LRDFN,LRMH,1,1,LRKL)
+2 QUIT
MISC SET LRKL=0
FOR
SET LRKL=$ORDER(^LAC("LRKILL",LRDFN,LRMH,1,LRKL))
if LRKL<1
QUIT
SET LRIDTSB=$PIECE(^(LRKL,0),U,1)
DO SB
+1 QUIT
MICRO SET LRKL=0
FOR
SET LRKL=$ORDER(^LAC("LRKILL",LRDFN,LRMH,LRKL))
if LRKL<1
QUIT
SET LRKL3=0
FOR
SET LRKL3=$ORDER(^LAC("LRKILL",LRDFN,LRMH,LRKL,LRKL3))
if LRKL3<1
QUIT
KILL ^LRO(68,"MI",LRDFN,LRKL,LRKL3)
+1 QUIT
DFN SET LRDFN=0
FOR
SET LRDFN=$ORDER(^LAC("LRKILL",LRDFN))
if LRDFN<1
QUIT
DO LRMH
+1 QUIT
AR KILL ^TMP($JOB)
SET S1=$PIECE(^LAB(64.5,1,0),U,6)
SET S2=$PIECE(^(0),U,4)
FOR J=0:0
SET LRLLOC=$ORDER(^LRO(69,LRDT,1,"AR",LRLLOC))
if LRLLOC=""
QUIT
SET LRPPT=-1
DO PT
+1 KILL ^LRO(69,LRDT,1,"AR")
SET %X="^TMP($J,""N"","
SET %Y="^LRO(69,"_LRDT_",1,""AR"","
DO %XY^%RCR
+2 KILL LRNLOC,LRLLOC,LRPPT,LRDFN,LRFLOC,DFN,DIC,DIC(0),S1,S2,X,Y,^TMP($JOB)
+3 QUIT
LAST if '$LENGTH(LRLDT)
QUIT
SET LRNWT=$PIECE(^LAB(64.5,1,0),U,3)
+1 SET X1=LRDT
SET X2=LRNWT
DO ^%DTC
IF X>1
SET LRCVT=X-1
FOR I=1:1:LRCVT
SET X=LRNWT
DO H^%DTC
SET %H=%H+1
DO YMD^%DTC
SET LRNWT=X
SET %X="^LRO(69,LRNWT,1,""AR"","
SET %Y="^LRO(69,LRDT,1,""AR"","
DO %XY^%RCR
+2 DO SHUF
KILL LRNWT,%X,%Y,%H,X,LRCVT
+3 QUIT
ENT ;from LRAC
+1 KILL ^TMP("TEMPLE")
SET LRCNTCUM=0
+2 SET LRLLOC=-1
SET U="^"
DO LAST
DO AR
IF '$DATA(^LAC("LRKILL"))
DO ALGOT
if $DATA(^LAC("LGOT"))
KILL ^LAC("LGOT")
if $DATA(^LAB(64.5,"AZ"))
DO ENT^LRAC8
QUIT
+3 DO DFN
END DO ALGOT
KILL ^LAC("LRKILL"),^LAC("LGOT"),LRDPF,LRDFN,LRMH,LRSH,LRKL,LRKL1,LRKL2,LRKL3,LRIDTSB,LRUTKL,LRSLOC
if $DATA(^LAB(64.5,"AZ"))
DO ENT^LRAC8
+1 ;
+2 KILL ^TMP("LR","T-CUME")
+3 KILL ^TMP("LR","LRCNT-CUME"),^TMP("LR","NO-LRLLIN"),^TMP("LR","LR-NO-LOC")
+4 QUIT
ALGOT IF $DATA(^LAC("LGOT"))
SET I=""
FOR
SET I=$ORDER(^LAC("LGOT",I))
if I<1
QUIT
SET K=""
FOR
SET K=$ORDER(^LAC("LGOT",I,K))
if K=""
QUIT
if K="MISC"
SET ^LAC("LRAC",I,"MISC",1,.5)=0
if K'="MISC"
SET ^LAC("LRAC",I,1,K,.5)=0
+1 QUIT
