source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRCAPML1.m@ 1006

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

initial load of WorldVistAEHR

File size: 2.9 KB
Line 
1LRCAPML1 ;SLC/AM/DALISC/FHS/J0 - WKLD COST REP BY MAJ SCTN; 2/6/91@16:04
2 ;;5.2;LAB SERVICE;;Sep 27, 1994
3EN ;
4 D INITMAN^LRCAPMR1
5 S LRGETIN=$S(LRIN:0,1:1)
6 F D BUILD Q:(LREND)!('LRLOOP)!(LRBLDONE)
7 Q
8BUILD ; BUILD DATA SUBSET IN ^TMP
9 D GTIN
10 I 'LRIN S LRBLDONE=1 Q
11 D GENCOM^LRCAPMR1,CAPCOM^LRCAPMR1
12 S (LRAPIGT,LRAPIGTU,LRCPIGT,LRCPIGTU)=0
13 S LRCDT=LRCDTB-1
14 F S LRCDT=$O(^LRO(64.1,LRIN,1,LRCDT)) Q:(LRCDT>LRCDTE)!(LRCDT<1) D
15 . D DATCOM^LRCAPMR1
16 . W:$E(IOST,1,2)="C-" "."
17 . S LRCC=0
18 . F S LRCC=$O(^LRO(64.1,LRIN,1,LRCDT,1,LRCC)) Q:(LRCC<1) D CC
19 S LRGTOTS=$G(^TMP("LR-WL",$J,0))
20 S $P(LRGTOTS,U)=$P(LRGTOTS,U)+LRAPIGT+LRCPIGT
21 S $P(LRGTOTS,U,2)=$P(LRGTOTS,U,2)+LRAPIGTU+LRCPIGTU
22 S ^TMP("LR-WL",$J,0)=LRGTOTS
23 S LRGTOTS=$G(^TMP("LR-WL",$J,"DIV","AP",LRIN,0))
24 S $P(LRGTOTS,U)=$P(LRGTOTS,U)+LRAPIGT
25 S $P(LRGTOTS,U,2)=$P(LRGTOTS,U,2)+LRAPIGTU
26 S ^TMP("LR-WL",$J,"DIV","AP",LRIN,0)=LRGTOTS
27 S LRGTOTS=$G(^TMP("LR-WL",$J,"DIV","CP",LRIN,0))
28 S $P(LRGTOTS,U)=$P(LRGTOTS,U)+LRCPIGT
29 S $P(LRGTOTS,U,2)=$P(LRGTOTS,U,2)+LRCPIGTU
30 S ^TMP("LR-WL",$J,"DIV","CP",LRIN,0)=LRGTOTS
31 Q
32CC ;
33 S LRCAPNAM=$$WKLDNAME^LRCAPU(LRCC)
34 D BMPMANL^LRCAPMR1
35 S LRCTM=$S(LRCTMB=0:"",1:LRCTMB-.001),LRFIRST=1
36 F S LRCTM=$O(^LRO(64.1,LRIN,1,LRCDT,1,LRCC,1,LRCTM)) Q:(LRCTM>LRCTME)!(LRCTM="") D TM
37 Q
38TM ;
39 Q:'($D(^LRO(64.1,LRIN,1,LRCDT,1,LRCC,1,LRCTM,0))#2)
40 S LRX=^(0)
41 S LRMA=$P(LRX,U,7)
42 I LRAA Q:'$D(LRAA(LRMA))
43 S LRUC=+$P(LRX,U,3),LRLDIV=$P(LRX,U,6),LRLSS=$P(LRX,U,8),LRSPEC=+$P(LRX,U,14)
44 S:'LRUC LRUC=1
45 S LRUW=+$P($G(^LAM(LRCC,0)),U,10),LRFIRST=0 S LRUWSP=+$P($G(^LAM(LRCC,5,LRSPEC,0)),U,2) S:LRUWSP LRUW=LRUWSP_"*" K LRUWSP
46 S LRWC=LRUC*LRUW
47 ;
48 ;
49 I +LRMA D
50 . S LRREC=$G(^LRO(68,LRMA,0))
51 . S LRMAA=$S($P(LRREC,U,11)]"":$P(LRREC,U,11),1:LRNDFN)
52 . S LRMAN=$S($P(LRREC,U)]"":$P(LRREC,U),1:LRNDFN)
53 . S LRMAN(LRMAA)=LRMAN
54 I '+LRMA S (LRMAA,LRMAN)=LRNDFN,LRMAN(LRMAA)=LRMAN
55 I +LRLSS D
56 . S LRREC=$G(^LRO(68,LRLSS,0))
57 . S LRLSSA=$S($P(LRREC,U,11)]"":$P(LRREC,U,11),1:LRNDFN)
58 . S LRLSSN=$S($P(LRREC,U)]"":$P(LRREC,U),1:LRNDFN)
59 . S LRLSSN(LRLSSA)=LRLSSN
60 I '+LRLSS S (LRLSSA,LRLSSN)=LRNDFN,LRLSSN(LRLSSA)=LRLSSN
61 ;
62 ;
63 I $D(^TMP("LR-WL",$J,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,LRCAPNAM))#2 S LRX=^(LRCAPNAM),LRX1=LRUC+$P(LRX,"^"),LRX2=LRWC+$P(LRX,"^",2),^(LRCAPNAM)=LRX1_"^"_LRX2_"^"_LRUW_"^"_LRCAPNUM
64 E S ^TMP("LR-WL",$J,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,LRCAPNAM)=LRUC_"^"_LRWC_"^"_LRUW_"^"_LRCAPNUM
65 I LRLDIV="AP" S LRAPIGT=LRAPIGT+LRWC,LRAPIGTU=LRAPIGTU+LRUC
66 E S LRCPIGT=LRCPIGT+LRWC,LRCPIGTU=LRCPIGTU+LRUC
67 I $D(^TMP("LR-WL",$J,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,0))#2 S LRX1=+$P(^(0),"^")+LRWC,LRX2=+$P(^(0),"^",2)+LRUC,^(0)=LRX1_"^"_LRX2
68 E S ^TMP("LR-WL",$J,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,0)=LRWC_"^"_LRUC
69 I $D(^TMP("LR-WL",$J,"AA",LRMAA,LRLSSA,0))#2 S LRX1=+$P(^(0),"^")+LRWC,LRX2=+$P(^(0),"^",2)+LRUC,^(0)=LRX1_"^"_LRX2
70 E S ^TMP("LR-WL",$J,"AA",LRMAA,LRLSSA,0)=LRWC_"^"_LRUC
71 Q
72GTIN ;
73 S:LRGETIN LRIN=+$O(^LRO(64.1,LRIN))
74 S:LRIN LRINN=$S($D(^DIC(4,LRIN,0))#2:$P(^DIC(4,LRIN,0),U),1:LRNDFN)
75 S LRGETIN=1
76 Q
Note: See TracBrowser for help on using the repository browser.