LA7VLCM6 ;DALOI/JDB - LAB CODE MAPPING FILE UTILITIES ;03/07/12 15:51
;;5.2;AUTOMATED LAB INSTRUMENTS;**74**;Sep 27, 1994;Build 229
;
Q
; Ex subs are the main entry points from menus, etc..
; Px subs are the main workhorse (called from Ex)
E0 ;
; Individual CONCEPT from #62.47 file
N DIC,X,Y,ZTQUEUED,ZTSAVE
N R6247
W !
S DIC="^LAB(62.47,"
S DIC(0)="AEMQ"
D ^DIC
I Y<1 Q
S R6247=+Y
S X="SUB^LA7VLCM6("_R6247_")"
S ZTSAVE("R6247")=""
S X=$$QUE^LA7VLCM1(X,"Print CONCEPT from #62.47",.ZTSAVE)
I X=-1 Q
I X=0 D P0(R6247) Q
Q
;
E1 ;
; Display CONCEPT SUSC MAPPINGS #7 & #21 from File #62.47
N X,Y,DIR,SHOW,MSGCFG,CODSET
N DTOUT,DUOUT,DIRUT,DIROUT
S SHOW="A"
S DIR(0)="SB^A:ALL;M:MAPPED;U:UNAMPPED"
S DIR("A")="Print (A)ll, (M)apped, (U)nmapped"
S DIR("B")="A"
S DIR("?")="Mapped/Unmapped refers to entries that have their RELATED ENTRY field either set or not set."
D ^DIR
I $E(Y,1,1)="^" Q
I "^A^M^U^"'[("^"_Y_"^") S Y="A"
S SHOW=Y
; Select a Message Config
; xref=^LAB(62.47,"AG",R6248,R6247,R624701)
;
; Select a Code Set
; xref=^LAB(62.47,R6247,1,"C",Code Set,DA)
;
S X="P1^LA7VLCM6("_SHOW_")"
S X=$$QUE^LA7VLCM1(X,"Print SUSC from #62.47")
I X=-1 Q
I X=0 D P1(SHOW)
Q
;
E2 ;
; Display all LOCAL codes in File #62.47
N X
S X="P2^LA7VLCM6"
S X=$$QUE^LA7VLCM1(X,"Print LOCAL CODES from #62.47")
I X=-1 Q
I X=0 D P2 Q
Q
;
P0(R6247) ;
; Display individual CONCEPT
N EXIT,LINE,LINE2,NOW,PAGE,EOP,TITLE
N DFL
D INIT^LA7VLCM1
S EOP=5 ;line padding at end of page
D DFL^LA7VLCM1(R6247,.DFL)
D HDR^LA7VLCM1(.DFL,"")
D SUB^LA7VLCM1(.DFL,R6247)
Q
;
P1(SHOW) ;
; Display #7 and #21 Susceptibilities
; Inputs
; SHOW :<opt> Show all or partial matches (entry has RELATED FILE?)
; : A=all<default> M=mapped U=unmapped
;
N EXIT,LINE,LINE2,NOW,PAGE,EOP,TITLE
N R6247,R624701,DFL,IORVOFF,IORVON,X,CODE,NODE
S SHOW=$G(SHOW,"A")
D INIT^LA7VLCM1
S X="IORVON;IORVOFF"
D ;
. N %ZIS
. D ENDR^%ZISS
S TITLE="LAB CODE MAPPING -- SUSCEPTIBILITIES"
S EOP=5
; get max field sizes
F R6247=7,21 D ;
. D DFL^LA7VLCM1(R6247,.DFL)
D HDR^LA7VLCM1(.DFL,TITLE)
F R6247=7,21 D Q:EXIT ;
. I R6247'=7 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)
. I SHOW="A" D Q ;
. . D SUB^LA7VLCM1(.DFL,R6247)
. I SHOW'="A" D Q ;
. . S CODE=""
. . S R624701=0
. . S NODE="^LAB(62.47,R6247,1,""B"")"
. . F S NODE=$Q(@NODE) Q:NODE="" Q:$QS(NODE,4)'="B" Q:$QS(NODE,3)'=1 Q:$QS(NODE,2)'=R6247 Q:EXIT D ;
. . . S CODE=$QS(NODE,5)
. . . S R624701=$QS(NODE,6)
. . . Q:'R624701
. . . S X=$G(^LAB(62.47,R6247,1,R624701,2))
. . . S X=$P(X,U,1)
. . . I SHOW="M" Q:X="" ;mapped
. . . I SHOW="U" Q:X'="" ;unmapped
. . . D SUB^LA7VLCM1(.DFL,R6247,,R624701)
. . ;
. ;
D CLEAN^LA7VLCM1
Q
;
P2 ;
; Display all Local Codes
N EXIT,LINE,LINE2,NOW,PAGE,EOP,START,TITLE
N R6247,R624701,DFL,IORVON,IORVOFF,X,CODE,CODSET
D INIT^LA7VLCM1
S EOP=5
S TITLE="LAB CODE MAPPING -- LOCAL CODES"
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)
F S R6247=$O(^LAB(62.47,R6247)) Q:'R6247 D Q:EXIT ;
. ; does this R6247 have any Local codes?
. I '$O(^LAB(62.47,R6247,1,"AC",0,0)) Q
. I 'START 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)
. K ^TMP("LA7VLCM6-P2",$J)
. S R624701=0
. ;create sort global
. F S R624701=$O(^LAB(62.47,R6247,1,"AC",0,R624701)) Q:'R624701 D ;
. . 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 ^TMP("LA7VLCM6-P2",$J,CODE,CODSET,R624701)=""
. ;now go thru sorted codes for display
. S NODE="^TMP(""LA7VLCM6-P2"",$J)"
. F S NODE=$Q(@NODE) Q:NODE="" Q:$QS(NODE,2)'=$J Q:$QS(NODE,1)'="LA7VLCM6-P2" D Q:EXIT ;
. . S R624701=$QS(NODE,5)
. . Q:'R624701
. . D SUB^LA7VLCM1(.DFL,R6247,,R624701)
. S START=0
. K ^TMP("LA7VLCM6-P2",$J)
. ;
D CLEAN^LA7VLCM1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLA7VLCM6 4531 printed Oct 16, 2024@17:41:33 Page 2
LA7VLCM6 ;DALOI/JDB - LAB CODE MAPPING FILE UTILITIES ;03/07/12 15:51
+1 ;;5.2;AUTOMATED LAB INSTRUMENTS;**74**;Sep 27, 1994;Build 229
+2 ;
+3 QUIT
+4 ; Ex subs are the main entry points from menus, etc..
+5 ; Px subs are the main workhorse (called from Ex)
E0 ;
+1 ; Individual CONCEPT from #62.47 file
+2 NEW DIC,X,Y,ZTQUEUED,ZTSAVE
+3 NEW R6247
+4 WRITE !
+5 SET DIC="^LAB(62.47,"
+6 SET DIC(0)="AEMQ"
+7 DO ^DIC
+8 IF Y<1
QUIT
+9 SET R6247=+Y
+10 SET X="SUB^LA7VLCM6("_R6247_")"
+11 SET ZTSAVE("R6247")=""
+12 SET X=$$QUE^LA7VLCM1(X,"Print CONCEPT from #62.47",.ZTSAVE)
+13 IF X=-1
QUIT
+14 IF X=0
DO P0(R6247)
QUIT
+15 QUIT
+16 ;
E1 ;
+1 ; Display CONCEPT SUSC MAPPINGS #7 & #21 from File #62.47
+2 NEW X,Y,DIR,SHOW,MSGCFG,CODSET
+3 NEW DTOUT,DUOUT,DIRUT,DIROUT
+4 SET SHOW="A"
+5 SET DIR(0)="SB^A:ALL;M:MAPPED;U:UNAMPPED"
+6 SET DIR("A")="Print (A)ll, (M)apped, (U)nmapped"
+7 SET DIR("B")="A"
+8 SET DIR("?")="Mapped/Unmapped refers to entries that have their RELATED ENTRY field either set or not set."
+9 DO ^DIR
+10 IF $EXTRACT(Y,1,1)="^"
QUIT
+11 IF "^A^M^U^"'[("^"_Y_"^")
SET Y="A"
+12 SET SHOW=Y
+13 ; Select a Message Config
+14 ; xref=^LAB(62.47,"AG",R6248,R6247,R624701)
+15 ;
+16 ; Select a Code Set
+17 ; xref=^LAB(62.47,R6247,1,"C",Code Set,DA)
+18 ;
+19 SET X="P1^LA7VLCM6("_SHOW_")"
+20 SET X=$$QUE^LA7VLCM1(X,"Print SUSC from #62.47")
+21 IF X=-1
QUIT
+22 IF X=0
DO P1(SHOW)
+23 QUIT
+24 ;
E2 ;
+1 ; Display all LOCAL codes in File #62.47
+2 NEW X
+3 SET X="P2^LA7VLCM6"
+4 SET X=$$QUE^LA7VLCM1(X,"Print LOCAL CODES from #62.47")
+5 IF X=-1
QUIT
+6 IF X=0
DO P2
QUIT
+7 QUIT
+8 ;
P0(R6247) ;
+1 ; Display individual CONCEPT
+2 NEW EXIT,LINE,LINE2,NOW,PAGE,EOP,TITLE
+3 NEW DFL
+4 DO INIT^LA7VLCM1
+5 ;line padding at end of page
SET EOP=5
+6 DO DFL^LA7VLCM1(R6247,.DFL)
+7 DO HDR^LA7VLCM1(.DFL,"")
+8 DO SUB^LA7VLCM1(.DFL,R6247)
+9 QUIT
+10 ;
P1(SHOW) ;
+1 ; Display #7 and #21 Susceptibilities
+2 ; Inputs
+3 ; SHOW :<opt> Show all or partial matches (entry has RELATED FILE?)
+4 ; : A=all<default> M=mapped U=unmapped
+5 ;
+6 NEW EXIT,LINE,LINE2,NOW,PAGE,EOP,TITLE
+7 NEW R6247,R624701,DFL,IORVOFF,IORVON,X,CODE,NODE
+8 SET SHOW=$GET(SHOW,"A")
+9 DO INIT^LA7VLCM1
+10 SET X="IORVON;IORVOFF"
+11 ;
Begin DoDot:1
+12 NEW %ZIS
+13 DO ENDR^%ZISS
End DoDot:1
+14 SET TITLE="LAB CODE MAPPING -- SUSCEPTIBILITIES"
+15 SET EOP=5
+16 ; get max field sizes
+17 ;
FOR R6247=7,21
Begin DoDot:1
+18 DO DFL^LA7VLCM1(R6247,.DFL)
End DoDot:1
+19 DO HDR^LA7VLCM1(.DFL,TITLE)
+20 ;
FOR R6247=7,21
Begin DoDot:1
+21 IF R6247'=7
WRITE !
+22 DO RVID^LA7VLCM1(1)
+23 WRITE !,"CONCEPT:",$$GET1^DIQ(62.47,R6247_",",".01","E","","")
+24 WRITE " (",$$GET1^DIQ(62.47,R6247_",",".02","I","",""),")"
+25 IF $EXTRACT($GET(IOST),1,2)="C-"
WRITE $$RJ^XLFSTR("",IOM-$X," ")
+26 DO RVID^LA7VLCM1(0)
+27 ;
IF SHOW="A"
Begin DoDot:2
+28 DO SUB^LA7VLCM1(.DFL,R6247)
End DoDot:2
QUIT
+29 ;
IF SHOW'="A"
Begin DoDot:2
+30 SET CODE=""
+31 SET R624701=0
+32 SET NODE="^LAB(62.47,R6247,1,""B"")"
+33 ;
FOR
SET NODE=$QUERY(@NODE)
if NODE=""
QUIT
if $QSUBSCRIPT(NODE,4)'="B"
QUIT
if $QSUBSCRIPT(NODE,3)'=1
QUIT
if $QSUBSCRIPT(NODE,2)'=R6247
QUIT
if EXIT
QUIT
Begin DoDot:3
+34 SET CODE=$QSUBSCRIPT(NODE,5)
+35 SET R624701=$QSUBSCRIPT(NODE,6)
+36 if 'R624701
QUIT
+37 SET X=$GET(^LAB(62.47,R6247,1,R624701,2))
+38 SET X=$PIECE(X,U,1)
+39 ;mapped
IF SHOW="M"
if X=""
QUIT
+40 ;unmapped
IF SHOW="U"
if X'=""
QUIT
+41 DO SUB^LA7VLCM1(.DFL,R6247,,R624701)
End DoDot:3
+42 ;
End DoDot:2
QUIT
+43 ;
End DoDot:1
if EXIT
QUIT
+44 DO CLEAN^LA7VLCM1
+45 QUIT
+46 ;
P2 ;
+1 ; Display all Local Codes
+2 NEW EXIT,LINE,LINE2,NOW,PAGE,EOP,START,TITLE
+3 NEW R6247,R624701,DFL,IORVON,IORVOFF,X,CODE,CODSET
+4 DO INIT^LA7VLCM1
+5 SET EOP=5
+6 SET TITLE="LAB CODE MAPPING -- LOCAL CODES"
+7 SET X="IORVON;IORVOFF"
+8 ;
Begin DoDot:1
+9 NEW %ZIS
+10 DO ENDR^%ZISS
End DoDot:1
+11 ; get max field sizes
+12 SET R6247=0
+13 ;
FOR
SET R6247=$ORDER(^LAB(62.47,R6247))
if 'R6247
QUIT
Begin DoDot:1
+14 DO DFL^LA7VLCM1(R6247,.DFL)
End DoDot:1
+15 SET R6247=0
+16 SET START=1
+17 DO HDR^LA7VLCM1(.DFL,TITLE)
+18 ;
FOR
SET R6247=$ORDER(^LAB(62.47,R6247))
if 'R6247
QUIT
Begin DoDot:1
+19 ; does this R6247 have any Local codes?
+20 IF '$ORDER(^LAB(62.47,R6247,1,"AC",0,0))
QUIT
+21 IF 'START
WRITE !
+22 DO RVID^LA7VLCM1(1)
+23 WRITE !,"CONCEPT:",$$GET1^DIQ(62.47,R6247_",",".01","E","","")
+24 WRITE " (",$$GET1^DIQ(62.47,R6247_",",".02","I","",""),")"
+25 IF $EXTRACT($GET(IOST),1,2)="C-"
WRITE $$RJ^XLFSTR("",IOM-$X," ")
+26 DO RVID^LA7VLCM1(0)
+27 KILL ^TMP("LA7VLCM6-P2",$JOB)
+28 SET R624701=0
+29 ;create sort global
+30 ;
FOR
SET R624701=$ORDER(^LAB(62.47,R6247,1,"AC",0,R624701))
if 'R624701
QUIT
Begin DoDot:2
+31 SET X=$GET(^LAB(62.47,R6247,1,R624701,0))
+32 SET CODE=$PIECE(X,U,1)
+33 SET CODSET=$PIECE(X,U,2)
+34 if CODE=""
SET CODE="??"
if CODSET=""
SET CODSET="??"
SET ^TMP("LA7VLCM6-P2",$JOB,CODE,CODSET,R624701)=""
End DoDot:2
+35 ;now go thru sorted codes for display
+36 SET NODE="^TMP(""LA7VLCM6-P2"",$J)"
+37 ;
FOR
SET NODE=$QUERY(@NODE)
if NODE=""
QUIT
if $QSUBSCRIPT(NODE,2)'=$JOB
QUIT
if $QSUBSCRIPT(NODE,1)'="LA7VLCM6-P2"
QUIT
Begin DoDot:2
+38 SET R624701=$QSUBSCRIPT(NODE,5)
+39 if 'R624701
QUIT
+40 DO SUB^LA7VLCM1(.DFL,R6247,,R624701)
End DoDot:2
if EXIT
QUIT
+41 SET START=0
+42 KILL ^TMP("LA7VLCM6-P2",$JOB)
+43 ;
End DoDot:1
if EXIT
QUIT
+44 DO CLEAN^LA7VLCM1
+45 QUIT
