- LRARCML1 ;DALISC/CKA - ARCHIVED WKLD COST REP BY MAJ SCTN; 5/22/95
- ;;5.2;LAB SERVICE;**59**;Aug 31, 1995
- ;same as LRCAPML1 except archived wkld file
- EN ;
- D INITMAN^LRARCMR1
- 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
- S (LRAPIGT,LRAPIGTU,LRCPIGT,LRCPIGTU)=0
- S LRCDT=LRCDTB-1
- F S LRCDT=$O(^LAR(64.19999,LRIN,1,"B",LRCDT)) Q:(LRCDT>LRCDTE)!(LRCDT<1) D
- . S LRCDTN=0,LRCDTN=$O(^LAR(64.19999,LRIN,1,"B",LRCDT,LRCDTN))
- . D DATCOM^LRARCMR1
- . W:$E(IOST,1,2)="C-" "."
- . S LRCC=""
- . F S LRCC=$O(^LAR(64.19999,LRIN,1,LRCDTN,1,"B",LRCC)) Q:(LRCC="") D CC
- S LRGTOTS=$G(^TMP("LRAR-WL",$J,0))
- S $P(LRGTOTS,U)=$P(LRGTOTS,U)+LRAPIGT+LRCPIGT
- S $P(LRGTOTS,U,2)=$P(LRGTOTS,U,2)+LRAPIGTU+LRCPIGTU
- S ^TMP("LRAR-WL",$J,0)=LRGTOTS
- S LRGTOTS=$G(^TMP("LRAR-WL",$J,"DIV","AP",LRIN,0))
- S $P(LRGTOTS,U)=$P(LRGTOTS,U)+LRAPIGT
- S $P(LRGTOTS,U,2)=$P(LRGTOTS,U,2)+LRAPIGTU
- S ^TMP("LRAR-WL",$J,"DIV","AP",LRIN,0)=LRGTOTS
- S LRGTOTS=$G(^TMP("LRAR-WL",$J,"DIV","CP",LRIN,0))
- S $P(LRGTOTS,U)=$P(LRGTOTS,U)+LRCPIGT
- S $P(LRGTOTS,U,2)=$P(LRGTOTS,U,2)+LRCPIGTU
- S ^TMP("LRAR-WL",$J,"DIV","CP",LRIN,0)=LRGTOTS
- Q
- CC ;
- S LRCCN=0,LRCCN=$O(^LAR(64.19999,LRIN,1,LRCDTN,1,"B",LRCC,LRCCN))
- S LRCCZ=$P(^LAR(64.19999,LRIN,1,LRCDTN,1,LRCCN,0),U)
- S:$E(LRCCZ)="+" LRCCZ=$E(LRCCZ,2,99)
- S LRCAPNUM=$$WKLDCODE^LRARCU(LRCCZ)
- S LRCAPNAM=$$WKLDNAME^LRARCU(LRCAPIFN)
- D BMPMANL^LRARCMR1
- S LRCTM=$S(LRCTMB=0:"",1:LRCTMB-.001),LRFIRST=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
- Q
- TM ;
- 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))
- S LRMA=$P(LRX,U,5),X=LRMA D GETA S LRMA=+Y
- I LRAA Q:'$D(LRAA(LRMA))
- S LRUC=+$P(LRX,U,3),LRLDIV=$P(LRX,U,4),LRLSS=$P(LRX,U,6),LRSPEC=+$P(LRX4,U)
- S:LRLDIV="ANATOMIC PATHOLOGY" LRLDIV="AP"
- S:LRLDIV="CLINICAL PATHOLOGY" LRLDIV="CP"
- S:'LRUC LRUC=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
- S LRWC=LRUC*LRUW
- ;
- ;
- 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 X=LRLSS D GETA S LRLSS=+Y
- . Q:'+LRLSS
- . 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("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
- E S ^TMP("LRAR-WL",$J,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,LRCAPNAM)=LRUC_"^"_LRWC_"^"_LRUW_"^"_LRCAPNUM
- I LRLDIV="AP" S LRAPIGT=LRAPIGT+LRWC,LRAPIGTU=LRAPIGTU+LRUC
- E S LRCPIGT=LRCPIGT+LRWC,LRCPIGTU=LRCPIGTU+LRUC
- 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
- E S ^TMP("LRAR-WL",$J,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,0)=LRWC_"^"_LRUC
- I $D(^TMP("LRAR-WL",$J,"AA",LRMAA,LRLSSA,0))#2 S LRX1=+$P(^(0),"^")+LRWC,LRX2=+$P(^(0),"^",2)+LRUC,^(0)=LRX1_"^"_LRX2
- E S ^TMP("LRAR-WL",$J,"AA",LRMAA,LRLSSA,0)=LRWC_"^"_LRUC
- Q
- GTIN ;
- S:LRGETIN LRIN=+$O(^LAR(64.19999,LRIN))
- S:LRIN LRINN=$S($D(^LAR(64.19999,LRIN,0)):^(0),1:"UNDEFINED")
- S LRGETIN=1
- Q
- GETA ;Get pointer value for file 68
- K DIC S DIC=68,DIC(0)="XMZ"
- D ^DIC Q:Y=-1
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRARCML1 3808 printed Feb 18, 2025@23:35:03 Page 2
- LRARCML1 ;DALISC/CKA - ARCHIVED WKLD COST REP BY MAJ SCTN; 5/22/95
- +1 ;;5.2;LAB SERVICE;**59**;Aug 31, 1995
- +2 ;same as LRCAPML1 except archived wkld file
- EN ;
- +1 DO INITMAN^LRARCMR1
- +2 SET LRGETIN=$SELECT(LRIN:0,1:1)
- +3 FOR
- DO BUILD
- if (LREND)!('LRLOOP)!(LRBLDONE)
- QUIT
- +4 QUIT
- BUILD ; BUILD DATA SUBSET IN ^TMP
- +1 DO GTIN
- +2 IF 'LRIN
- SET LRBLDONE=1
- QUIT
- +3 SET (LRAPIGT,LRAPIGTU,LRCPIGT,LRCPIGTU)=0
- +4 SET LRCDT=LRCDTB-1
- +5 FOR
- SET LRCDT=$ORDER(^LAR(64.19999,LRIN,1,"B",LRCDT))
- if (LRCDT>LRCDTE)!(LRCDT<1)
- QUIT
- Begin DoDot:1
- +6 SET LRCDTN=0
- SET LRCDTN=$ORDER(^LAR(64.19999,LRIN,1,"B",LRCDT,LRCDTN))
- +7 DO DATCOM^LRARCMR1
- +8 if $EXTRACT(IOST,1,2)="C-"
- WRITE "."
- +9 SET LRCC=""
- +10 FOR
- SET LRCC=$ORDER(^LAR(64.19999,LRIN,1,LRCDTN,1,"B",LRCC))
- if (LRCC="")
- QUIT
- DO CC
- End DoDot:1
- +11 SET LRGTOTS=$GET(^TMP("LRAR-WL",$JOB,0))
- +12 SET $PIECE(LRGTOTS,U)=$PIECE(LRGTOTS,U)+LRAPIGT+LRCPIGT
- +13 SET $PIECE(LRGTOTS,U,2)=$PIECE(LRGTOTS,U,2)+LRAPIGTU+LRCPIGTU
- +14 SET ^TMP("LRAR-WL",$JOB,0)=LRGTOTS
- +15 SET LRGTOTS=$GET(^TMP("LRAR-WL",$JOB,"DIV","AP",LRIN,0))
- +16 SET $PIECE(LRGTOTS,U)=$PIECE(LRGTOTS,U)+LRAPIGT
- +17 SET $PIECE(LRGTOTS,U,2)=$PIECE(LRGTOTS,U,2)+LRAPIGTU
- +18 SET ^TMP("LRAR-WL",$JOB,"DIV","AP",LRIN,0)=LRGTOTS
- +19 SET LRGTOTS=$GET(^TMP("LRAR-WL",$JOB,"DIV","CP",LRIN,0))
- +20 SET $PIECE(LRGTOTS,U)=$PIECE(LRGTOTS,U)+LRCPIGT
- +21 SET $PIECE(LRGTOTS,U,2)=$PIECE(LRGTOTS,U,2)+LRCPIGTU
- +22 SET ^TMP("LRAR-WL",$JOB,"DIV","CP",LRIN,0)=LRGTOTS
- +23 QUIT
- CC ;
- +1 SET LRCCN=0
- SET LRCCN=$ORDER(^LAR(64.19999,LRIN,1,LRCDTN,1,"B",LRCC,LRCCN))
- +2 SET LRCCZ=$PIECE(^LAR(64.19999,LRIN,1,LRCDTN,1,LRCCN,0),U)
- +3 if $EXTRACT(LRCCZ)="+"
- SET LRCCZ=$EXTRACT(LRCCZ,2,99)
- +4 SET LRCAPNUM=$$WKLDCODE^LRARCU(LRCCZ)
- +5 SET LRCAPNAM=$$WKLDNAME^LRARCU(LRCAPIFN)
- +6 DO BMPMANL^LRARCMR1
- +7 SET LRCTM=$SELECT(LRCTMB=0:"",1:LRCTMB-.001)
- SET LRFIRST=1
- +8 FOR
- SET LRCTM=$ORDER(^LAR(64.19999,LRIN,1,LRCDTN,1,LRCCN,1,"B",LRCTM))
- if (LRCTM>LRCTME)!(LRCTM="")
- QUIT
- SET LRCTMN=0
- SET LRCTMN=$ORDER(^LAR(64.19999,LRIN,1,LRCDTN,1,LRCCN,1,"B",LRCTM,LRCTMN))
- DO TM
- +9 QUIT
- TM ;
- +1 if '($DATA(^LAR(64.19999,LRIN,1,LRCDTN,1,LRCCN,1,LRCTMN,0))#2)
- QUIT
- SET LRX=^(0)
- SET LRX4=$GET(^LAR(64.19999,LRIN,1,LRCDTN,1,LRCCN,1,LRCTMN,4))
- +2 SET LRMA=$PIECE(LRX,U,5)
- SET X=LRMA
- DO GETA
- SET LRMA=+Y
- +3 IF LRAA
- if '$DATA(LRAA(LRMA))
- QUIT
- +4 SET LRUC=+$PIECE(LRX,U,3)
- SET LRLDIV=$PIECE(LRX,U,4)
- SET LRLSS=$PIECE(LRX,U,6)
- SET LRSPEC=+$PIECE(LRX4,U)
- +5 if LRLDIV="ANATOMIC PATHOLOGY"
- SET LRLDIV="AP"
- +6 if LRLDIV="CLINICAL PATHOLOGY"
- SET LRLDIV="CP"
- +7 if 'LRUC
- SET LRUC=1
- +8 SET LRUW=+$PIECE($GET(^LAM(LRCAPIFN,0)),U,10)
- SET LRFIRST=0
- SET LRUWSP=+$PIECE($GET(^LAM(LRCAPIFN,5,LRSPEC,0)),U,2)
- if LRUWSP
- SET LRUW=LRUWSP_"*"
- KILL LRUWSP
- +9 SET LRWC=LRUC*LRUW
- +10 ;
- +11 ;
- +12 IF +LRMA
- Begin DoDot:1
- +13 SET LRREC=$GET(^LRO(68,LRMA,0))
- +14 SET LRMAA=$SELECT($PIECE(LRREC,U,11)]"":$PIECE(LRREC,U,11),1:LRNDFN)
- +15 SET LRMAN=$SELECT($PIECE(LRREC,U)]"":$PIECE(LRREC,U),1:LRNDFN)
- +16 SET LRMAN(LRMAA)=LRMAN
- End DoDot:1
- +17 IF '+LRMA
- SET (LRMAA,LRMAN)=LRNDFN
- SET LRMAN(LRMAA)=LRMAN
- +18 IF LRLSS]""
- Begin DoDot:1
- +19 SET X=LRLSS
- DO GETA
- SET LRLSS=+Y
- +20 if '+LRLSS
- QUIT
- +21 SET LRREC=$GET(^LRO(68,LRLSS,0))
- +22 SET LRLSSA=$SELECT($PIECE(LRREC,U,11)]"":$PIECE(LRREC,U,11),1:LRNDFN)
- +23 SET LRLSSN=$SELECT($PIECE(LRREC,U)]"":$PIECE(LRREC,U),1:LRNDFN)
- +24 SET LRLSSN(LRLSSA)=LRLSSN
- End DoDot:1
- +25 IF '+LRLSS
- SET (LRLSSA,LRLSSN)=LRNDFN
- SET LRLSSN(LRLSSA)=LRLSSN
- +26 ;
- +27 ;
- +28 IF $DATA(^TMP("LRAR-WL",$JOB,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,LRCAPNAM))#2
- SET LRX=^(LRCAPNAM)
- SET LRX1=LRUC+$PIECE(LRX,"^")
- SET LRX2=LRWC+$PIECE(LRX,"^",2)
- SET ^(LRCAPNAM)=LRX1_"^"_LRX2_"^"_LRUW_"^"_LRCAPNUM
- +29 IF '$TEST
- SET ^TMP("LRAR-WL",$JOB,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,LRCAPNAM)=LRUC_"^"_LRWC_"^"_LRUW_"^"_LRCAPNUM
- +30 IF LRLDIV="AP"
- SET LRAPIGT=LRAPIGT+LRWC
- SET LRAPIGTU=LRAPIGTU+LRUC
- +31 IF '$TEST
- SET LRCPIGT=LRCPIGT+LRWC
- SET LRCPIGTU=LRCPIGTU+LRUC
- +32 IF $DATA(^TMP("LRAR-WL",$JOB,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,0))#2
- SET LRX1=+$PIECE(^(0),"^")+LRWC
- SET LRX2=+$PIECE(^(0),"^",2)+LRUC
- SET ^(0)=LRX1_"^"_LRX2
- +33 IF '$TEST
- SET ^TMP("LRAR-WL",$JOB,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,0)=LRWC_"^"_LRUC
- +34 IF $DATA(^TMP("LRAR-WL",$JOB,"AA",LRMAA,LRLSSA,0))#2
- SET LRX1=+$PIECE(^(0),"^")+LRWC
- SET LRX2=+$PIECE(^(0),"^",2)+LRUC
- SET ^(0)=LRX1_"^"_LRX2
- +35 IF '$TEST
- SET ^TMP("LRAR-WL",$JOB,"AA",LRMAA,LRLSSA,0)=LRWC_"^"_LRUC
- +36 QUIT
- GTIN ;
- +1 if LRGETIN
- SET LRIN=+$ORDER(^LAR(64.19999,LRIN))
- +2 if LRIN
- SET LRINN=$SELECT($DATA(^LAR(64.19999,LRIN,0)):^(0),1:"UNDEFINED")
- +3 SET LRGETIN=1
- +4 QUIT
- GETA ;Get pointer value for file 68
- +1 KILL DIC
- SET DIC=68
- SET DIC(0)="XMZ"
- +2 DO ^DIC
- if Y=-1
- QUIT
- +3 QUIT