LRACDIAG.m

LRACDIAG ;SLC/DCM - DIAGNOSTIC REPORT FOR LAB REPORTS FILE (64.5) ;2/19/91  10:09 ;

 ;;5.2;LAB SERVICE;;Sep 27, 1994

 ;

 S:'$D(U) U="^" S LRCKW=1

QUE S %ZIS="MQ" D ^%ZIS Q:POP  I $D(IO("Q")) K IO("Q") S ZTRTN="DQ^LRACDIAG",ZTDESC="Cumulative diagnostics",ZTSAVE("U")="",ZTSAVE("DT")="",ZTSAVE("LRCKW")="" D ^%ZTLOAD K ZTSK G END

 D ENT W !! W:$E(IOST,1,2)="P-" @IOF D ^%ZISC

 Q

ENT ;from LRCKF

 U IO K ^TMP($J),LR S A=0 W !!,?10,"Diagnostic Report for LAB REPORTS FILE (64.5)" I $O(^LAB(64.5,1,2,0))<1,LRCKW W !!,"SUPERVISOR'S SUMMARY REPORT field not defined",?68,">>WARNING<<"

 I $D(^LAB(64.5,"AC",0)) W !!,"The ""AC"" x-ref indicates that the Lab Reports file may contain tests",!?3,"that do not have data names (cosmic).  Remove test and re-cross-",!?3,"reference the ""AC"" index.",?70,">>FATAL<<"

 I $O(^LAB(64.5,1,3,0))<1 W !!,"REPORT NAME field not defined",?70,">>FATAL<<"

 F I=0:0 S A=$O(^LAB(64.5,1,3,A)) Q:A<1  I $D(^(A,0))#2 S LRST(A)=$P(^(0),U,2),LREN(A)=$P(^(0),U,3) I LREN(A)'=LRST(A) D

 . W:LREN(A)']LRST(A) !!,"ENDING LOCATION does not follow STARTING LOCATION",?70,">>FATAL<<" D DEV

MAJ S DA(3)=1,DA(2)=0 F  S DA(2)=$O(^LAB(64.5,1,1,DA(2))) Q:DA(2)<1  S LRMAJ=$P(^(DA(2),0),U,1),LROFMT="" W !!,LRMAJ D MIN

END K ^TMP($J),LRMAJ,LRMIN,LRTS,LRTST,LRSB,LRSITE,LR,LRCKW,LREN,LRFMT,LROFMT,LRST,I,J,K,DA

 W !! W:$E(IOST,1,2)="P-" @IOF

 Q

DEV W:'$D(^LAB(64.5,1,3,A,.1))#2 !,"No device defined for report name: ",$P(^LAB(64.5,1,3,A,0),U),?70,">>FATAL<<"

 Q

MIN S J=0 F  S J=$O(^LAB(64.5,1,1,DA(2),1,J)) Q:J<1  I $D(^(J,0))#2 S DA(1)=J,X=^(0),LRMIN=$P(X,U,1),LRSITE=$P(X,U,2),LRFMT=$P(X,U,3) S:'$L(LROFMT) LROFMT=LRFMT W !?3,LRMIN D TST

 Q

TST I LROFMT="V",LRFMT="H" W:'$D(LR) !?5,"Horizontal formats cannot be added after a vertical format.",?70,">>FATAL<<"

 S K=0 F  S K=$O(^LAB(64.5,1,1,DA(2),1,J,1,K)) Q:K<1  I $D(^(K,0))#2 S DA=K,X=^(0),LRTST=$P(X,U,3),LRTS=$P(X,U,1),LRSB=+$P($P(X,U,5),";",2),X=$P(X,U,1) D CHK,XREF

 Q

CHK I 'LRSB W:'$D(LR) !?5,LRTST," of the ",LRMIN," minor header of the ",LRMAJ,!?5," major header is not an atomic test (no data name).",?70,">>FATAL<<"

 I $D(^TMP($J,LRSITE,LRTS)) W:'$D(LR) !?5,LRTST," with ",$S($D(^LAB(61,LRSITE,0)):$P(^(0),U,1),1:"")," specimen already exists on another minor header.",?70,">>FATAL<<"

 E  S:'$D(LR) ^TMP($J,LRSITE,LRTS)=""

 Q

XREF G:$D(LR) XREF1 I '$D(^LAB(64.5,"AR",$P(^LAB(64.5,DA(3),1,DA(2),1,DA(1),0),"^",2),$P(^(1,DA,0),"^",1))) W !?5,"""AR"" x-ref does not exist for ",LRTST,?70,">>FATAL<<"

 I '$D(^LAB(64.5,"A",DA(3),DA(2),DA(1),DA)) W !?5,"""A"" x-ref does not exist for ",LRTST,?70,">>FATAL<<" Q

 I $D(^LAB(60,LRTS,1,LRSITE,0)),^LAB(64.5,"A",DA(3),DA(2),DA(1),DA)'=^LAB(60,LRTS,1,LRSITE,0) W !?5,"""A"" x-ref for ",LRTST," is 'out-of-date' with file 60.",?70,">>FATAL<<"

 I '$D(^LAB(64.5,"AC",+$P($P(^LAB(64.5,DA(3),1,DA(2),1,DA(1),1,DA,0),"^",5),";",2),DA(3),DA(2),DA(1),DA)) W !?5,"""AC"" x-ref does not exist for ",LRTST,?70,">>FATAL<<"

 Q

XREF1 I $D(LR(1)) X ^DD(64.53,.01,1,6,1) W "."

 I $D(LR(2)) X ^DD(64.53,4,1,1,1) W "."

 I $D(LR(3)) X ^DD(64.53,.01,1,5,1) W "."

 Q

EN S:'$D(U) U="^" S:'$D(DTIME) DTIME=300

 W:$D(LR(1)) !,"Mumps ""A"" index of the LAB TEST subfield",!?4,"(contains reference ranges, units, etc. from file 60)"

 W:$D(LR(2)) !,"Mumps ""AC"" index of the LAB TEST LOCATION subfield",!?4,"(atomic test x-ref.)" W:$D(LR(3)) !,"Mumps ""AR"" index of the LAB TEST subfield",!?4,"(site/specimen x-ref.)"

 W !!,"ARE YOU SURE" S %=2 D YN^DICN G END:%<1!(%=2)

 K:$D(LR(1)) ^LAB(64.5,"A") K:$D(LR(2)) ^LAB(64.5,"AC") K:$D(LR(3)) ^LAB(64.5,"AR")

 D MAJ

 G END

DQ U IO S:$D(ZTQUEUED) ZTREQ="@" D ENT D ^%ZISC Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---LRACDIAG   3648     printed  Feb 18, 2025@23:32:09                                                                                                                                                                                                    Page 2

LRACDIAG  ;SLC/DCM - DIAGNOSTIC REPORT FOR LAB REPORTS FILE (64.5) ;2/19/91  10:09 ;

 +1       ;;5.2;LAB SERVICE;;Sep 27, 1994

 +2       ;

 +3        if '$DATA(U)

               SET U="^"

           SET LRCKW=1

QUE        SET %ZIS="MQ"

           DO ^%ZIS

           if POP

               QUIT 

           IF $DATA(IO("Q"))

               KILL IO("Q")

               SET ZTRTN="DQ^LRACDIAG"

               SET ZTDESC="Cumulative diagnostics"

               SET ZTSAVE("U")=""

               SET ZTSAVE("DT")=""

               SET ZTSAVE("LRCKW")=""

               DO ^%ZTLOAD

               KILL ZTSK

               GOTO END

 +1        DO ENT

           WRITE !!

           if $EXTRACT(IOST,1,2)="P-"

               WRITE @IOF

           DO ^%ZISC

 +2        QUIT 

ENT       ;from LRCKF

 +1        USE IO

           KILL ^TMP($JOB),LR

           SET A=0

           WRITE !!,?10,"Diagnostic Report for LAB REPORTS FILE (64.5)"

           IF $ORDER(^LAB(64.5,1,2,0))<1

               IF LRCKW

                   WRITE !!,"SUPERVISOR'S SUMMARY REPORT field not defined",?68,">>WARNING<<"

 +2        IF $DATA(^LAB(64.5,"AC",0))

               WRITE !!,"The ""AC"" x-ref indicates that the Lab Reports file may contain tests",!?3,"that do not have data names (cosmic).  Remove test and re-cross-",!?3,"reference the ""AC"" index.",?70,">>FATAL<<"

 +3        IF $ORDER(^LAB(64.5,1,3,0))<1

               WRITE !!,"REPORT NAME field not defined",?70,">>FATAL<<"

 +4        FOR I=0:0

               SET A=$ORDER(^LAB(64.5,1,3,A))

               if A<1

                   QUIT 

               IF $DATA(^(A,0))#2

                   SET LRST(A)=$PIECE(^(0),U,2)

                   SET LREN(A)=$PIECE(^(0),U,3)

                   IF LREN(A)'=LRST(A)

                       Begin DoDot:1

 +5                        if LREN(A)']LRST(A)

                               WRITE !!,"ENDING LOCATION does not follow STARTING LOCATION",?70,">>FATAL<<"

                           DO DEV

                       End DoDot:1

MAJ        SET DA(3)=1

           SET DA(2)=0

           FOR 

               SET DA(2)=$ORDER(^LAB(64.5,1,1,DA(2)))

               if DA(2)<1

                   QUIT 

               SET LRMAJ=$PIECE(^(DA(2),0),U,1)

               SET LROFMT=""

               WRITE !!,LRMAJ

               DO MIN

END        KILL ^TMP($JOB),LRMAJ,LRMIN,LRTS,LRTST,LRSB,LRSITE,LR,LRCKW,LREN,LRFMT,LROFMT,LRST,I,J,K,DA

 +1        WRITE !!

           if $EXTRACT(IOST,1,2)="P-"

               WRITE @IOF

 +2        QUIT 

DEV        if '$DATA(^LAB(64.5,1,3,A,.1))#2

               WRITE !,"No device defined for report name: ",$PIECE(^LAB(64.5,1,3,A,0),U),?70,">>FATAL<<"

 +1        QUIT 

MIN        SET J=0

           FOR 

               SET J=$ORDER(^LAB(64.5,1,1,DA(2),1,J))

               if J<1

                   QUIT 

               IF $DATA(^(J,0))#2

                   SET DA(1)=J

                   SET X=^(0)

                   SET LRMIN=$PIECE(X,U,1)

                   SET LRSITE=$PIECE(X,U,2)

                   SET LRFMT=$PIECE(X,U,3)

                   if '$LENGTH(LROFMT)

                       SET LROFMT=LRFMT

                   WRITE !?3,LRMIN

                   DO TST

 +1        QUIT 

TST        IF LROFMT="V"

               IF LRFMT="H"

                   if '$DATA(LR)

                       WRITE !?5,"Horizontal formats cannot be added after a vertical format.",?70,">>FATAL<<"

 +1        SET K=0

           FOR 

               SET K=$ORDER(^LAB(64.5,1,1,DA(2),1,J,1,K))

               if K<1

                   QUIT 

               IF $DATA(^(K,0))#2

                   SET DA=K

                   SET X=^(0)

                   SET LRTST=$PIECE(X,U,3)

                   SET LRTS=$PIECE(X,U,1)

                   SET LRSB=+$PIECE($PIECE(X,U,5),";",2)

                   SET X=$PIECE(X,U,1)

                   DO CHK

                   DO XREF

 +2        QUIT 

CHK        IF 'LRSB

               if '$DATA(LR)

                   WRITE !?5,LRTST," of the ",LRMIN," minor header of the ",LRMAJ,!?5," major header is not an atomic test (no data name).",?70,">>FATAL<<"

 +1        IF $DATA(^TMP($JOB,LRSITE,LRTS))

               if '$DATA(LR)

                   WRITE !?5,LRTST," with ",$SELECT($DATA(^LAB(61,LRSITE,0)):$PIECE(^(0),U,1),1:"")," specimen already exists on another minor header.",?70,">>FATAL<<"

 +2       IF '$TEST

               if '$DATA(LR)

                   SET ^TMP($JOB,LRSITE,LRTS)=""

 +3        QUIT 

XREF       if $DATA(LR)

               GOTO XREF1

           IF '$DATA(^LAB(64.5,"AR",$PIECE(^LAB(64.5,DA(3),1,DA(2),1,DA(1),0),"^",2),$PIECE(^(1,DA,0),"^",1)))

               WRITE !?5,"""AR"" x-ref does not exist for ",LRTST,?70,">>FATAL<<"

 +1        IF '$DATA(^LAB(64.5,"A",DA(3),DA(2),DA(1),DA))

               WRITE !?5,"""A"" x-ref does not exist for ",LRTST,?70,">>FATAL<<"

               QUIT 

 +2        IF $DATA(^LAB(60,LRTS,1,LRSITE,0))

               IF ^LAB(64.5,"A",DA(3),DA(2),DA(1),DA)'=^LAB(60,LRTS,1,LRSITE,0)

                   WRITE !?5,"""A"" x-ref for ",LRTST," is 'out-of-date' with file 60.",?70,">>FATAL<<"

 +3        IF '$DATA(^LAB(64.5,"AC",+$PIECE($PIECE(^LAB(64.5,DA(3),1,DA(2),1,DA(1),1,DA,0),"^",5),";",2),DA(3),DA(2),DA(1),DA))

               WRITE !?5,"""AC"" x-ref does not exist for ",LRTST,?70,">>FATAL<<"

 +4        QUIT 

XREF1      IF $DATA(LR(1))

               XECUTE ^DD(64.53,.01,1,6,1)

               WRITE "."

 +1        IF $DATA(LR(2))

               XECUTE ^DD(64.53,4,1,1,1)

               WRITE "."

 +2        IF $DATA(LR(3))

               XECUTE ^DD(64.53,.01,1,5,1)

               WRITE "."

 +3        QUIT 

EN         if '$DATA(U)

               SET U="^"

           if '$DATA(DTIME)

               SET DTIME=300

 +1        if $DATA(LR(1))

               WRITE !,"Mumps ""A"" index of the LAB TEST subfield",!?4,"(contains reference ranges, units, etc. from file 60)"

 +2        if $DATA(LR(2))

               WRITE !,"Mumps ""AC"" index of the LAB TEST LOCATION subfield",!?4,"(atomic test x-ref.)"

           if $DATA(LR(3))

               WRITE !,"Mumps ""AR"" index of the LAB TEST subfield",!?4,"(site/specimen x-ref.)"

 +3        WRITE !!,"ARE YOU SURE"

           SET %=2

           DO YN^DICN

           if %<1!(%=2)

               GOTO END

 +4        if $DATA(LR(1))

               KILL ^LAB(64.5,"A")

           if $DATA(LR(2))

               KILL ^LAB(64.5,"AC")

           if $DATA(LR(3))

               KILL ^LAB(64.5,"AR")

 +5        DO MAJ

 +6        GOTO END

DQ         USE IO

           if $DATA(ZTQUEUED)

               SET ZTREQ="@"

           DO ENT

           DO ^%ZISC

           QUIT