LRCAPAM1 ;SLC/FHS - MOVE WKLD DATA FROM 64.1 TO 67.9;10/14/91 08:15
;;5.2;LAB SERVICE;**105,119,201**;Sep 27, 1994
EN ;
K DINUM D ^LRCAPAM0 G:$G(LREND) END
I $D(XRTN) S XRTN="LRCAPAM1" D T0^%ZOSV ;START TIMING RESPONSE
;S ^TMP("LRCAPAM1 RUN TIME")=$$NOW^XLFDT
S:'$D(^LRO(67.9,0))#2 ^(0)="LAB MONTHLY WORKLOADS^67.9P^"
I '$D(^LRO(67.9,LRPRI,0))#2 K DO,DIC,DR,DA S DIC(0)="LNM",DLAYGO=67,(X,DINUM,DA)=LRPRI,DIC="^LRO(67.9,",DA(1)=67.9 D FILE^DICN
EN1 ;
K DINUM D:'$D(^LRO(67.9,LRPRI,1,LRIN,0))#2 NEWIN D
.F LRDAT=LRDTS:0 S LRDAT=+$O(^LRO(64.1,LRIN,1,LRDAT)) Q:LRDAT<1!(LRDAT>LRDTE) I $D(^(LRDAT,0))#2 S LRCHK=$P($G(^(0)),U,2) D S $P(^LRO(64.1,LRIN,1,LRDAT,0),U,2)=1
..I LRCHK W !!?10,$$FMTE^XLFDT(LRDAT)," Compiled previously "
..W !,"Scanning >>> ",$$FMTE^XLFDT(LRDAT) S LRRDT=$E(LRDAT,1,5)
..K DIC,DA,DR,DINUM
..S DLAYGO=67,X=LRRDT_"00",DIC="^LRO(67.9,"_LRPRI_",1,"_LRIN_",1,",DIC(0)="L",DA(1)=LRIN,DA(2)=LRPRI D ^DIC S NX=+Y
..S $P(^LRO(67.9,LRPRI,1,LRIN,1,NX,0),U,3)=$$NOW^XLFDT
..S:'$D(^LRO(67.9,LRPRI,1,LRIN,1,NX,1,0))#2 ^(0)="^67.9114A^"
..S LRCAP=0 D
...F S LRCAP=+$O(^LRO(64.1,LRIN,1,LRDAT,1,LRCAP)) Q:'LRCAP D
....S LRTM=0,LRCAPN=$G(^LAM(LRCAP,0)) Q:'$L($P(LRCAPN,U,2)) S LRCAPNA=$P(LRCAPN,U),LRLMIP=$P(LRCAPN,U,5),LRACT=$P(LRCAPN,U,17),LRCAPN=$P(LRCAPN,U,2)
....I 'LRACT S $P(^LAM(LRCAP,0),U,17)=1,^LAM("AC",1,LRCAP)=""
....K DIC,DA,DR,DINUM
....S (DA,X)=LRCAPN,DIC="^LRO(67.9,LRPRI,1,LRIN,1,NX,1,"
....S DA(1)=NX,DA(2)=LRIN,DA(3)=LRPRI,DLAYGO=67.9,DIC(0)="L" D ^DIC K DLAYGO S NX2=+Y
....I Y<1 W !!?10,"Error Processing WKLD "_LRCAPNA,!?5,LRCAPN,!! Q
....I $P(Y,U,3) S ^LRO(67.9,LRPRI,1,LRIN,1,NX,1,NX2,0)=LRCAPN_"^^^^^^^^"_LRCAPNA_"^^^" S:$G(LRLMIP) ^(2)=1
....S LRTM=0,NODE0=^LRO(67.9,LRPRI,1,LRIN,1,NX,1,NX2,0) F S LRTM=+$O(^LRO(64.1,LRIN,1,LRDAT,1,LRCAP,1,LRTM)) Q:'$D(^(LRTM,0))#2 Q:$P(^(0),U,20) S NODE=^(0) D S $P(^LRO(64.1,LRIN,1,LRDAT,1,LRCAP,1,LRTM,0),U,20)=1
.....S LRFILE=$P($P(NODE,U,10),";",2) S:'$L(LRFILE) LRFILE=" "
.....S (INP,OUTP,OTHP)=0,LTYPE=$P(NODE,U,19),PTYPE=$P(NODE,U,10),TREAT=$P(NODE,U,17),TREAT=$S($P($G(^DIC(45.7,+TREAT,0)),U,2):$P(^(0),U,2),1:"XX ")
.....S:LRFILE="LRE("!(LRFILE="LRD(65,") TREAT="XY "
.....S:$L(TREAT)=2 TREAT="0"_TREAT I $L(TREAT)=1 S TREAT="00"_TREAT
.....S LRMULT=$S($P(NODE,U,3):$P(NODE,U,3),1:1)
.....S:LTYPE="" LTYPE="Z" S PN=$S(("WOR"[LTYPE&(LRFILE="DPT(")):2,("CMZNFI"[LTYPE&(LRFILE="DPT(")):3,LRFILE="LRT(67,":4,LRFILE="LRE(":4,LRFILE="LAB(62.3,":5,LRFILE="LRD(65,":4,1:12)
.....S $P(NODE0,U,PN)=$P(NODE0,U,PN)+LRMULT,LRURG=+$P(NODE,U,23) I LRURG,$S(LRURG<3:1,(LRURG>50&(LRURG<53)):1,1:0) S $P(NODE0,U,7)=$P(NODE0,U,7)+LRMULT I PN=2 S $P(NODE0,U,6)=$P(NODE0,U,6)+LRMULT
.....S ^LRO(67.9,LRPRI,1,LRIN,1,NX,1,NX2,0)=NODE0
.....S LRSO=$P(+NODE0,".",2),LRSOCNT=0 I $E(LRSO)=8 F PN=2:1:4,8,12 S LRSOCNT=LRSOCNT+$P(NODE0,U,PN)
.....I $G(LRSOCNT) S LRSOCNT=LRSOCNT*LRMULT,$P(NODE0,U,10)=LRSOCNT,^LRO(67.9,LRPRI,1,LRIN,1,NX,1,NX2,0)=NODE0 K LRSOCNT
.....S:'$D(^LRO(67.9,LRPRI,1,LRIN,1,NX,1,NX2,1,0)) ^(0)="^67.91148A^"
.....S NX3=$O(^LRO(67.9,LRPRI,1,LRIN,1,NX,1,NX2,1,"B",TREAT,0)) I 'NX3 S NODE2=^LRO(67.9,LRPRI,1,LRIN,1,NX,1,NX2,1,0),NX3=$P(NODE2,U,3)+1,$P(NODE2,U,3)=NX3,$P(NODE2,U,4)=$P(NODE2,U,4)+1,^(0)=NODE2
.....S:'$D(^LRO(67.9,LRPRI,1,LRIN,1,NX,1,NX2,1,"B",TREAT,NX3)) ^(NX3)=""
.....S LRTREATN=$S($D(^DIC(42.4,+TREAT,0)):$P(^(0),U),1:"")
.....I '$L(LRTREATN) S LRTREATN=$S(TREAT="XY ":"BLOOD BANK",1:"AMBULATORY CARE")
.....S:'$D(^LRO(67.9,LRPRI,1,LRIN,1,NX,1,NX2,1,NX3,0))#2 ^(0)=TREAT_"^^"_LRTREATN K LRTREATN
.....S NODE3=^(0),$P(NODE3,U,2)=($P(NODE3,U,2)+LRMULT),^(0)=NODE3
....I $D(^LRO(64.1,LRIN,1,LRDAT,1,LRCAP,"S")) S NODES=^("S") D
.....F P=1:1:4 S NODESX=+$P(NODES,U,P) I NODESX S PSN=$S(P=1:11,P=2:5,P=3:11,1:8),$P(NODE0,U,PSN)=($P(NODE0,U,PSN)+NODESX)
.....S ^LRO(67.9,LRPRI,1,LRIN,1,NX,1,NX2,0)=NODE0
W !!?10,"FINISHED",!! D CLEAR
Q
NEWIN ;Add new division
S:'$D(^LRO(67.9,LRPRI,1,0))#2 ^(0)="^67.901PA"
K DD,DIC,DO S DINUM=LRIN,DIC(0)="LNM",DLAYGO=67,DIC="^LRO(67.9,LRPRI,1,",DA(1)=LRPRI,(DA,X)=LRIN D FILE^DICN
S ^LRO(67.9,LRPRI,1,LRIN,1,0)="^67.911D^" K DINUM
Q
END ;
S LREND=1
CLEAR ;
L -^LRO(67.9)
I $D(XRTN) S XRTN="CLEAR^LRCAPAM1" D T1^%ZOSV ;STOP TIMING
;S $P(^TMP("LRCAPEX RUN TIME"),U,2)=$$NOW^XLFDT
D ^%ZISC
K %DT,DA,DIC,DINUM,DLAYGO,DIE,DR,LRDAT,INP,LINE,LRCAP,LRCAPN,LRCAPNA,LRCHK,LRDTS,LRIN,LRPRI,LRPRIN
K LRRDT,LRTN,LRLMIP,LRTM,LRURG,LTYPE,NODE,NODE0,NODE2,NODE3,NODES,NODESX,NODEX,NX,NX2
K NX3,OTHP,OUTP,P,PN,PSN,PTYPE,TREAT,Y,ZTSK,IO("Q")
K LRACT,LRDTE,LREND,LRFILE,LRMULT,LRSO,LRSOCNT,X
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRCAPAM1 4627 printed Dec 13, 2024@02:12:36 Page 2
LRCAPAM1 ;SLC/FHS - MOVE WKLD DATA FROM 64.1 TO 67.9;10/14/91 08:15
+1 ;;5.2;LAB SERVICE;**105,119,201**;Sep 27, 1994
EN ;
+1 KILL DINUM
DO ^LRCAPAM0
if $GET(LREND)
GOTO END
+2 ;START TIMING RESPONSE
IF $DATA(XRTN)
SET XRTN="LRCAPAM1"
DO T0^%ZOSV
+3 ;S ^TMP("LRCAPAM1 RUN TIME")=$$NOW^XLFDT
+4 if '$DATA(^LRO(67.9,0))#2
SET ^(0)="LAB MONTHLY WORKLOADS^67.9P^"
+5 IF '$DATA(^LRO(67.9,LRPRI,0))#2
KILL DO,DIC,DR,DA
SET DIC(0)="LNM"
SET DLAYGO=67
SET (X,DINUM,DA)=LRPRI
SET DIC="^LRO(67.9,"
SET DA(1)=67.9
DO FILE^DICN
EN1 ;
+1 KILL DINUM
if '$DATA(^LRO(67.9,LRPRI,1,LRIN,0))#2
DO NEWIN
Begin DoDot:1
+2 FOR LRDAT=LRDTS:0
SET LRDAT=+$ORDER(^LRO(64.1,LRIN,1,LRDAT))
if LRDAT<1!(LRDAT>LRDTE)
QUIT
IF $DATA(^(LRDAT,0))#2
SET LRCHK=$PIECE($GET(^(0)),U,2)
Begin DoDot:2
+3 IF LRCHK
WRITE !!?10,$$FMTE^XLFDT(LRDAT)," Compiled previously "
+4 WRITE !,"Scanning >>> ",$$FMTE^XLFDT(LRDAT)
SET LRRDT=$EXTRACT(LRDAT,1,5)
+5 KILL DIC,DA,DR,DINUM
+6 SET DLAYGO=67
SET X=LRRDT_"00"
SET DIC="^LRO(67.9,"_LRPRI_",1,"_LRIN_",1,"
SET DIC(0)="L"
SET DA(1)=LRIN
SET DA(2)=LRPRI
DO ^DIC
SET NX=+Y
+7 SET $PIECE(^LRO(67.9,LRPRI,1,LRIN,1,NX,0),U,3)=$$NOW^XLFDT
+8 if '$DATA(^LRO(67.9,LRPRI,1,LRIN,1,NX,1,0))#2
SET ^(0)="^67.9114A^"
+9 SET LRCAP=0
Begin DoDot:3
+10 FOR
SET LRCAP=+$ORDER(^LRO(64.1,LRIN,1,LRDAT,1,LRCAP))
if 'LRCAP
QUIT
Begin DoDot:4
+11 SET LRTM=0
SET LRCAPN=$GET(^LAM(LRCAP,0))
if '$LENGTH($PIECE(LRCAPN,U,2))
QUIT
SET LRCAPNA=$PIECE(LRCAPN,U)
SET LRLMIP=$PIECE(LRCAPN,U,5)
SET LRACT=$PIECE(LRCAPN,U,17)
SET LRCAPN=$PIECE(LRCAPN,U,2)
+12 IF 'LRACT
SET $PIECE(^LAM(LRCAP,0),U,17)=1
SET ^LAM("AC",1,LRCAP)=""
+13 KILL DIC,DA,DR,DINUM
+14 SET (DA,X)=LRCAPN
SET DIC="^LRO(67.9,LRPRI,1,LRIN,1,NX,1,"
+15 SET DA(1)=NX
SET DA(2)=LRIN
SET DA(3)=LRPRI
SET DLAYGO=67.9
SET DIC(0)="L"
DO ^DIC
KILL DLAYGO
SET NX2=+Y
+16 IF Y<1
WRITE !!?10,"Error Processing WKLD "_LRCAPNA,!?5,LRCAPN,!!
QUIT
+17 IF $PIECE(Y,U,3)
SET ^LRO(67.9,LRPRI,1,LRIN,1,NX,1,NX2,0)=LRCAPN_"^^^^^^^^"_LRCAPNA_"^^^"
if $GET(LRLMIP)
SET ^(2)=1
+18 SET LRTM=0
SET NODE0=^LRO(67.9,LRPRI,1,LRIN,1,NX,1,NX2,0)
FOR
SET LRTM=+$ORDER(^LRO(64.1,LRIN,1,LRDAT,1,LRCAP,1,LRTM))
if '$DATA(^(LRTM,0))#2
QUIT
if $PIECE(^(0),U,20)
QUIT
SET NODE=^(0)
Begin DoDot:5
+19 SET LRFILE=$PIECE($PIECE(NODE,U,10),";",2)
if '$LENGTH(LRFILE)
SET LRFILE=" "
+20 SET (INP,OUTP,OTHP)=0
SET LTYPE=$PIECE(NODE,U,19)
SET PTYPE=$PIECE(NODE,U,10)
SET TREAT=$PIECE(NODE,U,17)
SET TREAT=$SELECT($PIECE($GET(^DIC(45.7,+TREAT,0)),U,2):$PIECE(^(0),U,2),1:"XX ")
+21 if LRFILE="LRE("!(LRFILE="LRD(65,")
SET TREAT="XY "
+22 if $LENGTH(TREAT)=2
SET TREAT="0"_TREAT
IF $LENGTH(TREAT)=1
SET TREAT="00"_TREAT
+23 SET LRMULT=$SELECT($PIECE(NODE,U,3):$PIECE(NODE,U,3),1:1)
+24 if LTYPE=""
SET LTYPE="Z"
SET PN=$SELECT(("WOR"[LTYPE&(LRFILE="DPT(")):2,("CMZNFI"[LTYPE&(LRFILE="DPT(")):3,LRFILE="LRT(67,":4,LRFILE="LRE(":4,LRFILE="LAB(62.3,":5,LRFILE="LRD(65,":4,1:12)
+25 SET $PIECE(NODE0,U,PN)=$PIECE(NODE0,U,PN)+LRMULT
SET LRURG=+$PIECE(NODE,U,23)
IF LRURG
IF $SELECT(LRURG<3:1,(LRURG>50&(LRURG<53)):1,1:0)
SET $PIECE(NODE0,U,7)=$PIECE(NODE0,U,7)+LRMULT
IF PN=2
SET $PIECE(NODE0,U,6)=$PIECE(NODE0,U,6)+LRMULT
+26 SET ^LRO(67.9,LRPRI,1,LRIN,1,NX,1,NX2,0)=NODE0
+27 SET LRSO=$PIECE(+NODE0,".",2)
SET LRSOCNT=0
IF $EXTRACT(LRSO)=8
FOR PN=2:1:4,8,12
SET LRSOCNT=LRSOCNT+$PIECE(NODE0,U,PN)
+28 IF $GET(LRSOCNT)
SET LRSOCNT=LRSOCNT*LRMULT
SET $PIECE(NODE0,U,10)=LRSOCNT
SET ^LRO(67.9,LRPRI,1,LRIN,1,NX,1,NX2,0)=NODE0
KILL LRSOCNT
+29 if '$DATA(^LRO(67.9,LRPRI,1,LRIN,1,NX,1,NX2,1,0))
SET ^(0)="^67.91148A^"
+30 SET NX3=$ORDER(^LRO(67.9,LRPRI,1,LRIN,1,NX,1,NX2,1,"B",TREAT,0))
IF 'NX3
SET NODE2=^LRO(67.9,LRPRI,1,LRIN,1,NX,1,NX2,1,0)
SET NX3=$PIECE(NODE2,U,3)+1
SET $PIECE(NODE2,U,3)=NX3
SET $PIECE(NODE2,U,4)=$PIECE(NODE2,U,4)+1
SET ^(0)=NODE2
+31 if '$DATA(^LRO(67.9,LRPRI,1,LRIN,1,NX,1,NX2,1,"B",TREAT,NX3))
SET ^(NX3)=""
+32 SET LRTREATN=$SELECT($DATA(^DIC(42.4,+TREAT,0)):$PIECE(^(0),U),1:"")
+33 IF '$LENGTH(LRTREATN)
SET LRTREATN=$SELECT(TREAT="XY ":"BLOOD BANK",1:"AMBULATORY CARE")
+34 if '$DATA(^LRO(67.9,LRPRI,1,LRIN,1,NX,1,NX2,1,NX3,0))#2
SET ^(0)=TREAT_"^^"_LRTREATN
KILL LRTREATN
+35 SET NODE3=^(0)
SET $PIECE(NODE3,U,2)=($PIECE(NODE3,U,2)+LRMULT)
SET ^(0)=NODE3
End DoDot:5
SET $PIECE(^LRO(64.1,LRIN,1,LRDAT,1,LRCAP,1,LRTM,0),U,20)=1
+36 IF $DATA(^LRO(64.1,LRIN,1,LRDAT,1,LRCAP,"S"))
SET NODES=^("S")
Begin DoDot:5
+37 FOR P=1:1:4
SET NODESX=+$PIECE(NODES,U,P)
IF NODESX
SET PSN=$SELECT(P=1:11,P=2:5,P=3:11,1:8)
SET $PIECE(NODE0,U,PSN)=($PIECE(NODE0,U,PSN)+NODESX)
+38 SET ^LRO(67.9,LRPRI,1,LRIN,1,NX,1,NX2,0)=NODE0
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
SET $PIECE(^LRO(64.1,LRIN,1,LRDAT,0),U,2)=1
End DoDot:1
+39 WRITE !!?10,"FINISHED",!!
DO CLEAR
+40 QUIT
NEWIN ;Add new division
+1 if '$DATA(^LRO(67.9,LRPRI,1,0))#2
SET ^(0)="^67.901PA"
+2 KILL DD,DIC,DO
SET DINUM=LRIN
SET DIC(0)="LNM"
SET DLAYGO=67
SET DIC="^LRO(67.9,LRPRI,1,"
SET DA(1)=LRPRI
SET (DA,X)=LRIN
DO FILE^DICN
+3 SET ^LRO(67.9,LRPRI,1,LRIN,1,0)="^67.911D^"
KILL DINUM
+4 QUIT
END ;
+1 SET LREND=1
CLEAR ;
+1 LOCK -^LRO(67.9)
+2 ;STOP TIMING
IF $DATA(XRTN)
SET XRTN="CLEAR^LRCAPAM1"
DO T1^%ZOSV
+3 ;S $P(^TMP("LRCAPEX RUN TIME"),U,2)=$$NOW^XLFDT
+4 DO ^%ZISC
+5 KILL %DT,DA,DIC,DINUM,DLAYGO,DIE,DR,LRDAT,INP,LINE,LRCAP,LRCAPN,LRCAPNA,LRCHK,LRDTS,LRIN,LRPRI,LRPRIN
+6 KILL LRRDT,LRTN,LRLMIP,LRTM,LRURG,LTYPE,NODE,NODE0,NODE2,NODE3,NODES,NODESX,NODEX,NX,NX2
+7 KILL NX3,OTHP,OUTP,P,PN,PSN,PTYPE,TREAT,Y,ZTSK,IO("Q")
+8 KILL LRACT,LRDTE,LREND,LRFILE,LRMULT,LRSO,LRSOCNT,X
+9 QUIT
