LRARCMA1 ;DALISC/CKA - ARCHIVED WKLD REPORT BY MAJ SCTN; 2/6/91
;;5.2;LAB SERVICE;**59**;Aug 31,1995
;same as LRCAPMA1 except archived wkld file
EN ;
D INITMAN^LRARCMR1
S LRGETIN=$S(LRIN:0,1:1)
F D BUILD Q:(LREND)!('LRLOOP)!(LRBLDONE)
Q
BUILD ; BUILD DATA SUBSET IN ^TMP
D GTIN
I 'LRIN S LRBLDONE=1 Q
;D GENCOM^LRARCMR1,CAPCOM^LRARCMR1
S (LRAPINGT,LRCPINGT)=0
S LRCDT=LRCDTB-1
F S LRCDT=$O(^LAR(64.19999,LRIN,1,"B",LRCDT)) Q:(LRCDT>LRCDTE)!(LRCDT<1) D
. S LRCDTN=0,LRCDTN=$O(^LAR(64.19999,LRIN,1,"B",LRCDT,LRCDTN))
. D DATCOM^LRARCMR1
. W:$E(IOST,1,2)="C-" "."
. S LRCC=0
. F S LRCC=$O(^LAR(64.19999,LRIN,1,LRCDTN,1,"B",LRCC)) Q:(LRCC="") D CC
S LRGTOTS=$G(^TMP("LRAR-WL",$J,0))
S $P(LRGTOTS,U)=$P(LRGTOTS,U)+LRAPINGT+LRCPINGT
S ^TMP("LRAR-WL",$J,0)=LRGTOTS
S LRGTOTS=$G(^TMP("LRAR-WL",$J,"DIV","AP",LRIN,0))
S $P(LRGTOTS,U)=$P(LRGTOTS,U)+LRAPINGT
S ^TMP("LRAR-WL",$J,"DIV","AP",LRIN,0)=LRGTOTS
S LRGTOTS=$G(^TMP("LRAR-WL",$J,"DIV","CP",LRIN,0))
S $P(LRGTOTS,U)=$P(LRGTOTS,U)+LRCPINGT
S ^TMP("LRAR-WL",$J,"DIV","CP",LRIN,0)=LRGTOTS
Q
CC ;
S LRCCN=0,LRCCN=$O(^LAR(64.19999,LRIN,1,LRCDTN,1,"B",LRCC,LRCCN))
S LRCCZ=$P(^LAR(64.19999,LRIN,1,LRCDTN,1,LRCCN,0),U)
S:$E(LRCCZ)="+" LRCCZ=$E(LRCCZ,2,99)
S LRCAPNUM=$$WKLDCODE^LRARCU(LRCCZ)
S LRCAPNAM=$$WKLDNAME^LRARCU(LRCAPIFN)
D BMPMANL^LRARCMR1
S LRCTM=$S(LRCTMB=0:"",1:LRCTMB-.001)
F S LRCTM=$O(^LAR(64.19999,LRIN,1,LRCDTN,1,LRCCN,1,"B",LRCTM)) Q:(LRCTM>LRCTME)!(LRCTM="") S LRCTMN=0,LRCTMN=$O(^LAR(64.19999,LRIN,1,LRCDTN,1,LRCCN,1,"B",LRCTM,LRCTMN)) D TM
Q
TM ;
Q:'($D(^LAR(64.19999,LRIN,1,LRCDTN,1,LRCCN,1,LRCTMN,0))#2) S LRX=^(0),LRX1=^(1)
S LRMA=$P(LRX,U,5),X=LRMA D GETA S LRMA=+Y
I LRAA Q:'$D(LRAA(LRMA))
S LRUC=+$P(LRX,U,3),LRLDIV=$P(LRX,U,4),LRLSS=$P(LRX,U,6),X=LRLSS D GETA S LRLSS=+Y S:LRLDIV=""!(LRLDIV="CLINICAL PATHOLOGY") LRLDIV="CP"
I LRLDIV="ANATOMIC PATHOLOGY" S LRLDIV="AP"
S:'LRUC LRUC=1
I +LRMA D
. S LRREC=$G(^LRO(68,LRMA,0))
. S LRMAA=$S($P(LRREC,U,11)]"":$P(LRREC,U,11),1:LRNDFN)
. S LRMAN=$S($P(LRREC,U)]"":$P(LRREC,U),1:LRNDFN)
. S LRMAN(LRMAA)=LRMAN
I '+LRMA S (LRMAA,LRMAN)=LRNDFN,LRMAN(LRMAA)=LRMAN
I +LRLSS D
. S LRREC=$G(^LRO(68,LRLSS,0))
. S LRLSSA=$S($P(LRREC,U,11)]"":$P(LRREC,U,11),1:LRNDFN)
. S LRLSSN=$S($P(LRREC,U)]"":$P(LRREC,U),1:LRNDFN)
. S LRLSSN(LRLSSA)=LRLSSN
I '+LRLSS S (LRLSSA,LRLSSN)=LRNDFN,LRLSSN(LRLSSA)=LRLSSN
I $D(^TMP("LRAR-WL",$J,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,LRCAPNAM))#2 D
. S $P(^(LRCAPNAM),U)=$P(^TMP("LRAR-WL",$J,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,LRCAPNAM),U)+LRUC
E D
. S ^TMP("LRAR-WL",$J,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,LRCAPNAM)=LRUC
. S $P(^TMP("LRAR-WL",$J,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,LRCAPNAM),U,2)=LRCAPNUM
I LRLDIV="AP" D
. S LRAPINGT=LRAPINGT+LRUC
E D
. S LRCPINGT=LRCPINGT+LRUC
I $D(^TMP("LRAR-WL",$J,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,0))#2 D
. S ^(0)=$P(^TMP("LRAR-WL",$J,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,0),U)+LRUC
E D
. S ^TMP("LRAR-WL",$J,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,0)=LRUC
I $D(^TMP("LRAR-WL",$J,"AA",LRMAA,LRLSSA,0))#2 D
. S $P(^(0),U)=$P(^TMP("LRAR-WL",$J,"AA",LRMAA,LRLSSA,0),U)+LRUC
E D
. S ^TMP("LRAR-WL",$J,"AA",LRMAA,LRLSSA,0)=LRUC
Q
GTIN ;
S:LRGETIN LRIN=+$O(^LAR(64.19999,LRIN))
S:LRIN LRINN=^LAR(64.19999,LRIN,0)
S LRGETIN=1
Q
GETA ;Get pointer value for file 68
K DIC S DIC=68,DIC(0)="XMZ"
D ^DIC Q:Y=-1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRARCMA1 3414 printed Oct 16, 2024@18:09:52 Page 2
LRARCMA1 ;DALISC/CKA - ARCHIVED WKLD REPORT BY MAJ SCTN; 2/6/91
+1 ;;5.2;LAB SERVICE;**59**;Aug 31,1995
+2 ;same as LRCAPMA1 except archived wkld file
EN ;
+1 DO INITMAN^LRARCMR1
+2 SET LRGETIN=$SELECT(LRIN:0,1:1)
+3 FOR
DO BUILD
if (LREND)!('LRLOOP)!(LRBLDONE)
QUIT
+4 QUIT
BUILD ; BUILD DATA SUBSET IN ^TMP
+1 DO GTIN
+2 IF 'LRIN
SET LRBLDONE=1
QUIT
+3 ;D GENCOM^LRARCMR1,CAPCOM^LRARCMR1
+4 SET (LRAPINGT,LRCPINGT)=0
+5 SET LRCDT=LRCDTB-1
+6 FOR
SET LRCDT=$ORDER(^LAR(64.19999,LRIN,1,"B",LRCDT))
if (LRCDT>LRCDTE)!(LRCDT<1)
QUIT
Begin DoDot:1
+7 SET LRCDTN=0
SET LRCDTN=$ORDER(^LAR(64.19999,LRIN,1,"B",LRCDT,LRCDTN))
+8 DO DATCOM^LRARCMR1
+9 if $EXTRACT(IOST,1,2)="C-"
WRITE "."
+10 SET LRCC=0
+11 FOR
SET LRCC=$ORDER(^LAR(64.19999,LRIN,1,LRCDTN,1,"B",LRCC))
if (LRCC="")
QUIT
DO CC
End DoDot:1
+12 SET LRGTOTS=$GET(^TMP("LRAR-WL",$JOB,0))
+13 SET $PIECE(LRGTOTS,U)=$PIECE(LRGTOTS,U)+LRAPINGT+LRCPINGT
+14 SET ^TMP("LRAR-WL",$JOB,0)=LRGTOTS
+15 SET LRGTOTS=$GET(^TMP("LRAR-WL",$JOB,"DIV","AP",LRIN,0))
+16 SET $PIECE(LRGTOTS,U)=$PIECE(LRGTOTS,U)+LRAPINGT
+17 SET ^TMP("LRAR-WL",$JOB,"DIV","AP",LRIN,0)=LRGTOTS
+18 SET LRGTOTS=$GET(^TMP("LRAR-WL",$JOB,"DIV","CP",LRIN,0))
+19 SET $PIECE(LRGTOTS,U)=$PIECE(LRGTOTS,U)+LRCPINGT
+20 SET ^TMP("LRAR-WL",$JOB,"DIV","CP",LRIN,0)=LRGTOTS
+21 QUIT
CC ;
+1 SET LRCCN=0
SET LRCCN=$ORDER(^LAR(64.19999,LRIN,1,LRCDTN,1,"B",LRCC,LRCCN))
+2 SET LRCCZ=$PIECE(^LAR(64.19999,LRIN,1,LRCDTN,1,LRCCN,0),U)
+3 if $EXTRACT(LRCCZ)="+"
SET LRCCZ=$EXTRACT(LRCCZ,2,99)
+4 SET LRCAPNUM=$$WKLDCODE^LRARCU(LRCCZ)
+5 SET LRCAPNAM=$$WKLDNAME^LRARCU(LRCAPIFN)
+6 DO BMPMANL^LRARCMR1
+7 SET LRCTM=$SELECT(LRCTMB=0:"",1:LRCTMB-.001)
+8 FOR
SET LRCTM=$ORDER(^LAR(64.19999,LRIN,1,LRCDTN,1,LRCCN,1,"B",LRCTM))
if (LRCTM>LRCTME)!(LRCTM="")
QUIT
SET LRCTMN=0
SET LRCTMN=$ORDER(^LAR(64.19999,LRIN,1,LRCDTN,1,LRCCN,1,"B",LRCTM,LRCTMN))
DO TM
+9 QUIT
TM ;
+1 if '($DATA(^LAR(64.19999,LRIN,1,LRCDTN,1,LRCCN,1,LRCTMN,0))#2)
QUIT
SET LRX=^(0)
SET LRX1=^(1)
+2 SET LRMA=$PIECE(LRX,U,5)
SET X=LRMA
DO GETA
SET LRMA=+Y
+3 IF LRAA
if '$DATA(LRAA(LRMA))
QUIT
+4 SET LRUC=+$PIECE(LRX,U,3)
SET LRLDIV=$PIECE(LRX,U,4)
SET LRLSS=$PIECE(LRX,U,6)
SET X=LRLSS
DO GETA
SET LRLSS=+Y
if LRLDIV=""!(LRLDIV="CLINICAL PATHOLOGY")
SET LRLDIV="CP"
+5 IF LRLDIV="ANATOMIC PATHOLOGY"
SET LRLDIV="AP"
+6 if 'LRUC
SET LRUC=1
+7 IF +LRMA
Begin DoDot:1
+8 SET LRREC=$GET(^LRO(68,LRMA,0))
+9 SET LRMAA=$SELECT($PIECE(LRREC,U,11)]"":$PIECE(LRREC,U,11),1:LRNDFN)
+10 SET LRMAN=$SELECT($PIECE(LRREC,U)]"":$PIECE(LRREC,U),1:LRNDFN)
+11 SET LRMAN(LRMAA)=LRMAN
End DoDot:1
+12 IF '+LRMA
SET (LRMAA,LRMAN)=LRNDFN
SET LRMAN(LRMAA)=LRMAN
+13 IF +LRLSS
Begin DoDot:1
+14 SET LRREC=$GET(^LRO(68,LRLSS,0))
+15 SET LRLSSA=$SELECT($PIECE(LRREC,U,11)]"":$PIECE(LRREC,U,11),1:LRNDFN)
+16 SET LRLSSN=$SELECT($PIECE(LRREC,U)]"":$PIECE(LRREC,U),1:LRNDFN)
+17 SET LRLSSN(LRLSSA)=LRLSSN
End DoDot:1
+18 IF '+LRLSS
SET (LRLSSA,LRLSSN)=LRNDFN
SET LRLSSN(LRLSSA)=LRLSSN
+19 IF $DATA(^TMP("LRAR-WL",$JOB,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,LRCAPNAM))#2
Begin DoDot:1
+20 SET $PIECE(^(LRCAPNAM),U)=$PIECE(^TMP("LRAR-WL",$JOB,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,LRCAPNAM),U)+LRUC
End DoDot:1
+21 IF '$TEST
Begin DoDot:1
+22 SET ^TMP("LRAR-WL",$JOB,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,LRCAPNAM)=LRUC
+23 SET $PIECE(^TMP("LRAR-WL",$JOB,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,LRCAPNAM),U,2)=LRCAPNUM
End DoDot:1
+24 IF LRLDIV="AP"
Begin DoDot:1
+25 SET LRAPINGT=LRAPINGT+LRUC
End DoDot:1
+26 IF '$TEST
Begin DoDot:1
+27 SET LRCPINGT=LRCPINGT+LRUC
End DoDot:1
+28 IF $DATA(^TMP("LRAR-WL",$JOB,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,0))#2
Begin DoDot:1
+29 SET ^(0)=$PIECE(^TMP("LRAR-WL",$JOB,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,0),U)+LRUC
End DoDot:1
+30 IF '$TEST
Begin DoDot:1
+31 SET ^TMP("LRAR-WL",$JOB,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,0)=LRUC
End DoDot:1
+32 IF $DATA(^TMP("LRAR-WL",$JOB,"AA",LRMAA,LRLSSA,0))#2
Begin DoDot:1
+33 SET $PIECE(^(0),U)=$PIECE(^TMP("LRAR-WL",$JOB,"AA",LRMAA,LRLSSA,0),U)+LRUC
End DoDot:1
+34 IF '$TEST
Begin DoDot:1
+35 SET ^TMP("LRAR-WL",$JOB,"AA",LRMAA,LRLSSA,0)=LRUC
End DoDot:1
+36 QUIT
GTIN ;
+1 if LRGETIN
SET LRIN=+$ORDER(^LAR(64.19999,LRIN))
+2 if LRIN
SET LRINN=^LAR(64.19999,LRIN,0)
+3 SET LRGETIN=1
+4 QUIT
GETA ;Get pointer value for file 68
+1 KILL DIC
SET DIC=68
SET DIC(0)="XMZ"
+2 DO ^DIC
if Y=-1
QUIT
+3 QUIT
