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

LRCAPMA1 ;SLC/AM/DALISC/FHS/J0  -  WKLD REPORT BY MAJ SCTN; 2/6/91
 ;;5.2;LAB SERVICE;**105,119**;Sep 27, 1994
EN ;
 D INITMAN^LRCAPMR1
 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^LRCAPMR1,CAPCOM^LRCAPMR1
 S (LRAPICGT,LRAPIIGT,LRAPIOGT,LRAPINGT)=0
 S (LRCPICGT,LRCPIIGT,LRCPIOGT,LRCPINGT)=0
 S LRCDT=LRCDTB-1
 F  S LRCDT=$O(^LRO(64.1,LRIN,1,LRCDT)) Q:(LRCDT>LRCDTE)!(LRCDT<1)  D
 . D DATCOM^LRCAPMR1
 . W:$E(IOST,1,2)="C-" "."
 . S LRCC=0
 . F  S LRCC=$O(^LRO(64.1,LRIN,1,LRCDT,1,LRCC)) Q:(LRCC<1)  D CC
 S LRGTOTS=$G(^TMP("LR-WL",$J,0))
 S $P(LRGTOTS,U)=$P(LRGTOTS,U)+LRAPICGT+LRCPICGT
 S $P(LRGTOTS,U,2)=$P(LRGTOTS,U,2)+LRAPIIGT+LRCPIIGT
 S $P(LRGTOTS,U,3)=$P(LRGTOTS,U,3)+LRAPIOGT+LRCPIOGT
 S $P(LRGTOTS,U,4)=$P(LRGTOTS,U,4)+LRAPINGT+LRCPINGT
 S ^TMP("LR-WL",$J,0)=LRGTOTS
 S LRGTOTS=$G(^TMP("LR-WL",$J,"DIV","AP",LRIN,0))
 S $P(LRGTOTS,U)=$P(LRGTOTS,U)+LRAPICGT
 S $P(LRGTOTS,U,2)=$P(LRGTOTS,U,2)+LRAPIIGT
 S $P(LRGTOTS,U,3)=$P(LRGTOTS,U,3)+LRAPIOGT
 S $P(LRGTOTS,U,4)=$P(LRGTOTS,U,4)+LRAPINGT
 S ^TMP("LR-WL",$J,"DIV","AP",LRIN,0)=LRGTOTS
 S LRGTOTS=$G(^TMP("LR-WL",$J,"DIV","CP",LRIN,0))
 S $P(LRGTOTS,U)=$P(LRGTOTS,U)+LRCPICGT
 S $P(LRGTOTS,U,2)=$P(LRGTOTS,U,2)+LRCPIIGT
 S $P(LRGTOTS,U,3)=$P(LRGTOTS,U,3)+LRCPIOGT
 S $P(LRGTOTS,U,4)=$P(LRGTOTS,U,4)+LRCPINGT
 S ^TMP("LR-WL",$J,"DIV","CP",LRIN,0)=LRGTOTS
 Q
CC ;
 S LRCAPNAM=$$WKLDNAME^LRCAPU(LRCC)
 D BMPMANL^LRCAPMR1
 S LRCTM=$S(LRCTMB=0:"",1:LRCTMB-.001)
 F  S LRCTM=$O(^LRO(64.1,LRIN,1,LRCDT,1,LRCC,1,LRCTM)) Q:(LRCTM>LRCTME)!(LRCTM="")  D TM
 Q
TM ;
 Q:'($D(^LRO(64.1,LRIN,1,LRCDT,1,LRCC,1,LRCTM,0))#2)
 S LRX=^(0)
 S LRMA=+$P(LRX,U,7)
 I LRAA Q:'$D(LRAA(LRMA))
 S LRUC=+$P(LRX,U,3),LRLDIV=$P(LRX,U,6),LRLSS=$P(LRX,U,8) S:LRLDIV="" LRLDIV="CP"
 S:'LRUC LRUC=1
 S LRTYP=$$CHKTYP(LRX) Q:'LRTYP
 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("LR-WL",$J,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,LRCAPNAM))#2 D
 . S $P(^(LRCAPNAM),U,LRTYP)=$P(^TMP("LR-WL",$J,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,LRCAPNAM),U,LRTYP)+LRUC
 E  D
 . S $P(^TMP("LR-WL",$J,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,LRCAPNAM),U,LRTYP)=LRUC
 . S $P(^TMP("LR-WL",$J,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,LRCAPNAM),U,5)=LRCAPNUM
 I LRLDIV="AP" D
 . S LRGT=$S(LRTYP=1:"LRAPICGT",LRTYP=2:"LRAPIIGT",LRTYP=3:"LRAPIOGT",1:"LRAPINGT")
 . S @LRGT=@LRGT+LRUC
 E  D
 . S LRGT=$S(LRTYP=1:"LRCPICGT",LRTYP=2:"LRCPIIGT",LRTYP=3:"LRCPIOGT",1:"LRCPINGT")
 . S @LRGT=@LRGT+LRUC
 I $D(^TMP("LR-WL",$J,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,0))#2 D
 . S $P(^(0),U,LRTYP)=$P(^TMP("LR-WL",$J,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,0),U,LRTYP)+LRUC
 E  D
 . S $P(^TMP("LR-WL",$J,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,0),U,LRTYP)=LRUC
 I $D(^TMP("LR-WL",$J,"AA",LRMAA,LRLSSA,0))#2 D
 . S $P(^(0),U,LRTYP)=$P(^TMP("LR-WL",$J,"AA",LRMAA,LRLSSA,0),U,LRTYP)+LRUC
 E  D
 . S $P(^TMP("LR-WL",$J,"AA",LRMAA,LRLSSA,0),U,LRTYP)=LRUC
 Q
GTIN ;
 S:LRGETIN LRIN=+$O(^LRO(64.1,LRIN))
 S:LRIN LRINN=$S($D(^DIC(4,LRIN,0))#2:$P(^DIC(4,LRIN,0),U),1:LRNDFN)
 S LRGETIN=1
 Q
CHKTYP(LRREC) ;
 N LRFIL,LRLTYP
 S LRFIL=$P(LRREC,U,10),LRFIL=$P(LRFIL,";",2)
 S LRLTYP=$P(LRREC,U,19)
 S:LRFIL="" LRFIL=" " S:LRLTYP="" LRLTYP=" "
 Q:LRFIL="LAB(62.3," 1
 Q:((LRFIL="DPT(")&("ORW"[LRLTYP)) 2
 Q:LRFIL="DPT(" 3
 Q 4