- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRCAPMA1 3771 printed Feb 18, 2025@23:38:53 Page 2
- LRCAPMA1 ;SLC/AM/DALISC/FHS/J0 - WKLD REPORT BY MAJ SCTN; 2/6/91
- +1 ;;5.2;LAB SERVICE;**105,119**;Sep 27, 1994
- EN ;
- +1 DO INITMAN^LRCAPMR1
- +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 DO GENCOM^LRCAPMR1
- DO CAPCOM^LRCAPMR1
- +4 SET (LRAPICGT,LRAPIIGT,LRAPIOGT,LRAPINGT)=0
- +5 SET (LRCPICGT,LRCPIIGT,LRCPIOGT,LRCPINGT)=0
- +6 SET LRCDT=LRCDTB-1
- +7 FOR
- SET LRCDT=$ORDER(^LRO(64.1,LRIN,1,LRCDT))
- if (LRCDT>LRCDTE)!(LRCDT<1)
- QUIT
- Begin DoDot:1
- +8 DO DATCOM^LRCAPMR1
- +9 if $EXTRACT(IOST,1,2)="C-"
- WRITE "."
- +10 SET LRCC=0
- +11 FOR
- SET LRCC=$ORDER(^LRO(64.1,LRIN,1,LRCDT,1,LRCC))
- if (LRCC<1)
- QUIT
- DO CC
- End DoDot:1
- +12 SET LRGTOTS=$GET(^TMP("LR-WL",$JOB,0))
- +13 SET $PIECE(LRGTOTS,U)=$PIECE(LRGTOTS,U)+LRAPICGT+LRCPICGT
- +14 SET $PIECE(LRGTOTS,U,2)=$PIECE(LRGTOTS,U,2)+LRAPIIGT+LRCPIIGT
- +15 SET $PIECE(LRGTOTS,U,3)=$PIECE(LRGTOTS,U,3)+LRAPIOGT+LRCPIOGT
- +16 SET $PIECE(LRGTOTS,U,4)=$PIECE(LRGTOTS,U,4)+LRAPINGT+LRCPINGT
- +17 SET ^TMP("LR-WL",$JOB,0)=LRGTOTS
- +18 SET LRGTOTS=$GET(^TMP("LR-WL",$JOB,"DIV","AP",LRIN,0))
- +19 SET $PIECE(LRGTOTS,U)=$PIECE(LRGTOTS,U)+LRAPICGT
- +20 SET $PIECE(LRGTOTS,U,2)=$PIECE(LRGTOTS,U,2)+LRAPIIGT
- +21 SET $PIECE(LRGTOTS,U,3)=$PIECE(LRGTOTS,U,3)+LRAPIOGT
- +22 SET $PIECE(LRGTOTS,U,4)=$PIECE(LRGTOTS,U,4)+LRAPINGT
- +23 SET ^TMP("LR-WL",$JOB,"DIV","AP",LRIN,0)=LRGTOTS
- +24 SET LRGTOTS=$GET(^TMP("LR-WL",$JOB,"DIV","CP",LRIN,0))
- +25 SET $PIECE(LRGTOTS,U)=$PIECE(LRGTOTS,U)+LRCPICGT
- +26 SET $PIECE(LRGTOTS,U,2)=$PIECE(LRGTOTS,U,2)+LRCPIIGT
- +27 SET $PIECE(LRGTOTS,U,3)=$PIECE(LRGTOTS,U,3)+LRCPIOGT
- +28 SET $PIECE(LRGTOTS,U,4)=$PIECE(LRGTOTS,U,4)+LRCPINGT
- +29 SET ^TMP("LR-WL",$JOB,"DIV","CP",LRIN,0)=LRGTOTS
- +30 QUIT
- CC ;
- +1 SET LRCAPNAM=$$WKLDNAME^LRCAPU(LRCC)
- +2 DO BMPMANL^LRCAPMR1
- +3 SET LRCTM=$SELECT(LRCTMB=0:"",1:LRCTMB-.001)
- +4 FOR
- SET LRCTM=$ORDER(^LRO(64.1,LRIN,1,LRCDT,1,LRCC,1,LRCTM))
- if (LRCTM>LRCTME)!(LRCTM="")
- QUIT
- DO TM
- +5 QUIT
- TM ;
- +1 if '($DATA(^LRO(64.1,LRIN,1,LRCDT,1,LRCC,1,LRCTM,0))#2)
- QUIT
- +2 SET LRX=^(0)
- +3 SET LRMA=+$PIECE(LRX,U,7)
- +4 IF LRAA
- if '$DATA(LRAA(LRMA))
- QUIT
- +5 SET LRUC=+$PIECE(LRX,U,3)
- SET LRLDIV=$PIECE(LRX,U,6)
- SET LRLSS=$PIECE(LRX,U,8)
- if LRLDIV=""
- SET LRLDIV="CP"
- +6 if 'LRUC
- SET LRUC=1
- +7 SET LRTYP=$$CHKTYP(LRX)
- if 'LRTYP
- QUIT
- +8 IF +LRMA
- Begin DoDot:1
- +9 SET LRREC=$GET(^LRO(68,LRMA,0))
- +10 SET LRMAA=$SELECT($PIECE(LRREC,U,11)]"":$PIECE(LRREC,U,11),1:LRNDFN)
- +11 SET LRMAN=$SELECT($PIECE(LRREC,U)]"":$PIECE(LRREC,U),1:LRNDFN)
- +12 SET LRMAN(LRMAA)=LRMAN
- End DoDot:1
- +13 IF '+LRMA
- SET (LRMAA,LRMAN)=LRNDFN
- SET LRMAN(LRMAA)=LRMAN
- +14 IF +LRLSS
- Begin DoDot:1
- +15 SET LRREC=$GET(^LRO(68,LRLSS,0))
- +16 SET LRLSSA=$SELECT($PIECE(LRREC,U,11)]"":$PIECE(LRREC,U,11),1:LRNDFN)
- +17 SET LRLSSN=$SELECT($PIECE(LRREC,U)]"":$PIECE(LRREC,U),1:LRNDFN)
- +18 SET LRLSSN(LRLSSA)=LRLSSN
- End DoDot:1
- +19 IF '+LRLSS
- SET (LRLSSA,LRLSSN)=LRNDFN
- SET LRLSSN(LRLSSA)=LRLSSN
- +20 IF $DATA(^TMP("LR-WL",$JOB,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,LRCAPNAM))#2
- Begin DoDot:1
- +21 SET $PIECE(^(LRCAPNAM),U,LRTYP)=$PIECE(^TMP("LR-WL",$JOB,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,LRCAPNAM),U,LRTYP)+LRUC
- End DoDot:1
- +22 IF '$TEST
- Begin DoDot:1
- +23 SET $PIECE(^TMP("LR-WL",$JOB,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,LRCAPNAM),U,LRTYP)=LRUC
- +24 SET $PIECE(^TMP("LR-WL",$JOB,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,LRCAPNAM),U,5)=LRCAPNUM
- End DoDot:1
- +25 IF LRLDIV="AP"
- Begin DoDot:1
- +26 SET LRGT=$SELECT(LRTYP=1:"LRAPICGT",LRTYP=2:"LRAPIIGT",LRTYP=3:"LRAPIOGT",1:"LRAPINGT")
- +27 SET @LRGT=@LRGT+LRUC
- End DoDot:1
- +28 IF '$TEST
- Begin DoDot:1
- +29 SET LRGT=$SELECT(LRTYP=1:"LRCPICGT",LRTYP=2:"LRCPIIGT",LRTYP=3:"LRCPIOGT",1:"LRCPINGT")
- +30 SET @LRGT=@LRGT+LRUC
- End DoDot:1
- +31 IF $DATA(^TMP("LR-WL",$JOB,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,0))#2
- Begin DoDot:1
- +32 SET $PIECE(^(0),U,LRTYP)=$PIECE(^TMP("LR-WL",$JOB,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,0),U,LRTYP)+LRUC
- End DoDot:1
- +33 IF '$TEST
- Begin DoDot:1
- +34 SET $PIECE(^TMP("LR-WL",$JOB,"DIV",LRLDIV,LRIN,LRMAA,LRLSSA,0),U,LRTYP)=LRUC
- End DoDot:1
- +35 IF $DATA(^TMP("LR-WL",$JOB,"AA",LRMAA,LRLSSA,0))#2
- Begin DoDot:1
- +36 SET $PIECE(^(0),U,LRTYP)=$PIECE(^TMP("LR-WL",$JOB,"AA",LRMAA,LRLSSA,0),U,LRTYP)+LRUC
- End DoDot:1
- +37 IF '$TEST
- Begin DoDot:1
- +38 SET $PIECE(^TMP("LR-WL",$JOB,"AA",LRMAA,LRLSSA,0),U,LRTYP)=LRUC
- End DoDot:1
- +39 QUIT
- GTIN ;
- +1 if LRGETIN
- SET LRIN=+$ORDER(^LRO(64.1,LRIN))
- +2 if LRIN
- SET LRINN=$SELECT($DATA(^DIC(4,LRIN,0))#2:$PIECE(^DIC(4,LRIN,0),U),1:LRNDFN)
- +3 SET LRGETIN=1
- +4 QUIT
- CHKTYP(LRREC) ;
- +1 NEW LRFIL,LRLTYP
- +2 SET LRFIL=$PIECE(LRREC,U,10)
- SET LRFIL=$PIECE(LRFIL,";",2)
- +3 SET LRLTYP=$PIECE(LRREC,U,19)
- +4 if LRFIL=""
- SET LRFIL=" "
- if LRLTYP=""
- SET LRLTYP=" "
- +5 if LRFIL="LAB(62.3,"
- QUIT 1
- +6 if ((LRFIL="DPT(")&("ORW"[LRLTYP))
- QUIT 2
- +7 if LRFIL="DPT("
- QUIT 3
- +8 QUIT 4