68 lines
3.9 KiB
Mathematica
68 lines
3.9 KiB
Mathematica
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
|