source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRARCMA1.m@ 724

Last change on this file since 724 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.2 KB
Line 
1LRARCMA1 ;DALISC/CKA - ARCHIVED WKLD REPORT BY MAJ SCTN; 2/6/91
2 ;;5.2;LAB SERVICE;**59**;Aug 31,1995
3 ;same as LRCAPMA1 except archived wkld file
4EN ;
5 D INITMAN^LRARCMR1
6 S LRGETIN=$S(LRIN:0,1:1)
7 F D BUILD Q:(LREND)!('LRLOOP)!(LRBLDONE)
8 Q
9BUILD ; BUILD DATA SUBSET IN ^TMP
10 D GTIN
11 I 'LRIN S LRBLDONE=1 Q
12 ;D GENCOM^LRARCMR1,CAPCOM^LRARCMR1
13 S (LRAPINGT,LRCPINGT)=0
14 S LRCDT=LRCDTB-1
15 F S LRCDT=$O(^LAR(64.19999,LRIN,1,"B",LRCDT)) Q:(LRCDT>LRCDTE)!(LRCDT<1) D
16 . S LRCDTN=0,LRCDTN=$O(^LAR(64.19999,LRIN,1,"B",LRCDT,LRCDTN))
17 . D DATCOM^LRARCMR1
18 . W:$E(IOST,1,2)="C-" "."
19 . S LRCC=0
20 . F S LRCC=$O(^LAR(64.19999,LRIN,1,LRCDTN,1,"B",LRCC)) Q:(LRCC="") D CC
21 S LRGTOTS=$G(^TMP("LRAR-WL",$J,0))
22 S $P(LRGTOTS,U)=$P(LRGTOTS,U)+LRAPINGT+LRCPINGT
23 S ^TMP("LRAR-WL",$J,0)=LRGTOTS
24 S LRGTOTS=$G(^TMP("LRAR-WL",$J,"DIV","AP",LRIN,0))
25 S $P(LRGTOTS,U)=$P(LRGTOTS,U)+LRAPINGT
26 S ^TMP("LRAR-WL",$J,"DIV","AP",LRIN,0)=LRGTOTS
27 S LRGTOTS=$G(^TMP("LRAR-WL",$J,"DIV","CP",LRIN,0))
28 S $P(LRGTOTS,U)=$P(LRGTOTS,U)+LRCPINGT
29 S ^TMP("LRAR-WL",$J,"DIV","CP",LRIN,0)=LRGTOTS
30 Q
31CC ;
32 S LRCCN=0,LRCCN=$O(^LAR(64.19999,LRIN,1,LRCDTN,1,"B",LRCC,LRCCN))
33 S LRCCZ=$P(^LAR(64.19999,LRIN,1,LRCDTN,1,LRCCN,0),U)
34 S:$E(LRCCZ)="+" LRCCZ=$E(LRCCZ,2,99)
35 S LRCAPNUM=$$WKLDCODE^LRARCU(LRCCZ)
36 S LRCAPNAM=$$WKLDNAME^LRARCU(LRCAPIFN)
37 D BMPMANL^LRARCMR1
38 S LRCTM=$S(LRCTMB=0:"",1:LRCTMB-.001)
39 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
40 Q
41TM ;
42 Q:'($D(^LAR(64.19999,LRIN,1,LRCDTN,1,LRCCN,1,LRCTMN,0))#2) S LRX=^(0),LRX1=^(1)
43 S LRMA=$P(LRX,U,5),X=LRMA D GETA S LRMA=+Y
44 I LRAA Q:'$D(LRAA(LRMA))
45 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"
46 I LRLDIV="ANATOMIC PATHOLOGY" S LRLDIV="AP"
47 S:'LRUC LRUC=1
48 I +LRMA D
49 . S LRREC=$G(^LRO(68,LRMA,0))
50 . S LRMAA=$S($P(LRREC,U,11)]"":$P(LRREC,U,11),1:LRNDFN)
51 . S LRMAN=$S($P(LRREC,U)]"":$P(LRREC,U),1:LRNDFN)
52 . S LRMAN(LRMAA)=LRMAN
53 I '+LRMA S (LRMAA,LRMAN)=LRNDFN,LRMAN(LRMAA)=LRMAN
54 I +LRLSS D
55 . S LRREC=$G(^LRO(68,LRLSS,0))
56 . S LRLSSA=$S($P(LRREC,U,11)]"":$P(LRREC,U,11),1:LRNDFN)
57 . S LRLSSN=$S($P(LRREC,U)]"":$P(LRREC,U),1:LRNDFN)
58 . S LRLSSN(LRLSSA)=LRLSSN
59 I '+LRLSS S (LRLSSA,LRLSSN)=LRNDFN,LRLSSN(LRLSSA)=LRLSSN
60 I $D(^TMP("LRAR-WL",$J,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,LRCAPNAM))#2 D
61 . S $P(^(LRCAPNAM),U)=$P(^TMP("LRAR-WL",$J,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,LRCAPNAM),U)+LRUC
62 E D
63 . S ^TMP("LRAR-WL",$J,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,LRCAPNAM)=LRUC
64 . S $P(^TMP("LRAR-WL",$J,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,LRCAPNAM),U,2)=LRCAPNUM
65 I LRLDIV="AP" D
66 . S LRAPINGT=LRAPINGT+LRUC
67 E D
68 . S LRCPINGT=LRCPINGT+LRUC
69 I $D(^TMP("LRAR-WL",$J,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,0))#2 D
70 . S ^(0)=$P(^TMP("LRAR-WL",$J,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,0),U)+LRUC
71 E D
72 . S ^TMP("LRAR-WL",$J,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,0)=LRUC
73 I $D(^TMP("LRAR-WL",$J,"AA",LRMAA,LRLSSA,0))#2 D
74 . S $P(^(0),U)=$P(^TMP("LRAR-WL",$J,"AA",LRMAA,LRLSSA,0),U)+LRUC
75 E D
76 . S ^TMP("LRAR-WL",$J,"AA",LRMAA,LRLSSA,0)=LRUC
77 Q
78GTIN ;
79 S:LRGETIN LRIN=+$O(^LAR(64.19999,LRIN))
80 S:LRIN LRINN=^LAR(64.19999,LRIN,0)
81 S LRGETIN=1
82 Q
83GETA ;Get pointer value for file 68
84 K DIC S DIC=68,DIC(0)="XMZ"
85 D ^DIC Q:Y=-1
86 Q
Note: See TracBrowser for help on using the repository browser.