- 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 Jan 18, 2025@03:07:04 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