LRARCAM5 ; IHS/DIR/AAB - ARCHIVED RCS 14-4 REPORT PART 1 ;
;;5.2;LR;**1002**;JUN 01, 1998
;;5.2;LAB SERVICE;**59**;August 31,1995
;same as LRCAPAM5 except for archived wkld file reference
EN ;
DEVICE ;
S %ZIS="Q" D ^%ZIS G:POP EXIT I $D(IO("Q")) G ZTLOAD
D WAIT^DICD
QUE ;
U IO K ^TMP($J,"RCS14-4"),^TMP($J,"LMIP")
S (LRERR,LRMT)="" S:$D(ZTQUEUED) ZTREQ="@"
F S LRMT=$O(LRRPTM(LRMT)) Q:LRMT="" S LRTSTOT=0,LRCAP="" D
.D INITSUM^LRARCAM7
.S:'$D(^TMP($J,"RCS14-4",$P(LRMT,U,2),0)) ^(0)=0 S LRTOT1=^(0)
.F S LRCAP=$O(^LAR(67.99999,+LRDA(1),1,+LRDA,1,+LRMT,1,"B",LRCAP)) Q:LRCAP="" D
..S LRCAPN=$O(^LAR(67.99999,+LRDA(1),1,+LRDA,1,+LRMT,1,"B",LRCAP,0))
..I $D(^LAR(67.99999,+LRDA(1),1,+LRDA,1,+LRMT,1,LRCAPN,0))#2 S LRTREAT=0 D S ^TMP($J,"RCS14-4",$P(LRMT,U,2),0)=LRTOT1
...S LRN=$G(^LAR(67.99999,+LRDA(1),1,+LRDA,1,+LRMT,1,LRCAPN,0)),LRN2=+$G(^(2))
...I '$O(^LAR(67.99999,+LRDA(1),1,+LRDA,1,+LRMT,1,LRCAPN,1,0)) S LRCAPIFN=+$O(^LAM("C",$P(LRN,U)_" ",0)) D:LRCAPIFN BMPSUM^LRARCAM7 Q
..S LRCC=$P(LRN,U) S LRCCN=$E($$WKLDNAME^LRARCU(LRCC),1,40)
..S:LRCCN["*ERR" LRERR=LRERR+1
..Q:((LRDTYP=2)&('LRN2))!((LRDTYP=3)&(LRN2))
..D BMPSUM^LRARCAM7
..S:'$D(^TMP($J,"RCS14-4",$P(LRMT,U,2),1,LRCCN,0))#2 ^(0)=$P(LRN,U,1,8)_U_$P(LRN,U,12) F I=2,3,4 S N=$P(LRN,U,I) I N S $P(LRTOT1,U,I)=($P(LRTOT1,U,I)+N)
..S LRTREAT="" F S LRTREAT=$O(^LAR(67.99999,+LRDA(1),1,+LRDA,1,+LRMT,1,LRCAPN,1,"B",LRTREAT)) Q:LRTREAT="" D
...S LRTREATN=$O(^LAR(67.99999,+LRDA(1),1,+LRDA,1,+LRMT,1,LRCAPN,1,"B",LRTREAT,0)),LRN1=^LAR(67.99999,+LRDA(1),1,+LRDA,1,+LRMT,1,LRCAPN,1,LRTREATN,0) D T1
D ^LRARCAM6
EXIT ;
D ^%ZISC
D KILLALL^LRARCU
K ^TMP($J,"RCS14-4"),^TMP($J,"LMIP"),LRERR
Q
T1 ;
D LKUP S:'$D(^TMP($J,"RCS14-4",$P(LRMT,U,2),1,LRCCN,LRTRN)) ^(LRTRN)=0 S ^(LRTRN)=(^(LRTRN)+$P(LRN1,U,2))
S:'$D(^TMP($J,"RCS14-4",$P(LRMT,U,2),LRTRN)) ^(LRTRN)=0 S ^(LRTRN)=(^(LRTRN)+$P(LRN1,U,2))
S LRTSTOT=LRTSTOT+$P(LRN1,U,2)
Q
LKUP ;
S NODE=$G(^DIC(42.4,+LRN1,0)),LRCDR=$S($P(NODE,U,6):$P(NODE,U,6),$P(LRN1,U)="XY ":2100,1:2000)
S LRTRN="[ "_LRCDR_" ] "_$S($L($P(NODE,U)):$P(NODE,U),LRCDR=2100:"BLOOD BANK",1:"AMBULATORY CARE")
S LRSV=$S($L($P(NODE,U,3)):$P(NODE,U,3),1:LRTRN)
I $L(LRSV)<4 S LRSV=$S(LRSV="M":"MEDICINE",LRSV="S":"SURGERY",LRSV="P":"PSYCHIATRY",LRSV="NH":"NHCU",LRSV="NE":"NEUROLOGY",LRSV="I":"INTERMEDIATE MED",LRSV="R":"REHAB MEDICINE",1:LRSV)
I $L(LRSV)<4 S LRSB=$S(LRSV="SCI":"SPINAL CORD INJURY",LRSV="D":"DOMICILIARY",LRSV="B":"BLIND REHAB",1:"RESPITE CARE")
S LRBS=$S($L($P(NODE,U,5)):$P(NODE,U,5),1:LRTRN)
S:'$D(^TMP($J,"RCS14-4",$P(LRMT,U,2),3))#2 ^(3)=0 S ^(3)=(^(3)+$P(LRN1,U,2))
S:'$D(^TMP($J,"RCS14-4",$P(LRMT,U,2),3,LRSV)) ^(LRSV)=0 S ^(LRSV)=(^(LRSV)+$P(LRN1,U,2))
S:'$D(^TMP($J,"RCS14-4",$P(LRMT,U,2),5))#2 ^(5)=0 S ^(5)=(^(5)+$P(LRN1,U,2))
S:'$D(^TMP($J,"RCS14-4",$P(LRMT,U,2),5,LRBS)) ^(LRBS)=0 S ^(LRBS)=(^(LRBS)+$P(LRN1,U,2))
Q
ZTLOAD ;
S ZTIO=ION,ZTRTN="QUE^LRARCAM5",ZTDESC="ARCHIVED LR RCS/CDR REPORT"
S ZTSAVE("LR*")="",ZTSAVE("LRDA*")=""
D ^%ZTLOAD K ZTSK G EXIT
LRARCAM5 ; IHS/DIR/AAB - ARCHIVED RCS 14-4 REPORT PART 1 ;
+1 ;;5.2;LR;**1002**;JUN 01, 1998
+2 ;;5.2;LAB SERVICE;**59**;August 31,1995
+3 ;same as LRCAPAM5 except for archived wkld file reference
EN ;
DEVICE ;
+1 SET %ZIS="Q"
DO ^%ZIS
IF POP
GOTO EXIT
IF $DATA(IO("Q"))
GOTO ZTLOAD
+2 DO WAIT^DICD
QUE ;
+1 USE IO
KILL ^TMP($JOB,"RCS14-4"),^TMP($JOB,"LMIP")
+2 SET (LRERR,LRMT)=""
IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+3 FOR
SET LRMT=$ORDER(LRRPTM(LRMT))
IF LRMT=""
QUIT
SET LRTSTOT=0
SET LRCAP=""
Begin DoDot:1
+4 DO INITSUM^LRARCAM7
+5 IF '$DATA(^TMP($JOB,"RCS14-4",$PIECE(LRMT,U,2),0))
SET ^(0)=0
SET LRTOT1=^(0)
+6 FOR
SET LRCAP=$ORDER(^LAR(67.99999,+LRDA(1),1,+LRDA,1,+LRMT,1,"B",LRCAP))
IF LRCAP=""
QUIT
Begin DoDot:2
+7 SET LRCAPN=$ORDER(^LAR(67.99999,+LRDA(1),1,+LRDA,1,+LRMT,1,"B",LRCAP,0))
+8 IF $DATA(^LAR(67.99999,+LRDA(1),1,+LRDA,1,+LRMT,1,LRCAPN,0))#2
SET LRTREAT=0
Begin DoDot:3
+9 SET LRN=$GET(^LAR(67.99999,+LRDA(1),1,+LRDA,1,+LRMT,1,LRCAPN,0))
SET LRN2=+$GET(^(2))
+10 IF '$ORDER(^LAR(67.99999,+LRDA(1),1,+LRDA,1,+LRMT,1,LRCAPN,1,0))
SET LRCAPIFN=+$ORDER(^LAM("C",$PIECE(LRN,U)_" ",0))
IF LRCAPIFN
DO BMPSUM^LRARCAM7
QUIT
End DoDot:3
SET ^TMP($JOB,"RCS14-4",$PIECE(LRMT,U,2),0)=LRTOT1
+11 SET LRCC=$PIECE(LRN,U)
SET LRCCN=$EXTRACT($$WKLDNAME^LRARCU(LRCC),1,40)
+12 IF LRCCN["*ERR"
SET LRERR=LRERR+1
+13 IF ((LRDTYP=2)&('LRN2))!((LRDTYP=3)&(LRN2))
QUIT
+14 DO BMPSUM^LRARCAM7
+15 IF '$DATA(^TMP($JOB,"RCS14-4",$PIECE(LRMT,U,2),1,LRCCN,0))#2
SET ^(0)=$PIECE(LRN,U,1,8)_U_$PIECE(LRN,U,12)
FOR I=2,3,4
SET N=$PIECE(LRN,U,I)
IF N
SET $PIECE(LRTOT1,U,I)=($PIECE(LRTOT1,U,I)+N)
+16 SET LRTREAT=""
FOR
SET LRTREAT=$ORDER(^LAR(67.99999,+LRDA(1),1,+LRDA,1,+LRMT,1,LRCAPN,1,"B",LRTREAT))
IF LRTREAT=""
QUIT
Begin DoDot:3
+17 SET LRTREATN=$ORDER(^LAR(67.99999,+LRDA(1),1,+LRDA,1,+LRMT,1,LRCAPN,1,"B",LRTREAT,0))
SET LRN1=^LAR(67.99999,+LRDA(1),1,+LRDA,1,+LRMT,1,LRCAPN,1,LRTREATN,0)
DO T1
End DoDot:3
End DoDot:2
End DoDot:1
+18 DO ^LRARCAM6
EXIT ;
+1 DO ^%ZISC
+2 DO KILLALL^LRARCU
+3 KILL ^TMP($JOB,"RCS14-4"),^TMP($JOB,"LMIP"),LRERR
+4 QUIT
T1 ;
+1 DO LKUP
IF '$DATA(^TMP($JOB,"RCS14-4",$PIECE(LRMT,U,2),1,LRCCN,LRTRN))
SET ^(LRTRN)=0
SET ^(LRTRN)=(^(LRTRN)+$PIECE(LRN1,U,2))
+2 IF '$DATA(^TMP($JOB,"RCS14-4",$PIECE(LRMT,U,2),LRTRN))
SET ^(LRTRN)=0
SET ^(LRTRN)=(^(LRTRN)+$PIECE(LRN1,U,2))
+3 SET LRTSTOT=LRTSTOT+$PIECE(LRN1,U,2)
+4 QUIT
LKUP ;
+1 SET NODE=$GET(^DIC(42.4,+LRN1,0))
SET LRCDR=$SELECT($PIECE(NODE,U,6):$PIECE(NODE,U,6),$PIECE(LRN1,U)="XY ":2100,1:2000)
+2 SET LRTRN="[ "_LRCDR_" ] "_$SELECT($LENGTH($PIECE(NODE,U)):$PIECE(NODE,U),LRCDR=2100:"BLOOD BANK",1:"AMBULATORY CARE")
+3 SET LRSV=$SELECT($LENGTH($PIECE(NODE,U,3)):$PIECE(NODE,U,3),1:LRTRN)
+4 IF $LENGTH(LRSV)<4
SET LRSV=$SELECT(LRSV="M":"MEDICINE",LRSV="S":"SURGERY",LRSV="P":"PSYCHIATRY",LRSV="NH":"NHCU",LRSV="NE":"NEUROLOGY",LRSV="I":"INTERMEDIATE MED",LRSV="R":"REHAB MEDICINE",1:LRSV)
+5 IF $LENGTH(LRSV)<4
SET LRSB=$SELECT(LRSV="SCI":"SPINAL CORD INJURY",LRSV="D":"DOMICILIARY",LRSV="B":"BLIND REHAB",1:"RESPITE CARE")
+6 SET LRBS=$SELECT($LENGTH($PIECE(NODE,U,5)):$PIECE(NODE,U,5),1:LRTRN)
+7 IF '$DATA(^TMP($JOB,"RCS14-4",$PIECE(LRMT,U,2),3))#2
SET ^(3)=0
SET ^(3)=(^(3)+$PIECE(LRN1,U,2))
+8 IF '$DATA(^TMP($JOB,"RCS14-4",$PIECE(LRMT,U,2),3,LRSV))
SET ^(LRSV)=0
SET ^(LRSV)=(^(LRSV)+$PIECE(LRN1,U,2))
+9 IF '$DATA(^TMP($JOB,"RCS14-4",$PIECE(LRMT,U,2),5))#2
SET ^(5)=0
SET ^(5)=(^(5)+$PIECE(LRN1,U,2))
+10 IF '$DATA(^TMP($JOB,"RCS14-4",$PIECE(LRMT,U,2),5,LRBS))
SET ^(LRBS)=0
SET ^(LRBS)=(^(LRBS)+$PIECE(LRN1,U,2))
+11 QUIT
ZTLOAD ;
+1 SET ZTIO=ION
SET ZTRTN="QUE^LRARCAM5"
SET ZTDESC="ARCHIVED LR RCS/CDR REPORT"
+2 SET ZTSAVE("LR*")=""
SET ZTSAVE("LRDA*")=""
+3 DO ^%ZTLOAD
KILL ZTSK
GOTO EXIT
