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 ---[H[J[2J[HLRACDIAG 3648 printed Oct 16, 2024@18:07:01 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
