source: FOIAVistA/trunk/r/LAB_SERVICE-LR-LS/LRCAPMA1.m@ 794

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

initial load of FOIAVistA 6/30/08 version

File size: 3.6 KB
Line 
1LRCAPMA1 ;SLC/AM/DALISC/FHS/J0 - WKLD REPORT BY MAJ SCTN; 2/6/91
2 ;;5.2;LAB SERVICE;**105,119**;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 (LRAPICGT,LRAPIIGT,LRAPIOGT,LRAPINGT)=0
13 S (LRCPICGT,LRCPIIGT,LRCPIOGT,LRCPINGT)=0
14 S LRCDT=LRCDTB-1
15 F S LRCDT=$O(^LRO(64.1,LRIN,1,LRCDT)) Q:(LRCDT>LRCDTE)!(LRCDT<1) D
16 . D DATCOM^LRCAPMR1
17 . W:$E(IOST,1,2)="C-" "."
18 . S LRCC=0
19 . F S LRCC=$O(^LRO(64.1,LRIN,1,LRCDT,1,LRCC)) Q:(LRCC<1) D CC
20 S LRGTOTS=$G(^TMP("LR-WL",$J,0))
21 S $P(LRGTOTS,U)=$P(LRGTOTS,U)+LRAPICGT+LRCPICGT
22 S $P(LRGTOTS,U,2)=$P(LRGTOTS,U,2)+LRAPIIGT+LRCPIIGT
23 S $P(LRGTOTS,U,3)=$P(LRGTOTS,U,3)+LRAPIOGT+LRCPIOGT
24 S $P(LRGTOTS,U,4)=$P(LRGTOTS,U,4)+LRAPINGT+LRCPINGT
25 S ^TMP("LR-WL",$J,0)=LRGTOTS
26 S LRGTOTS=$G(^TMP("LR-WL",$J,"DIV","AP",LRIN,0))
27 S $P(LRGTOTS,U)=$P(LRGTOTS,U)+LRAPICGT
28 S $P(LRGTOTS,U,2)=$P(LRGTOTS,U,2)+LRAPIIGT
29 S $P(LRGTOTS,U,3)=$P(LRGTOTS,U,3)+LRAPIOGT
30 S $P(LRGTOTS,U,4)=$P(LRGTOTS,U,4)+LRAPINGT
31 S ^TMP("LR-WL",$J,"DIV","AP",LRIN,0)=LRGTOTS
32 S LRGTOTS=$G(^TMP("LR-WL",$J,"DIV","CP",LRIN,0))
33 S $P(LRGTOTS,U)=$P(LRGTOTS,U)+LRCPICGT
34 S $P(LRGTOTS,U,2)=$P(LRGTOTS,U,2)+LRCPIIGT
35 S $P(LRGTOTS,U,3)=$P(LRGTOTS,U,3)+LRCPIOGT
36 S $P(LRGTOTS,U,4)=$P(LRGTOTS,U,4)+LRCPINGT
37 S ^TMP("LR-WL",$J,"DIV","CP",LRIN,0)=LRGTOTS
38 Q
39CC ;
40 S LRCAPNAM=$$WKLDNAME^LRCAPU(LRCC)
41 D BMPMANL^LRCAPMR1
42 S LRCTM=$S(LRCTMB=0:"",1:LRCTMB-.001)
43 F S LRCTM=$O(^LRO(64.1,LRIN,1,LRCDT,1,LRCC,1,LRCTM)) Q:(LRCTM>LRCTME)!(LRCTM="") D TM
44 Q
45TM ;
46 Q:'($D(^LRO(64.1,LRIN,1,LRCDT,1,LRCC,1,LRCTM,0))#2)
47 S LRX=^(0)
48 S LRMA=+$P(LRX,U,7)
49 I LRAA Q:'$D(LRAA(LRMA))
50 S LRUC=+$P(LRX,U,3),LRLDIV=$P(LRX,U,6),LRLSS=$P(LRX,U,8) S:LRLDIV="" LRLDIV="CP"
51 S:'LRUC LRUC=1
52 S LRTYP=$$CHKTYP(LRX) Q:'LRTYP
53 I +LRMA D
54 . S LRREC=$G(^LRO(68,LRMA,0))
55 . S LRMAA=$S($P(LRREC,U,11)]"":$P(LRREC,U,11),1:LRNDFN)
56 . S LRMAN=$S($P(LRREC,U)]"":$P(LRREC,U),1:LRNDFN)
57 . S LRMAN(LRMAA)=LRMAN
58 I '+LRMA S (LRMAA,LRMAN)=LRNDFN,LRMAN(LRMAA)=LRMAN
59 I +LRLSS D
60 . S LRREC=$G(^LRO(68,LRLSS,0))
61 . S LRLSSA=$S($P(LRREC,U,11)]"":$P(LRREC,U,11),1:LRNDFN)
62 . S LRLSSN=$S($P(LRREC,U)]"":$P(LRREC,U),1:LRNDFN)
63 . S LRLSSN(LRLSSA)=LRLSSN
64 I '+LRLSS S (LRLSSA,LRLSSN)=LRNDFN,LRLSSN(LRLSSA)=LRLSSN
65 I $D(^TMP("LR-WL",$J,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,LRCAPNAM))#2 D
66 . S $P(^(LRCAPNAM),U,LRTYP)=$P(^TMP("LR-WL",$J,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,LRCAPNAM),U,LRTYP)+LRUC
67 E D
68 . S $P(^TMP("LR-WL",$J,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,LRCAPNAM),U,LRTYP)=LRUC
69 . S $P(^TMP("LR-WL",$J,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,LRCAPNAM),U,5)=LRCAPNUM
70 I LRLDIV="AP" D
71 . S LRGT=$S(LRTYP=1:"LRAPICGT",LRTYP=2:"LRAPIIGT",LRTYP=3:"LRAPIOGT",1:"LRAPINGT")
72 . S @LRGT=@LRGT+LRUC
73 E D
74 . S LRGT=$S(LRTYP=1:"LRCPICGT",LRTYP=2:"LRCPIIGT",LRTYP=3:"LRCPIOGT",1:"LRCPINGT")
75 . S @LRGT=@LRGT+LRUC
76 I $D(^TMP("LR-WL",$J,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,0))#2 D
77 . S $P(^(0),U,LRTYP)=$P(^TMP("LR-WL",$J,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,0),U,LRTYP)+LRUC
78 E D
79 . S $P(^TMP("LR-WL",$J,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,0),U,LRTYP)=LRUC
80 I $D(^TMP("LR-WL",$J,"AA",LRMAA,LRLSSA,0))#2 D
81 . S $P(^(0),U,LRTYP)=$P(^TMP("LR-WL",$J,"AA",LRMAA,LRLSSA,0),U,LRTYP)+LRUC
82 E D
83 . S $P(^TMP("LR-WL",$J,"AA",LRMAA,LRLSSA,0),U,LRTYP)=LRUC
84 Q
85GTIN ;
86 S:LRGETIN LRIN=+$O(^LRO(64.1,LRIN))
87 S:LRIN LRINN=$S($D(^DIC(4,LRIN,0))#2:$P(^DIC(4,LRIN,0),U),1:LRNDFN)
88 S LRGETIN=1
89 Q
90CHKTYP(LRREC) ;
91 N LRFIL,LRLTYP
92 S LRFIL=$P(LRREC,U,10),LRFIL=$P(LRFIL,";",2)
93 S LRLTYP=$P(LRREC,U,19)
94 S:LRFIL="" LRFIL=" " S:LRLTYP="" LRLTYP=" "
95 Q:LRFIL="LAB(62.3," 1
96 Q:((LRFIL="DPT(")&("ORW"[LRLTYP)) 2
97 Q:LRFIL="DPT(" 3
98 Q 4
Note: See TracBrowser for help on using the repository browser.