Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LRCAPMA1

LRCAPMA1.m

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