LA7VLCM2 ;DALOI/JDB - LAB CODE MAPPING FILE UTILITIES ;03/07/12 10:45
;;5.2;AUTOMATED LAB INSTRUMENTS;**74**;Sep 27, 1994;Build 229
;
; Ex subs are the main entry points from menus, etc..
; Px subs are the main workhorse (called from Ex)
Q
;
E1 ;
; Print #62.47 entries based on Msg Config and Concept
N X,Y,CNT,QUE,DIR,R6248
S (X,CNT)=0
; how many #62.48s in #62.47
F S X=$O(^LAB(62.47,"AG",X)) Q:X="" Q:CNT>1 S CNT=CNT+1
I CNT=0 W !,"No entries to display." Q
I CNT=1 D ;
. S R6248=$O(^LAB(62.47,"AG",0))
;
I CNT>1 D ;
. S DIR(0)="Y"
. S DIR("A")="Print All Message Configurations? "
. S DIR("B")="N"
. S DIR("?")="Print all codes associated with all message configurations."
. D ^DIR
. S R6248=0
. I Y=0 D Q:R6248'>0 ;
. . N DIC
. . S DIC=62.48
. . S DIC(0)="AENOQ"
. . S DIC("S")="I $D(^LAB(62.47,""AG"",+Y))"
. . D ^DIC
. . K DIC
. . S R6248=+Y
. ;
Q:R6248<0
S X="P1^LA7VLCM2("_R6248_")"
S QUE=$$QUE^LA7VLCM1(X,"Print Codes from #62.47")
I QUE=-1 Q
I 'QUE D P1(R6248)
Q
;
P1(R6248) ;
; Print codes based on Message Config (R6248)
N EXIT,LINE,LINE2,NOW,PAGE,EOP,START,TITLE
N R6247,R624701,DFL,IORVON,IORVOFF,X,CODE,CODSET,CONCLAST
N TMPNM
S TMPNM="LA7VLCM2-P1A"
K ^TMP(TMPNM,$J)
D INIT^LA7VLCM1
S EOP=5
S TITLE="LAB CODE MAPPING (BY MSG CONFIG)"
S X="IORVON;IORVOFF"
D ;
. N %ZIS
. D ENDR^%ZISS
; get max field sizes
S R6247=0
F S R6247=$O(^LAB(62.47,R6247)) Q:'R6247 D ;
. D DFL^LA7VLCM1(R6247,.DFL)
S R6247=0
S START=1
D HDR^LA7VLCM1(.DFL,TITLE)
I 'R6248 D ;
. ;go thru Msg Configs in alpha order
. N MSGCFG
. S MSGCFG=""
. F S MSGCFG=$O(^LAHM(62.48,"B",MSGCFG)) Q:MSGCFG="" D Q:EXIT ;
. . S R6248=$O(^LAHM(62.48,"B",MSGCFG,0))
. . Q:'R6248
. . D P1A(R6248)
. ;
. S R6248=0
;
I R6248 D ;
. D P1A(R6248)
;
D P1DISP
K ^TMP("LA7VLCM2-P1A",$J)
D CLEAN^LA7VLCM1
Q
;
P1A(R6248) ;
; Helper method for P1
; Creates then steps through its ^TMP global and then
; calls the display method
N R6247,R624701,NODE,X,CODE,CODSET,MSGCFG
N TMPNM
S TMPNM="LA7VLCM2-P1A"
S R6247=0
S NODE="^LAB(62.47,""AG"",R6248)"
F S NODE=$Q(@NODE) Q:NODE="" Q:$QS(NODE,3)'=R6248 Q:$QS(NODE,2)'="AG" Q:$QS(NODE,1)'=62.47 D ;
. S R6247=$QS(NODE,4)
. S R624701=$QS(NODE,5)
. ;create sort global
. S X=$G(^LAB(62.47,R6247,1,R624701,0))
. S CODE=$P(X,U,1)
. S CODSET=$P(X,U,2)
. S:CODE="" CODE="??" S:CODSET="" CODSET="??"
. S X=$G(^LAHM(62.48,R6248,0))
. S MSGCFG=$P(X,U,1)
. S ^TMP(TMPNM,$J,R6247,MSGCFG,R6248,CODE,CODSET,R624701)=""
Q
;
P1DISP ;
; Utility display function for P1 (above)
; now go thru sorted codes for display
; ^TMP("LA7VLCM2-P1",$J,R6247,MSGCFG,R6248,CODE,CODSET,R624701)=""
N NODE,R6248,R6247,R624701,LASTCONC
N TMPNM
S TMPNM="LA7VLCM2-P1A"
S LASTCONC=0 ;Last Concept printed
S NODE="^TMP(TMPNM,$J)"
F S NODE=$Q(@NODE) Q:NODE="" Q:$QS(NODE,2)'=$J Q:$QS(NODE,1)'=TMPNM D Q:EXIT ;
. S R6248=$QS(NODE,5)
. S R6247=$QS(NODE,3)
. S R624701=$QS(NODE,8)
. Q:'R624701
. I LASTCONC'=R6247 D ;
. . I LASTCONC'=0 W !
. . D RVID^LA7VLCM1(1)
. . W !,"CONCEPT:",$$GET1^DIQ(62.47,R6247_",",".01","E","","")
. . W " (",$$GET1^DIQ(62.47,R6247_",",".02","I","",""),")"
. . I $E($G(IOST),1,2)="C-" W $$RJ^XLFSTR("",IOM-$X," ")
. . D RVID^LA7VLCM1(0)
. . S LASTCONC=R6247
. D SUB^LA7VLCM1(.DFL,R6247,,R624701)
. ;
K ^TMP(TMPNM,$J)
Q
;
E2 ;
; Print #62.47 entries with bad IDENTIFIER/CODE SYSTEM mappings
N X,Y,CNT,QUE,DIR
S (X,CNT)=0
S X="P2^LA7VLCM2(1)"
S QUE=$$QUE^LA7VLCM1(X,"Code/Set mismatches in #62.47")
I QUE=-1 Q
I 'QUE D P2(0)
Q
;
P2(QUE) ;
; Print entries with bad IDENTIFIER/CODE SYS mappings
; Inputs
; QUE 1=was queued
N EXIT,LINE,LINE2,NOW,PAGE,EOP,START,TITLE
N R6247,R624701,DFL,IORVON,IORVOFF,X,TMPNM
N CODE,CS,CONCLAST,NODE,LADOT
N TMPNM
S QUE=+$G(QUE)
S TMPNM="LA7VLCM2-P2"
K ^TMP(TMPNM,$J)
D INIT^LA7VLCM1
S EOP=5
S TITLE="LAB CODE MAPPING (CODE/SET MISMATCHES)"
S X="IORVON;IORVOFF"
D ;
. N %ZIS
. D ENDR^%ZISS
; get max field sizes
S R6247=0
F S R6247=$O(^LAB(62.47,R6247)) Q:'R6247 D ;
. D DFL^LA7VLCM1(R6247,.DFL)
S R6247=0
S START=1
; build list
I 'QUE D WAIT^DICD
S LADOT=$H
S NODE="^LAB(62.47,""AF"")"
F S NODE=$Q(@NODE) Q:NODE="" Q:$QS(NODE,2)'="AF" D ;
. S CS=$QS(NODE,3)
. S CODE=$QS(NODE,4)
. S R6247=$QS(NODE,5)
. S R624701=$QS(NODE,6)
. I 'QUE D PROGRESS^LA7VLCM1(.LADOT)
. Q:$$CODSETOK^LA7VLCM3("","",CODE,CS,0)
. S ^TMP(TMPNM,$J,R6247,CODE,CS,R624701)=""
D HDR^LA7VLCM1(.DFL,TITLE)
S NODE="^TMP(TMPNM,$J)"
S CONCLAST=0
F S NODE=$Q(@NODE) Q:NODE="" Q:$QS(NODE,1)'=TMPNM Q:$QS(NODE,2)'=$J D Q:EXIT ;
. I CONCLAST'=0 W !
. S R6247=$QS(NODE,3)
. S CODE=$QS(NODE,4)
. S CS=$QS(NODE,5)
. S R624701=$QS(NODE,6)
. S CONCLAST=R6247
. D RVID^LA7VLCM1(1)
. W !,"CONCEPT:",$$GET1^DIQ(62.47,R6247_",",".01","E","","")
. W " (",$$GET1^DIQ(62.47,R6247_",",".02","I","",""),")"
. I $E($G(IOST),1,2)="C-" W $$RJ^XLFSTR("",IOM-$X," ")
. D RVID^LA7VLCM1(0)
. D SUB^LA7VLCM1(.DFL,R6247,,R624701)
I CONCLAST=0 W !!," No exceptions found."
;
K ^TMP(TMPNM,$J)
D CLEAN^LA7VLCM1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLA7VLCM2 5303 printed Apr 09, 2024@20:44:49 Page 2
LA7VLCM2 ;DALOI/JDB - LAB CODE MAPPING FILE UTILITIES ;03/07/12 10:45
+1 ;;5.2;AUTOMATED LAB INSTRUMENTS;**74**;Sep 27, 1994;Build 229
+2 ;
+3 ; Ex subs are the main entry points from menus, etc..
+4 ; Px subs are the main workhorse (called from Ex)
+5 QUIT
+6 ;
E1 ;
+1 ; Print #62.47 entries based on Msg Config and Concept
+2 NEW X,Y,CNT,QUE,DIR,R6248
+3 SET (X,CNT)=0
+4 ; how many #62.48s in #62.47
+5 FOR
SET X=$ORDER(^LAB(62.47,"AG",X))
if X=""
QUIT
if CNT>1
QUIT
SET CNT=CNT+1
+6 IF CNT=0
WRITE !,"No entries to display."
QUIT
+7 ;
IF CNT=1
Begin DoDot:1
+8 SET R6248=$ORDER(^LAB(62.47,"AG",0))
End DoDot:1
+9 ;
+10 ;
IF CNT>1
Begin DoDot:1
+11 SET DIR(0)="Y"
+12 SET DIR("A")="Print All Message Configurations? "
+13 SET DIR("B")="N"
+14 SET DIR("?")="Print all codes associated with all message configurations."
+15 DO ^DIR
+16 SET R6248=0
+17 ;
IF Y=0
Begin DoDot:2
+18 NEW DIC
+19 SET DIC=62.48
+20 SET DIC(0)="AENOQ"
+21 SET DIC("S")="I $D(^LAB(62.47,""AG"",+Y))"
+22 DO ^DIC
+23 KILL DIC
+24 SET R6248=+Y
End DoDot:2
if R6248'>0
QUIT
+25 ;
End DoDot:1
+26 if R6248<0
QUIT
+27 SET X="P1^LA7VLCM2("_R6248_")"
+28 SET QUE=$$QUE^LA7VLCM1(X,"Print Codes from #62.47")
+29 IF QUE=-1
QUIT
+30 IF 'QUE
DO P1(R6248)
+31 QUIT
+32 ;
P1(R6248) ;
+1 ; Print codes based on Message Config (R6248)
+2 NEW EXIT,LINE,LINE2,NOW,PAGE,EOP,START,TITLE
+3 NEW R6247,R624701,DFL,IORVON,IORVOFF,X,CODE,CODSET,CONCLAST
+4 NEW TMPNM
+5 SET TMPNM="LA7VLCM2-P1A"
+6 KILL ^TMP(TMPNM,$JOB)
+7 DO INIT^LA7VLCM1
+8 SET EOP=5
+9 SET TITLE="LAB CODE MAPPING (BY MSG CONFIG)"
+10 SET X="IORVON;IORVOFF"
+11 ;
Begin DoDot:1
+12 NEW %ZIS
+13 DO ENDR^%ZISS
End DoDot:1
+14 ; get max field sizes
+15 SET R6247=0
+16 ;
FOR
SET R6247=$ORDER(^LAB(62.47,R6247))
if 'R6247
QUIT
Begin DoDot:1
+17 DO DFL^LA7VLCM1(R6247,.DFL)
End DoDot:1
+18 SET R6247=0
+19 SET START=1
+20 DO HDR^LA7VLCM1(.DFL,TITLE)
+21 ;
IF 'R6248
Begin DoDot:1
+22 ;go thru Msg Configs in alpha order
+23 NEW MSGCFG
+24 SET MSGCFG=""
+25 ;
FOR
SET MSGCFG=$ORDER(^LAHM(62.48,"B",MSGCFG))
if MSGCFG=""
QUIT
Begin DoDot:2
+26 SET R6248=$ORDER(^LAHM(62.48,"B",MSGCFG,0))
+27 if 'R6248
QUIT
+28 DO P1A(R6248)
End DoDot:2
if EXIT
QUIT
+29 ;
+30 SET R6248=0
End DoDot:1
+31 ;
+32 ;
IF R6248
Begin DoDot:1
+33 DO P1A(R6248)
End DoDot:1
+34 ;
+35 DO P1DISP
+36 KILL ^TMP("LA7VLCM2-P1A",$JOB)
+37 DO CLEAN^LA7VLCM1
+38 QUIT
+39 ;
P1A(R6248) ;
+1 ; Helper method for P1
+2 ; Creates then steps through its ^TMP global and then
+3 ; calls the display method
+4 NEW R6247,R624701,NODE,X,CODE,CODSET,MSGCFG
+5 NEW TMPNM
+6 SET TMPNM="LA7VLCM2-P1A"
+7 SET R6247=0
+8 SET NODE="^LAB(62.47,""AG"",R6248)"
+9 ;
FOR
SET NODE=$QUERY(@NODE)
if NODE=""
QUIT
if $QSUBSCRIPT(NODE,3)'=R6248
QUIT
if $QSUBSCRIPT(NODE,2)'="AG"
QUIT
if $QSUBSCRIPT(NODE,1)'=62.47
QUIT
Begin DoDot:1
+10 SET R6247=$QSUBSCRIPT(NODE,4)
+11 SET R624701=$QSUBSCRIPT(NODE,5)
+12 ;create sort global
+13 SET X=$GET(^LAB(62.47,R6247,1,R624701,0))
+14 SET CODE=$PIECE(X,U,1)
+15 SET CODSET=$PIECE(X,U,2)
+16 if CODE=""
SET CODE="??"
if CODSET=""
SET CODSET="??"
+17 SET X=$GET(^LAHM(62.48,R6248,0))
+18 SET MSGCFG=$PIECE(X,U,1)
+19 SET ^TMP(TMPNM,$JOB,R6247,MSGCFG,R6248,CODE,CODSET,R624701)=""
End DoDot:1
+20 QUIT
+21 ;
P1DISP ;
+1 ; Utility display function for P1 (above)
+2 ; now go thru sorted codes for display
+3 ; ^TMP("LA7VLCM2-P1",$J,R6247,MSGCFG,R6248,CODE,CODSET,R624701)=""
+4 NEW NODE,R6248,R6247,R624701,LASTCONC
+5 NEW TMPNM
+6 SET TMPNM="LA7VLCM2-P1A"
+7 ;Last Concept printed
SET LASTCONC=0
+8 SET NODE="^TMP(TMPNM,$J)"
+9 ;
FOR
SET NODE=$QUERY(@NODE)
if NODE=""
QUIT
if $QSUBSCRIPT(NODE,2)'=$JOB
QUIT
if $QSUBSCRIPT(NODE,1)'=TMPNM
QUIT
Begin DoDot:1
+10 SET R6248=$QSUBSCRIPT(NODE,5)
+11 SET R6247=$QSUBSCRIPT(NODE,3)
+12 SET R624701=$QSUBSCRIPT(NODE,8)
+13 if 'R624701
QUIT
+14 ;
IF LASTCONC'=R6247
Begin DoDot:2
+15 IF LASTCONC'=0
WRITE !
+16 DO RVID^LA7VLCM1(1)
+17 WRITE !,"CONCEPT:",$$GET1^DIQ(62.47,R6247_",",".01","E","","")
+18 WRITE " (",$$GET1^DIQ(62.47,R6247_",",".02","I","",""),")"
+19 IF $EXTRACT($GET(IOST),1,2)="C-"
WRITE $$RJ^XLFSTR("",IOM-$X," ")
+20 DO RVID^LA7VLCM1(0)
+21 SET LASTCONC=R6247
End DoDot:2
+22 DO SUB^LA7VLCM1(.DFL,R6247,,R624701)
+23 ;
End DoDot:1
if EXIT
QUIT
+24 KILL ^TMP(TMPNM,$JOB)
+25 QUIT
+26 ;
E2 ;
+1 ; Print #62.47 entries with bad IDENTIFIER/CODE SYSTEM mappings
+2 NEW X,Y,CNT,QUE,DIR
+3 SET (X,CNT)=0
+4 SET X="P2^LA7VLCM2(1)"
+5 SET QUE=$$QUE^LA7VLCM1(X,"Code/Set mismatches in #62.47")
+6 IF QUE=-1
QUIT
+7 IF 'QUE
DO P2(0)
+8 QUIT
+9 ;
P2(QUE) ;
+1 ; Print entries with bad IDENTIFIER/CODE SYS mappings
+2 ; Inputs
+3 ; QUE 1=was queued
+4 NEW EXIT,LINE,LINE2,NOW,PAGE,EOP,START,TITLE
+5 NEW R6247,R624701,DFL,IORVON,IORVOFF,X,TMPNM
+6 NEW CODE,CS,CONCLAST,NODE,LADOT
+7 NEW TMPNM
+8 SET QUE=+$GET(QUE)
+9 SET TMPNM="LA7VLCM2-P2"
+10 KILL ^TMP(TMPNM,$JOB)
+11 DO INIT^LA7VLCM1
+12 SET EOP=5
+13 SET TITLE="LAB CODE MAPPING (CODE/SET MISMATCHES)"
+14 SET X="IORVON;IORVOFF"
+15 ;
Begin DoDot:1
+16 NEW %ZIS
+17 DO ENDR^%ZISS
End DoDot:1
+18 ; get max field sizes
+19 SET R6247=0
+20 ;
FOR
SET R6247=$ORDER(^LAB(62.47,R6247))
if 'R6247
QUIT
Begin DoDot:1
+21 DO DFL^LA7VLCM1(R6247,.DFL)
End DoDot:1
+22 SET R6247=0
+23 SET START=1
+24 ; build list
+25 IF 'QUE
DO WAIT^DICD
+26 SET LADOT=$HOROLOG
+27 SET NODE="^LAB(62.47,""AF"")"
+28 ;
FOR
SET NODE=$QUERY(@NODE)
if NODE=""
QUIT
if $QSUBSCRIPT(NODE,2)'="AF"
QUIT
Begin DoDot:1
+29 SET CS=$QSUBSCRIPT(NODE,3)
+30 SET CODE=$QSUBSCRIPT(NODE,4)
+31 SET R6247=$QSUBSCRIPT(NODE,5)
+32 SET R624701=$QSUBSCRIPT(NODE,6)
+33 IF 'QUE
DO PROGRESS^LA7VLCM1(.LADOT)
+34 if $$CODSETOK^LA7VLCM3("","",CODE,CS,0)
QUIT
+35 SET ^TMP(TMPNM,$JOB,R6247,CODE,CS,R624701)=""
End DoDot:1
+36 DO HDR^LA7VLCM1(.DFL,TITLE)
+37 SET NODE="^TMP(TMPNM,$J)"
+38 SET CONCLAST=0
+39 ;
FOR
SET NODE=$QUERY(@NODE)
if NODE=""
QUIT
if $QSUBSCRIPT(NODE,1)'=TMPNM
QUIT
if $QSUBSCRIPT(NODE,2)'=$JOB
QUIT
Begin DoDot:1
+40 IF CONCLAST'=0
WRITE !
+41 SET R6247=$QSUBSCRIPT(NODE,3)
+42 SET CODE=$QSUBSCRIPT(NODE,4)
+43 SET CS=$QSUBSCRIPT(NODE,5)
+44 SET R624701=$QSUBSCRIPT(NODE,6)
+45 SET CONCLAST=R6247
+46 DO RVID^LA7VLCM1(1)
+47 WRITE !,"CONCEPT:",$$GET1^DIQ(62.47,R6247_",",".01","E","","")
+48 WRITE " (",$$GET1^DIQ(62.47,R6247_",",".02","I","",""),")"
+49 IF $EXTRACT($GET(IOST),1,2)="C-"
WRITE $$RJ^XLFSTR("",IOM-$X," ")
+50 DO RVID^LA7VLCM1(0)
+51 DO SUB^LA7VLCM1(.DFL,R6247,,R624701)
End DoDot:1
if EXIT
QUIT
+52 IF CONCLAST=0
WRITE !!," No exceptions found."
+53 ;
+54 KILL ^TMP(TMPNM,$JOB)
+55 DO CLEAN^LA7VLCM1
+56 QUIT
