source: FOIAVistA/tag/r/LAB_SERVICE-LR-LS/LRACKL.m@ 636

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