LRCAPAM1.m

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 ---LRCAPAM1   4627     printed  Mar 13, 2025@21:16:56                                                                                                                                                                                                    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