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

LRARCML1.m

Go to the documentation of this file.
  1. LRARCML1 ;DALISC/CKA - ARCHIVED WKLD COST REP BY MAJ SCTN; 5/22/95
  1. ;;5.2;LAB SERVICE;**59**;Aug 31, 1995
  1. ;same as LRCAPML1 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. S (LRAPIGT,LRAPIGTU,LRCPIGT,LRCPIGTU)=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=""
  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)+LRAPIGT+LRCPIGT
  1. S $P(LRGTOTS,U,2)=$P(LRGTOTS,U,2)+LRAPIGTU+LRCPIGTU
  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)+LRAPIGT
  1. S $P(LRGTOTS,U,2)=$P(LRGTOTS,U,2)+LRAPIGTU
  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)+LRCPIGT
  1. S $P(LRGTOTS,U,2)=$P(LRGTOTS,U,2)+LRCPIGTU
  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),LRFIRST=1
  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),LRX4=$G(^LAR(64.19999,LRIN,1,LRCDTN,1,LRCCN,1,LRCTMN,4))
  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),LRSPEC=+$P(LRX4,U)
  1. S:LRLDIV="ANATOMIC PATHOLOGY" LRLDIV="AP"
  1. S:LRLDIV="CLINICAL PATHOLOGY" LRLDIV="CP"
  1. S:'LRUC LRUC=1
  1. S LRUW=+$P($G(^LAM(LRCAPIFN,0)),U,10),LRFIRST=0 S LRUWSP=+$P($G(^LAM(LRCAPIFN,5,LRSPEC,0)),U,2) S:LRUWSP LRUW=LRUWSP_"*" K LRUWSP
  1. S LRWC=LRUC*LRUW
  1. ;
  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 X=LRLSS D GETA S LRLSS=+Y
  1. . Q:'+LRLSS
  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. ;
  1. ;
  1. I $D(^TMP("LRAR-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
  1. E S ^TMP("LRAR-WL",$J,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,LRCAPNAM)=LRUC_"^"_LRWC_"^"_LRUW_"^"_LRCAPNUM
  1. I LRLDIV="AP" S LRAPIGT=LRAPIGT+LRWC,LRAPIGTU=LRAPIGTU+LRUC
  1. E S LRCPIGT=LRCPIGT+LRWC,LRCPIGTU=LRCPIGTU+LRUC
  1. I $D(^TMP("LRAR-WL",$J,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,0))#2 S LRX1=+$P(^(0),"^")+LRWC,LRX2=+$P(^(0),"^",2)+LRUC,^(0)=LRX1_"^"_LRX2
  1. E S ^TMP("LRAR-WL",$J,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,0)=LRWC_"^"_LRUC
  1. I $D(^TMP("LRAR-WL",$J,"AA",LRMAA,LRLSSA,0))#2 S LRX1=+$P(^(0),"^")+LRWC,LRX2=+$P(^(0),"^",2)+LRUC,^(0)=LRX1_"^"_LRX2
  1. E S ^TMP("LRAR-WL",$J,"AA",LRMAA,LRLSSA,0)=LRWC_"^"_LRUC
  1. Q
  1. GTIN ;
  1. S:LRGETIN LRIN=+$O(^LAR(64.19999,LRIN))
  1. S:LRIN LRINN=$S($D(^LAR(64.19999,LRIN,0)):^(0),1:"UNDEFINED")
  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