Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LRACKL

LRACKL.m

Go to the documentation of this file.
  1. LRACKL ;DALOI/DCM/JMC/RLM-CHUTES & LADDERS; 2/16/88 16:15
  1. ;;5.2;LAB SERVICE;**272**;Sep 27, 1994
  1. ; Reference to ^%DTC supported by IA # 10000
  1. ; Reference to H^%DTC supported by IA # 10000
  1. ; Reference to YMD^%DTC supported by IA # 10000
  1. ; Reference to ^%RCR supported by IA # 10022
  1. ; Reference to IX^DIC supported by IA # 10006
  1. LR1 K ^LRO(69,DT,1,"AR",LRLLOC,PNM,LRDFN) S ^LRO(69,LRDT,1,"AR",LRLLOC,PNM,LRDFN)=""
  1. Q
  1. 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
  1. Q
  1. PT1 ;
  1. I $G(LRLLOC)="UNKNOWN" S LRLLOC=$G(^LR(LRDFN,.1))
  1. I $G(LRLLOC)="" S LRLLOC="UNKNOWN"
  1. 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
  1. ;I Y'>0 S ^TMP("LR","T-CUME",LRLLOC)=$G(LRDT)_U_$G(LRDFN)_U_$G(LRPPT)
  1. I $G(LRLLIN)'>0 D ^LRAC14
  1. 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)
  1. I $L(LRFLOC) S LRSLOC=LRLLOC,LRLLOC=LRFLOC D DPT^LRWU S LRFLOC=LRLLOC,LRLLOC=LRSLOC
  1. I $L(LRFLOC) S:'S1!(S1=1) ^TMP($J,"N",LRFLOC,LRPPT,LRDFN)="" Q
  1. Q:S1=1 I S2 D DIC^LRACKL1 Q
  1. S ^TMP($J,"N",LRLLOC,LRPPT,LRDFN)=""
  1. Q
  1. PT ;
  1. S LRPPT=""
  1. 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
  1. Q
  1. LRKL2 I $D(^LRO(68,"AC",LRDFN,LRIDTSB,LRKL2)),^(LRKL2)'="" K ^LRO(68,"AC",LRDFN,LRIDTSB,LRKL2)
  1. Q
  1. 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
  1. Q
  1. 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
  1. I $O(^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,1,0))="" K ^(0)
  1. I $O(^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,0))="" K ^(0)
  1. Q
  1. 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
  1. I LRMH="MI" D MICRO S LRMH=$O(^LAC("LRKILL",LRDFN,"MI"))
  1. I LRMH="MISC" D MISC
  1. Q
  1. 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)
  1. I $O(^LAC(LRXLR,LRDFN,LRMH,1,1,LRKL,1,0))<1 K ^LAC(LRXLR,LRDFN,LRMH,1,1,LRKL)
  1. Q
  1. 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
  1. Q
  1. 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)
  1. Q
  1. DFN S LRDFN=0 F S LRDFN=$O(^LAC("LRKILL",LRDFN)) Q:LRDFN<1 D LRMH
  1. Q
  1. 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
  1. K ^LRO(69,LRDT,1,"AR") S %X="^TMP($J,""N"",",%Y="^LRO(69,"_LRDT_",1,""AR""," D %XY^%RCR
  1. K LRNLOC,LRLLOC,LRPPT,LRDFN,LRFLOC,DFN,DIC,DIC(0),S1,S2,X,Y,^TMP($J)
  1. Q
  1. LAST Q:'$L(LRLDT) S LRNWT=$P(^LAB(64.5,1,0),U,3)
  1. 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
  1. D SHUF K LRNWT,%X,%Y,%H,X,LRCVT
  1. Q
  1. ENT ;from LRAC
  1. K ^TMP("TEMPLE") S LRCNTCUM=0
  1. 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
  1. D DFN
  1. 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
  1. ;
  1. K ^TMP("LR","T-CUME")
  1. K ^TMP("LR","LRCNT-CUME"),^TMP("LR","NO-LRLLIN"),^TMP("LR","LR-NO-LOC")
  1. Q
  1. 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
  1. Q