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

LRARCMA1.m

Go to the documentation of this file. 
  1. LRARCMA1 ;DALISC/CKA  -  ARCHIVED WKLD REPORT BY MAJ SCTN; 2/6/91
  1.  ;;5.2;LAB SERVICE;**59**;Aug 31,1995
  1.  ;same as LRCAPMA1 except archived wkld file
  1. EN ;
  1.  D INITMAN^LRARCMR1
  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^LRARCMR1,CAPCOM^LRARCMR1
  1.  S (LRAPINGT,LRCPINGT)=0
  1.  S LRCDT=LRCDTB-1
  1.  F  S LRCDT=$O(^LAR(64.19999,LRIN,1,"B",LRCDT)) Q:(LRCDT>LRCDTE)!(LRCDT<1)  D
  1.  . S LRCDTN=0,LRCDTN=$O(^LAR(64.19999,LRIN,1,"B",LRCDT,LRCDTN))
  1.  . D DATCOM^LRARCMR1
  1.  . W:$E(IOST,1,2)="C-" "."
  1.  . S LRCC=0
  1.  . F  S LRCC=$O(^LAR(64.19999,LRIN,1,LRCDTN,1,"B",LRCC)) Q:(LRCC="")  D CC
  1.  S LRGTOTS=$G(^TMP("LRAR-WL",$J,0))
  1.  S $P(LRGTOTS,U)=$P(LRGTOTS,U)+LRAPINGT+LRCPINGT
  1.  S ^TMP("LRAR-WL",$J,0)=LRGTOTS
  1.  S LRGTOTS=$G(^TMP("LRAR-WL",$J,"DIV","AP",LRIN,0))
  1.  S $P(LRGTOTS,U)=$P(LRGTOTS,U)+LRAPINGT
  1.  S ^TMP("LRAR-WL",$J,"DIV","AP",LRIN,0)=LRGTOTS
  1.  S LRGTOTS=$G(^TMP("LRAR-WL",$J,"DIV","CP",LRIN,0))
  1.  S $P(LRGTOTS,U)=$P(LRGTOTS,U)+LRCPINGT
  1.  S ^TMP("LRAR-WL",$J,"DIV","CP",LRIN,0)=LRGTOTS
  1.  Q
  1. CC ;
  1.  S LRCCN=0,LRCCN=$O(^LAR(64.19999,LRIN,1,LRCDTN,1,"B",LRCC,LRCCN))
  1.  S LRCCZ=$P(^LAR(64.19999,LRIN,1,LRCDTN,1,LRCCN,0),U)
  1.  S:$E(LRCCZ)="+" LRCCZ=$E(LRCCZ,2,99)
  1.  S LRCAPNUM=$$WKLDCODE^LRARCU(LRCCZ)
  1.  S LRCAPNAM=$$WKLDNAME^LRARCU(LRCAPIFN)
  1.  D BMPMANL^LRARCMR1
  1.  S LRCTM=$S(LRCTMB=0:"",1:LRCTMB-.001)
  1.  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
  1.  Q
  1. TM ;
  1.  Q:'($D(^LAR(64.19999,LRIN,1,LRCDTN,1,LRCCN,1,LRCTMN,0))#2)  S LRX=^(0),LRX1=^(1)
  1.  S LRMA=$P(LRX,U,5),X=LRMA D GETA S LRMA=+Y
  1.  I LRAA Q:'$D(LRAA(LRMA))
  1.  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"
  1.  I LRLDIV="ANATOMIC PATHOLOGY" S LRLDIV="AP"
  1.  S:'LRUC LRUC=1
  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("LRAR-WL",$J,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,LRCAPNAM))#2 D
  1.  . S $P(^(LRCAPNAM),U)=$P(^TMP("LRAR-WL",$J,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,LRCAPNAM),U)+LRUC
  1.  E  D
  1.  . S ^TMP("LRAR-WL",$J,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,LRCAPNAM)=LRUC
  1.  . S $P(^TMP("LRAR-WL",$J,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,LRCAPNAM),U,2)=LRCAPNUM
  1.  I LRLDIV="AP" D
  1.  . S LRAPINGT=LRAPINGT+LRUC
  1.  E  D
  1.  . S LRCPINGT=LRCPINGT+LRUC
  1.  I $D(^TMP("LRAR-WL",$J,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,0))#2 D
  1.  . S ^(0)=$P(^TMP("LRAR-WL",$J,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,0),U)+LRUC
  1.  E  D
  1.  . S ^TMP("LRAR-WL",$J,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,0)=LRUC
  1.  I $D(^TMP("LRAR-WL",$J,"AA",LRMAA,LRLSSA,0))#2 D
  1.  . S $P(^(0),U)=$P(^TMP("LRAR-WL",$J,"AA",LRMAA,LRLSSA,0),U)+LRUC
  1.  E  D
  1.  . S ^TMP("LRAR-WL",$J,"AA",LRMAA,LRLSSA,0)=LRUC
  1.  Q
  1. GTIN ;
  1.  S:LRGETIN LRIN=+$O(^LAR(64.19999,LRIN))
  1.  S:LRIN LRINN=^LAR(64.19999,LRIN,0)
  1.  S LRGETIN=1
  1.  Q
  1. GETA ;Get pointer value for file 68
  1.  K DIC S DIC=68,DIC(0)="XMZ"
  1.  D ^DIC Q:Y=-1
  1.  Q