- 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
