LA7VPFL ;DALOI/PDL - Lab Mapping Data Verification ;03/07/12 16:04
;;5.2;AUTOMATED LAB INSTRUMENTS;**74**;Sep 27, 1994;Build 229
;
Q
;
START ;
N LABORT
S LABORT=0
F D MAIN(.LABORT) Q:LABORT
Q
;
MAIN(LABORT) ;
; Prompts for subscript and type of report then queues or displays.
; Inputs
; LABORT: <byref> See Outputs
; Outputs
; LABORT: User wants to abort (1=abort)
;
N RTN,RPT,SS,DIR,DIRUT,TASK,X,Y,POP
S DIR(0)="SO^MI:Microbiology;SP:Surgical Pathology;CY:Cytopathology"
S DIR("A")="Enter Lab Area Subscript"
D ^DIR
I $D(DIRUT) S LABORT=1 Q
S SS=Y
K DIR
S DIR(0)="SO^C:Correctly Mapped Tests;E:Tests with Errors"
D ^DIR
I $D(DIRUT) S LABORT=1 Q
S RPT=0
I Y="E" S RPT=1
I Y="C" S RPT=2
S RTN="SHOW^LA7VPFL("""_SS_""","_RPT_")"
S TASK=$$QUE^LRUTIL(RTN,"Check Lab Test NLT /Code Mapping")
I TASK Q
D SHOW(SS,RPT,.LABORT)
D HOME^%ZIS
Q
;
SHOW(SS,RPT,LABORT) ;
; Branches to the appropriate report subroutine.
; Inputs
; SS: LR subscript (MI,SP,CY)
; RPT: Which report 1=errors 2=correct
; LABORT: <byref> See Outputs
; Outputs
; LABORT: User wants to abort 1=abort
;
S SS=$G(SS)
S RPT=$G(RPT)
S LABORT=$G(LABORT)
U IO
I "^1^2^"[("^"_RPT_"^") D ;
. I RPT=1 D RPT1(SS,.LABORT)
. I RPT=2 D RPT2(SS,.LABORT)
. I $D(ZTQUEUED) S ZTREQ="@"
D ^%ZISC
Q
;
RPT1(LASS,LABORT) ;
; "Mapping Error" report
; Inputs
; LASS: Subscript (ie "MI","SP","CY")
; LABORT: <byref> See Outputs
; Outputs
; LABORT: User wants to abort (1=abort)
;
N LAPGDATA,LAPGNUM,LADATA,LANOW,LAMSG,DATA,NODE,DIERR,X,Y
N D64061,FILE,FIELD,LEC,PROC,R60,R64,R64061,SECT,TEST,WTEST,WKLD
S LASS=$G(LASS)
S LABORT=$G(LABORT)
S LANOW=$$NOW^XLFDT()
S LAPGDATA("HDR")="D HDR1^LA7VPFL"
D HDR1
S NODE="^LAB(60,""B"")"
F S NODE=$Q(@NODE) Q:NODE="" Q:$QS(NODE,2)'="B" D Q:LABORT ;
. Q:@NODE=1
. S WTEST=0 ;Test name was written
. S R60=$QS(NODE,4)
. S TEST=$QS(NODE,3)
. S DATA=$G(^LAB(60,R60,0))
. S X=$P(DATA,U,4)
. Q:X'=LASS
. S DATA=$G(^LAB(60,R60,64))
. S R64=$P(DATA,U,1)
. I 'R64 D Q ; No 64 pointer
. . S WTEST=1
. . D NP Q:LABORT
. . W !,"[",R60,"] ",TEST
. . W ?35," Not Mapped to File #64"
. ;
. S DATA=$G(^LAM(R64,0))
. S PROC=$P(DATA,U,1)
. S WKLD=$P(DATA,U,2)
. I WKLD="" D ;
. . I 'WTEST D NP Q:LABORT W !,"[",R60,"] ",TEST S WTEST=1
. . D NP Q:LABORT W !,?35," No Workload Code"
. ;
. I WKLD'="" Q:WKLD<2
. S DATA=$G(^LAM(R64,63))
. S R64061=$P(DATA,U,1)
. I 'R64061 D ;
. . I 'WTEST D NP Q:LABORT W !,"[",R60,"] ",TEST S WTEST=1
. . D NP Q:LABORT
. . W !,?15,"is mapped to: ",PROC," [",WKLD,"]"
. . D NP Q:LABORT
. . W !,?37,"Not Linked to File #64.061"
. ;
;
W !,$$CJ^XLFSTR("< < < End of report > > >",IOM),!
Q
;
RPT2(LASS,LABORT) ;
; "Mapping Okay" report
; Inputs
; LASS: Subscript (ie "MI","SP","CY")
; LABORT: <byref> See Outputs
; Outputs
; LABORT: User wants to abort (1=abort)
;
N LAPGDATA,LAPGNUM,LADATA,LANOW,LAMSG,DATA,NODE,DIERR,X,Y
N D64061,FILE,FIELD,LEC,SECT,R60,R64,R64061,TEST,WKLD
S LASS=$G(LASS)
S LABORT=$G(LABORT)
S LANOW=$$NOW^XLFDT()
S LAPGDATA("HDR")="D HDR2^LA7VPFL"
D HDR2
S NODE="^LAB(60,""B"")"
F S NODE=$Q(@NODE) Q:NODE="" Q:$QS(NODE,2)'="B" D Q:LABORT ;
. Q:@NODE=1
. S R60=$QS(NODE,4)
. S TEST=$QS(NODE,3)
. S DATA=$G(^LAB(60,R60,0))
. S X=$P(DATA,U,4)
. Q:X'=LASS
. S DATA=$G(^LAB(60,R60,64))
. S R64=$P(DATA,U,1)
. Q:'R64
. S DATA=$G(^LAM(R64,0))
. S WKLD=$P(DATA,U,2)
. Q:WKLD=""
. Q:WKLD<2
. S DATA=$G(^LAM(R64,63))
. S R64061=$P(DATA,U,1)
. Q:'R64061
. S DATA=$G(^LAB(64.061,R64061,0))
. S LEC=$P(DATA,U,1) ;#62.041 NAME
. D GETS^DIQ(64.061,R64061_",","63.1;63.2;63.3","IE","LADATA","LRMSG")
. M D64061=LADATA(64.061,R64061_",")
. K LADATA
. S X=$G(^LAM(R64,0))
. S X=$P(X,U,1)
. W !,"[",R60,"] ",TEST
. D NP Q:LABORT
. W !,?3,"Mapped to: ",X," [",WKLD,"]"
. D NP Q:LABORT
. W !,?5,"Linked to: ",LEC," [",R64061,"]"
. D NP Q:LABORT
. S FILE=D64061(63.1,"E")
. S FIELD=D64061(63.2,"E")
. S:'FIELD FIELD=.01
. S SECT=$S(FILE=63.05:5,FILE=63.08:8,FILE=63.09:9,1:"")
. K LADATA,LAMSG,DIERR
. I SECT D
. . D FIELD^DID(63,SECT,"","LABEL","LADATA","LAMSG")
. . I '$D(LAMSG) S SECT=LADATA("LABEL")
. I SECT="" S SECT="<??"_FILE_"??>"
. ;
. K LADATA,LRMSG,DIERR
. S X=$P(FIELD,";",2)
. S FIELD=$P(FIELD,";",1)
. D FIELD^DID(FILE,FIELD,"","LABEL","LADATA","LAMSG")
. I '$D(LAMSG) S FIELD=LADATA("LABEL")
. ;
. W !,?7,"Lab Data: ",SECT," [",FIELD,"]"
. D NP Q:LABORT
. W !,?9,"SCT Top Concept: ",$G(D64061(63.3,"E"))," [",$G(D64061(63.3,"I")),"]"
. D NP Q:LABORT
;
W !,$$CJ^XLFSTR("< < < End of report > > >",IOM),!
Q
;
HDR1 ;
; Generate header used with "Error" report
N PGNUM,X
S PGNUM=$G(LAPGDATA("PGNUM"),1)
I PGNUM=1 I $E($G(IOST),1,2)="C-" I $G(IOF)'="" W @IOF
W !,"Laboratory Tests for "_LASS_" with mapping errors"
S X=$$FMTE^XLFDT(LANOW)
W ?IOM-$L(X),X
S X="Page: "_PGNUM_" "
W !?IOM-$L(X),X
W !,$$REPEAT^XLFSTR("=",IOM)
Q
;
HDR2 ;
; Generate header used with "Correct" report
N PGNUM,X
S PGNUM=$G(LAPGDATA("PGNUM"),1)
I PGNUM=1 I $E($G(IOST),1,2)="C-" I $G(IOF)'="" W @IOF
W !,"Laboratory Tests for "_LASS_" mapped correctly"
S X=$$FMTE^XLFDT(LANOW)
W ?IOM-$L(X),X
S X="Page: "_PGNUM_" "
W !?IOM-$L(X),X
W !,$$REPEAT^XLFSTR("=",IOM)
Q
;
NP ;
; Convenience method
D NP^LRUTIL(.LABORT,.LAPGDATA)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLA7VPFL 5574 printed Dec 13, 2024@01:41:06 Page 2
LA7VPFL ;DALOI/PDL - Lab Mapping Data Verification ;03/07/12 16:04
+1 ;;5.2;AUTOMATED LAB INSTRUMENTS;**74**;Sep 27, 1994;Build 229
+2 ;
+3 QUIT
+4 ;
START ;
+1 NEW LABORT
+2 SET LABORT=0
+3 FOR
DO MAIN(.LABORT)
if LABORT
QUIT
+4 QUIT
+5 ;
MAIN(LABORT) ;
+1 ; Prompts for subscript and type of report then queues or displays.
+2 ; Inputs
+3 ; LABORT: <byref> See Outputs
+4 ; Outputs
+5 ; LABORT: User wants to abort (1=abort)
+6 ;
+7 NEW RTN,RPT,SS,DIR,DIRUT,TASK,X,Y,POP
+8 SET DIR(0)="SO^MI:Microbiology;SP:Surgical Pathology;CY:Cytopathology"
+9 SET DIR("A")="Enter Lab Area Subscript"
+10 DO ^DIR
+11 IF $DATA(DIRUT)
SET LABORT=1
QUIT
+12 SET SS=Y
+13 KILL DIR
+14 SET DIR(0)="SO^C:Correctly Mapped Tests;E:Tests with Errors"
+15 DO ^DIR
+16 IF $DATA(DIRUT)
SET LABORT=1
QUIT
+17 SET RPT=0
+18 IF Y="E"
SET RPT=1
+19 IF Y="C"
SET RPT=2
+20 SET RTN="SHOW^LA7VPFL("""_SS_""","_RPT_")"
+21 SET TASK=$$QUE^LRUTIL(RTN,"Check Lab Test NLT /Code Mapping")
+22 IF TASK
QUIT
+23 DO SHOW(SS,RPT,.LABORT)
+24 DO HOME^%ZIS
+25 QUIT
+26 ;
SHOW(SS,RPT,LABORT) ;
+1 ; Branches to the appropriate report subroutine.
+2 ; Inputs
+3 ; SS: LR subscript (MI,SP,CY)
+4 ; RPT: Which report 1=errors 2=correct
+5 ; LABORT: <byref> See Outputs
+6 ; Outputs
+7 ; LABORT: User wants to abort 1=abort
+8 ;
+9 SET SS=$GET(SS)
+10 SET RPT=$GET(RPT)
+11 SET LABORT=$GET(LABORT)
+12 USE IO
+13 ;
IF "^1^2^"[("^"_RPT_"^")
Begin DoDot:1
+14 IF RPT=1
DO RPT1(SS,.LABORT)
+15 IF RPT=2
DO RPT2(SS,.LABORT)
+16 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
End DoDot:1
+17 DO ^%ZISC
+18 QUIT
+19 ;
RPT1(LASS,LABORT) ;
+1 ; "Mapping Error" report
+2 ; Inputs
+3 ; LASS: Subscript (ie "MI","SP","CY")
+4 ; LABORT: <byref> See Outputs
+5 ; Outputs
+6 ; LABORT: User wants to abort (1=abort)
+7 ;
+8 NEW LAPGDATA,LAPGNUM,LADATA,LANOW,LAMSG,DATA,NODE,DIERR,X,Y
+9 NEW D64061,FILE,FIELD,LEC,PROC,R60,R64,R64061,SECT,TEST,WTEST,WKLD
+10 SET LASS=$GET(LASS)
+11 SET LABORT=$GET(LABORT)
+12 SET LANOW=$$NOW^XLFDT()
+13 SET LAPGDATA("HDR")="D HDR1^LA7VPFL"
+14 DO HDR1
+15 SET NODE="^LAB(60,""B"")"
+16 ;
FOR
SET NODE=$QUERY(@NODE)
if NODE=""
QUIT
if $QSUBSCRIPT(NODE,2)'="B"
QUIT
Begin DoDot:1
+17 if @NODE=1
QUIT
+18 ;Test name was written
SET WTEST=0
+19 SET R60=$QSUBSCRIPT(NODE,4)
+20 SET TEST=$QSUBSCRIPT(NODE,3)
+21 SET DATA=$GET(^LAB(60,R60,0))
+22 SET X=$PIECE(DATA,U,4)
+23 if X'=LASS
QUIT
+24 SET DATA=$GET(^LAB(60,R60,64))
+25 SET R64=$PIECE(DATA,U,1)
+26 ; No 64 pointer
IF 'R64
Begin DoDot:2
+27 SET WTEST=1
+28 DO NP
if LABORT
QUIT
+29 WRITE !,"[",R60,"] ",TEST
+30 WRITE ?35," Not Mapped to File #64"
End DoDot:2
QUIT
+31 ;
+32 SET DATA=$GET(^LAM(R64,0))
+33 SET PROC=$PIECE(DATA,U,1)
+34 SET WKLD=$PIECE(DATA,U,2)
+35 ;
IF WKLD=""
Begin DoDot:2
+36 IF 'WTEST
DO NP
if LABORT
QUIT
WRITE !,"[",R60,"] ",TEST
SET WTEST=1
+37 DO NP
if LABORT
QUIT
WRITE !,?35," No Workload Code"
End DoDot:2
+38 ;
+39 IF WKLD'=""
if WKLD<2
QUIT
+40 SET DATA=$GET(^LAM(R64,63))
+41 SET R64061=$PIECE(DATA,U,1)
+42 ;
IF 'R64061
Begin DoDot:2
+43 IF 'WTEST
DO NP
if LABORT
QUIT
WRITE !,"[",R60,"] ",TEST
SET WTEST=1
+44 DO NP
if LABORT
QUIT
+45 WRITE !,?15,"is mapped to: ",PROC," [",WKLD,"]"
+46 DO NP
if LABORT
QUIT
+47 WRITE !,?37,"Not Linked to File #64.061"
End DoDot:2
+48 ;
End DoDot:1
if LABORT
QUIT
+49 ;
+50 WRITE !,$$CJ^XLFSTR("< < < End of report > > >",IOM),!
+51 QUIT
+52 ;
RPT2(LASS,LABORT) ;
+1 ; "Mapping Okay" report
+2 ; Inputs
+3 ; LASS: Subscript (ie "MI","SP","CY")
+4 ; LABORT: <byref> See Outputs
+5 ; Outputs
+6 ; LABORT: User wants to abort (1=abort)
+7 ;
+8 NEW LAPGDATA,LAPGNUM,LADATA,LANOW,LAMSG,DATA,NODE,DIERR,X,Y
+9 NEW D64061,FILE,FIELD,LEC,SECT,R60,R64,R64061,TEST,WKLD
+10 SET LASS=$GET(LASS)
+11 SET LABORT=$GET(LABORT)
+12 SET LANOW=$$NOW^XLFDT()
+13 SET LAPGDATA("HDR")="D HDR2^LA7VPFL"
+14 DO HDR2
+15 SET NODE="^LAB(60,""B"")"
+16 ;
FOR
SET NODE=$QUERY(@NODE)
if NODE=""
QUIT
if $QSUBSCRIPT(NODE,2)'="B"
QUIT
Begin DoDot:1
+17 if @NODE=1
QUIT
+18 SET R60=$QSUBSCRIPT(NODE,4)
+19 SET TEST=$QSUBSCRIPT(NODE,3)
+20 SET DATA=$GET(^LAB(60,R60,0))
+21 SET X=$PIECE(DATA,U,4)
+22 if X'=LASS
QUIT
+23 SET DATA=$GET(^LAB(60,R60,64))
+24 SET R64=$PIECE(DATA,U,1)
+25 if 'R64
QUIT
+26 SET DATA=$GET(^LAM(R64,0))
+27 SET WKLD=$PIECE(DATA,U,2)
+28 if WKLD=""
QUIT
+29 if WKLD<2
QUIT
+30 SET DATA=$GET(^LAM(R64,63))
+31 SET R64061=$PIECE(DATA,U,1)
+32 if 'R64061
QUIT
+33 SET DATA=$GET(^LAB(64.061,R64061,0))
+34 ;#62.041 NAME
SET LEC=$PIECE(DATA,U,1)
+35 DO GETS^DIQ(64.061,R64061_",","63.1;63.2;63.3","IE","LADATA","LRMSG")
+36 MERGE D64061=LADATA(64.061,R64061_",")
+37 KILL LADATA
+38 SET X=$GET(^LAM(R64,0))
+39 SET X=$PIECE(X,U,1)
+40 WRITE !,"[",R60,"] ",TEST
+41 DO NP
if LABORT
QUIT
+42 WRITE !,?3,"Mapped to: ",X," [",WKLD,"]"
+43 DO NP
if LABORT
QUIT
+44 WRITE !,?5,"Linked to: ",LEC," [",R64061,"]"
+45 DO NP
if LABORT
QUIT
+46 SET FILE=D64061(63.1,"E")
+47 SET FIELD=D64061(63.2,"E")
+48 if 'FIELD
SET FIELD=.01
+49 SET SECT=$SELECT(FILE=63.05:5,FILE=63.08:8,FILE=63.09:9,1:"")
+50 KILL LADATA,LAMSG,DIERR
+51 IF SECT
Begin DoDot:2
+52 DO FIELD^DID(63,SECT,"","LABEL","LADATA","LAMSG")
+53 IF '$DATA(LAMSG)
SET SECT=LADATA("LABEL")
End DoDot:2
+54 IF SECT=""
SET SECT="<??"_FILE_"??>"
+55 ;
+56 KILL LADATA,LRMSG,DIERR
+57 SET X=$PIECE(FIELD,";",2)
+58 SET FIELD=$PIECE(FIELD,";",1)
+59 DO FIELD^DID(FILE,FIELD,"","LABEL","LADATA","LAMSG")
+60 IF '$DATA(LAMSG)
SET FIELD=LADATA("LABEL")
+61 ;
+62 WRITE !,?7,"Lab Data: ",SECT," [",FIELD,"]"
+63 DO NP
if LABORT
QUIT
+64 WRITE !,?9,"SCT Top Concept: ",$GET(D64061(63.3,"E"))," [",$GET(D64061(63.3,"I")),"]"
+65 DO NP
if LABORT
QUIT
End DoDot:1
if LABORT
QUIT
+66 ;
+67 WRITE !,$$CJ^XLFSTR("< < < End of report > > >",IOM),!
+68 QUIT
+69 ;
HDR1 ;
+1 ; Generate header used with "Error" report
+2 NEW PGNUM,X
+3 SET PGNUM=$GET(LAPGDATA("PGNUM"),1)
+4 IF PGNUM=1
IF $EXTRACT($GET(IOST),1,2)="C-"
IF $GET(IOF)'=""
WRITE @IOF
+5 WRITE !,"Laboratory Tests for "_LASS_" with mapping errors"
+6 SET X=$$FMTE^XLFDT(LANOW)
+7 WRITE ?IOM-$LENGTH(X),X
+8 SET X="Page: "_PGNUM_" "
+9 WRITE !?IOM-$LENGTH(X),X
+10 WRITE !,$$REPEAT^XLFSTR("=",IOM)
+11 QUIT
+12 ;
HDR2 ;
+1 ; Generate header used with "Correct" report
+2 NEW PGNUM,X
+3 SET PGNUM=$GET(LAPGDATA("PGNUM"),1)
+4 IF PGNUM=1
IF $EXTRACT($GET(IOST),1,2)="C-"
IF $GET(IOF)'=""
WRITE @IOF
+5 WRITE !,"Laboratory Tests for "_LASS_" mapped correctly"
+6 SET X=$$FMTE^XLFDT(LANOW)
+7 WRITE ?IOM-$LENGTH(X),X
+8 SET X="Page: "_PGNUM_" "
+9 WRITE !?IOM-$LENGTH(X),X
+10 WRITE !,$$REPEAT^XLFSTR("=",IOM)
+11 QUIT
+12 ;
NP ;
+1 ; Convenience method
+2 DO NP^LRUTIL(.LABORT,.LAPGDATA)
+3 QUIT
