LA7VLCM4 ;DALOI/JDB - LAB CODE MAPPING FILE UTILITIES ;03/07/12 12:29
;;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 specific IDENTIFIER in #62.47
N CODE,X,DATA
S X=$$FINDID(.DATA)
Q:'X
S CODE=DATA(1)
S X="P1^LA7VLCM4("_CODE_")"
S QUE=$$QUE^LA7VLCM1(X,"Find Identifier from #62.47")
I QUE=-1 Q
I 'QUE D P1(CODE)
Q
;
P1(CODE) ;
; Print code based on Message Config (R6248)
; Inputs
; CODE The code (IDENTIFIER) to display
N EXIT,LINE,LINE2,NOW,PAGE,EOP,START,TITLE
N R6247,R624701,DFL,IORVON,IORVOFF,X,CODSET,CONCLAST
N TMPNM,MSGCFG,LAMSG
S TMPNM="LA7VLCM4-P1"
K ^TMP(TMPNM,$J)
D INIT^LA7VLCM1
S EOP=5
S TITLE="LAB CODE MAPPING ("_CODE_")"
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)
; find matching records
S NODE="^LAB(62.47,""AH"",CODE)"
F S NODE=$Q(@NODE) Q:NODE="" Q:$QS(NODE,2)'="AH" Q:$QS(NODE,3)'=CODE D ;
. S R6247=$QS(NODE,4)
. S R624701=$QS(NODE,5)
. S X=$G(^LAB(62.47,R6247,1,R624701,0))
. S CS=$P(X,U,2)
. S:CS="" CS=" "
. S MSGCFG=$$GET1^DIQ(62.4701,R624701_","_R6247_",",2.2,"","LAMSG")
. S:MSGCFG="" MSGCFG=" "
. S ^TMP(TMPNM,$J,R6247,CODE,CS,MSGCFG,R624701)=""
;
D P1DISP
K ^TMP("LA7VLCM4-P1",$J)
D CLEAN^LA7VLCM1
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,R6247,R624701,LASTCONC
N TMPNM
S TMPNM="LA7VLCM4-P1"
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 R6247=$QS(NODE,3)
. S R624701=$QS(NODE,7)
. 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
;
FINDID(DATA) ;
; Driver used with LOOKUP^LA7VLCM5 to emulate a DIC call
; so users can select IDENTIFIERS from entire file.
; Inputs
; DATA <byref> See Outputs below
;
; Outputs
; Returns #62.47 IEN_"^"_#62.4701 IEN or "0^0" if no selection
; DATA(1) = Selection's text
; DATA(2) = Global node
;
N IN,DIR,STOP,Y,LIST,SEL,NODE,FOUND
N GBL,OUT,USTAT,IDARR,SCRN
N R6247,R624701
K DATA
S FOUND=0
S (R6247,R624701)=0
S GBL="^LAB(62.47,""AH"","
S SCRN=""
S IDARR("NODE0")="^LAB(62.47,DA(1),1,DA,0)"
S IDARR("DA",0)=5
S IDARR("DA",1)=4
S STOP=0
;
F Q:STOP Q:FOUND D ;
. S GBL="^LAB(62.47,""AH"","
. K IDARR
. S IDARR("NODE0")="^LAB(62.47,DA(1),1,DA,0)"
. S IDARR("DA",0)=5
. S IDARR("DA",1)=4
. W !,"Select IDENTIFIER: "
. R IN:$G(DTIME,300)
. I '$T S STOP=1 Q
. I IN']"" S STOP=1 Q
. I $E(IN,1,1)="^" S STOP=1 Q
. I IN=" " D ;
. . ; space bar return
. . S X=$G(^TMP($J,"LA7VLCM4","SBR",DUZ))
. . I X'="" S IN=X W " ",X
. ;
. I IN="?" D Q ;
. . W !," Enter an IDENTIFIER to find"
. ;
. I $E(IN,1,2)="??" D ;
. . S FOUND=$$LOOKUP^LA7VLCM5(GBL,"??",.OUT,.USTAT,SCRN,.IDARR)
. . I USTAT="^" S STOP=1
. . Q:'FOUND
. . S SEL=OUT
. . S NODE=OUT(1)
. . S R6247=$QS(NODE,4)
. . S R624701=$QS(NODE,5)
. ;
. I 'FOUND I $E(IN,1,2)'="??" D ;
. . S FOUND=$$LOOKUP^LA7VLCM5(GBL,IN,.OUT,.USTAT,"",.IDARR)
. . S:USTAT="^" STOP=1
. . I 'FOUND I 'STOP D Q:STOP ;
. . . S GBL="^LAB(62.47,""AF"","""_IN_""""
. . . K IDARR
. . . S IDARR("NODE0")="^LAB(62.47,DA(1),1,DA,0)"
. . . S IDARR("DA",0)=6
. . . S IDARR("DA",1)=5
. . . S FOUND=$$LOOKUP^LA7VLCM5(GBL,"??",.OUT,.USTAT,"",.IDARR)
. . . S:USTAT="^" STOP="^"
. . I USTAT="^" S STOP=1
. . I 'FOUND D Q ;
. . . I 'STOP I USTAT<1 W $C(7)," ??"
. . ;
. . S SEL=OUT
. . S NODE=OUT(1)
. . S ^TMP($J,"LA7VLCM4","SBR",DUZ)=SEL ;space bar return
. . S R6247=$QS(NODE,4)
. . S R624701=$QS(NODE,5)
. ;
;
I FOUND D ;
. S DATA(1)=SEL
. S DATA(2)=NODE
Q R6247_"^"_R624701
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLA7VLCM4 4448 printed Apr 09, 2024@20:44:08 Page 2
LA7VLCM4 ;DALOI/JDB - LAB CODE MAPPING FILE UTILITIES ;03/07/12 12:29
+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 specific IDENTIFIER in #62.47
+2 NEW CODE,X,DATA
+3 SET X=$$FINDID(.DATA)
+4 if 'X
QUIT
+5 SET CODE=DATA(1)
+6 SET X="P1^LA7VLCM4("_CODE_")"
+7 SET QUE=$$QUE^LA7VLCM1(X,"Find Identifier from #62.47")
+8 IF QUE=-1
QUIT
+9 IF 'QUE
DO P1(CODE)
+10 QUIT
+11 ;
P1(CODE) ;
+1 ; Print code based on Message Config (R6248)
+2 ; Inputs
+3 ; CODE The code (IDENTIFIER) to display
+4 NEW EXIT,LINE,LINE2,NOW,PAGE,EOP,START,TITLE
+5 NEW R6247,R624701,DFL,IORVON,IORVOFF,X,CODSET,CONCLAST
+6 NEW TMPNM,MSGCFG,LAMSG
+7 SET TMPNM="LA7VLCM4-P1"
+8 KILL ^TMP(TMPNM,$JOB)
+9 DO INIT^LA7VLCM1
+10 SET EOP=5
+11 SET TITLE="LAB CODE MAPPING ("_CODE_")"
+12 SET X="IORVON;IORVOFF"
+13 ;
Begin DoDot:1
+14 NEW %ZIS
+15 DO ENDR^%ZISS
End DoDot:1
+16 ; get max field sizes
+17 SET R6247=0
+18 ;
FOR
SET R6247=$ORDER(^LAB(62.47,R6247))
if 'R6247
QUIT
Begin DoDot:1
+19 DO DFL^LA7VLCM1(R6247,.DFL)
End DoDot:1
+20 SET R6247=0
+21 SET START=1
+22 DO HDR^LA7VLCM1(.DFL,TITLE)
+23 ; find matching records
+24 SET NODE="^LAB(62.47,""AH"",CODE)"
+25 ;
FOR
SET NODE=$QUERY(@NODE)
if NODE=""
QUIT
if $QSUBSCRIPT(NODE,2)'="AH"
QUIT
if $QSUBSCRIPT(NODE,3)'=CODE
QUIT
Begin DoDot:1
+26 SET R6247=$QSUBSCRIPT(NODE,4)
+27 SET R624701=$QSUBSCRIPT(NODE,5)
+28 SET X=$GET(^LAB(62.47,R6247,1,R624701,0))
+29 SET CS=$PIECE(X,U,2)
+30 if CS=""
SET CS=" "
+31 SET MSGCFG=$$GET1^DIQ(62.4701,R624701_","_R6247_",",2.2,"","LAMSG")
+32 if MSGCFG=""
SET MSGCFG=" "
+33 SET ^TMP(TMPNM,$JOB,R6247,CODE,CS,MSGCFG,R624701)=""
End DoDot:1
+34 ;
+35 DO P1DISP
+36 KILL ^TMP("LA7VLCM4-P1",$JOB)
+37 DO CLEAN^LA7VLCM1
+38 QUIT
+39 ;
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,R6247,R624701,LASTCONC
+5 NEW TMPNM
+6 SET TMPNM="LA7VLCM4-P1"
+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 R6247=$QSUBSCRIPT(NODE,3)
+11 SET R624701=$QSUBSCRIPT(NODE,7)
+12 if 'R624701
QUIT
+13 ;
IF LASTCONC'=R6247
Begin DoDot:2
+14 IF LASTCONC'=0
WRITE !
+15 DO RVID^LA7VLCM1(1)
+16 WRITE !,"CONCEPT:",$$GET1^DIQ(62.47,R6247_",",".01","E","","")
+17 WRITE " (",$$GET1^DIQ(62.47,R6247_",",".02","I","",""),")"
+18 IF $EXTRACT($GET(IOST),1,2)="C-"
WRITE $$RJ^XLFSTR("",IOM-$X," ")
+19 DO RVID^LA7VLCM1(0)
+20 SET LASTCONC=R6247
End DoDot:2
+21 DO SUB^LA7VLCM1(.DFL,R6247,,R624701)
+22 ;
End DoDot:1
if EXIT
QUIT
+23 KILL ^TMP(TMPNM,$JOB)
+24 QUIT
+25 ;
FINDID(DATA) ;
+1 ; Driver used with LOOKUP^LA7VLCM5 to emulate a DIC call
+2 ; so users can select IDENTIFIERS from entire file.
+3 ; Inputs
+4 ; DATA <byref> See Outputs below
+5 ;
+6 ; Outputs
+7 ; Returns #62.47 IEN_"^"_#62.4701 IEN or "0^0" if no selection
+8 ; DATA(1) = Selection's text
+9 ; DATA(2) = Global node
+10 ;
+11 NEW IN,DIR,STOP,Y,LIST,SEL,NODE,FOUND
+12 NEW GBL,OUT,USTAT,IDARR,SCRN
+13 NEW R6247,R624701
+14 KILL DATA
+15 SET FOUND=0
+16 SET (R6247,R624701)=0
+17 SET GBL="^LAB(62.47,""AH"","
+18 SET SCRN=""
+19 SET IDARR("NODE0")="^LAB(62.47,DA(1),1,DA,0)"
+20 SET IDARR("DA",0)=5
+21 SET IDARR("DA",1)=4
+22 SET STOP=0
+23 ;
+24 ;
FOR
if STOP
QUIT
if FOUND
QUIT
Begin DoDot:1
+25 SET GBL="^LAB(62.47,""AH"","
+26 KILL IDARR
+27 SET IDARR("NODE0")="^LAB(62.47,DA(1),1,DA,0)"
+28 SET IDARR("DA",0)=5
+29 SET IDARR("DA",1)=4
+30 WRITE !,"Select IDENTIFIER: "
+31 READ IN:$GET(DTIME,300)
+32 IF '$TEST
SET STOP=1
QUIT
+33 IF IN']""
SET STOP=1
QUIT
+34 IF $EXTRACT(IN,1,1)="^"
SET STOP=1
QUIT
+35 ;
IF IN=" "
Begin DoDot:2
+36 ; space bar return
+37 SET X=$GET(^TMP($JOB,"LA7VLCM4","SBR",DUZ))
+38 IF X'=""
SET IN=X
WRITE " ",X
End DoDot:2
+39 ;
+40 ;
IF IN="?"
Begin DoDot:2
+41 WRITE !," Enter an IDENTIFIER to find"
End DoDot:2
QUIT
+42 ;
+43 ;
IF $EXTRACT(IN,1,2)="??"
Begin DoDot:2
+44 SET FOUND=$$LOOKUP^LA7VLCM5(GBL,"??",.OUT,.USTAT,SCRN,.IDARR)
+45 IF USTAT="^"
SET STOP=1
+46 if 'FOUND
QUIT
+47 SET SEL=OUT
+48 SET NODE=OUT(1)
+49 SET R6247=$QSUBSCRIPT(NODE,4)
+50 SET R624701=$QSUBSCRIPT(NODE,5)
End DoDot:2
+51 ;
+52 ;
IF 'FOUND
IF $EXTRACT(IN,1,2)'="??"
Begin DoDot:2
+53 SET FOUND=$$LOOKUP^LA7VLCM5(GBL,IN,.OUT,.USTAT,"",.IDARR)
+54 if USTAT="^"
SET STOP=1
+55 ;
IF 'FOUND
IF 'STOP
Begin DoDot:3
+56 SET GBL="^LAB(62.47,""AF"","""_IN_""""
+57 KILL IDARR
+58 SET IDARR("NODE0")="^LAB(62.47,DA(1),1,DA,0)"
+59 SET IDARR("DA",0)=6
+60 SET IDARR("DA",1)=5
+61 SET FOUND=$$LOOKUP^LA7VLCM5(GBL,"??",.OUT,.USTAT,"",.IDARR)
+62 if USTAT="^"
SET STOP="^"
End DoDot:3
if STOP
QUIT
+63 IF USTAT="^"
SET STOP=1
+64 ;
IF 'FOUND
Begin DoDot:3
+65 IF 'STOP
IF USTAT<1
WRITE $CHAR(7)," ??"
End DoDot:3
QUIT
+66 ;
+67 SET SEL=OUT
+68 SET NODE=OUT(1)
+69 ;space bar return
SET ^TMP($JOB,"LA7VLCM4","SBR",DUZ)=SEL
+70 SET R6247=$QSUBSCRIPT(NODE,4)
+71 SET R624701=$QSUBSCRIPT(NODE,5)
End DoDot:2
+72 ;
End DoDot:1
+73 ;
+74 ;
IF FOUND
Begin DoDot:1
+75 SET DATA(1)=SEL
+76 SET DATA(2)=NODE
End DoDot:1
+77 QUIT R6247_"^"_R624701
+78 ;
