VAQDIS15 ;ALB/JFP - PDX,DISPLAY SEGMENTS FOR DISPLAY;01MAR93
;;1.5;PATIENT DATA EXCHANGE;**1,17**;NOV 17, 1993
EP ; -- Main entry point for the list processor
; -- K XQORS,VALMEVL (only kill on the first screen in)
D EN^VALM("VAQ DISPLAY SEGMENT PDX11") ; -- protocol = VAQ PDX11 (MENU)
;K VALMBCK
QUIT
;
INIT ; -- Initializes variables and defines screen
K ^TMP("VAQD2",$J)
S (VAQECNT,VALMCNT,SEGDE)=0
;
I '$D(^VAT(394.61,DFN,"SEG",0)) D QUIT
.S X=$$SETSTR^VALM1(" ","",1,79) D TMP
.S X=$$SETSTR^VALM1(" ** No Segment(s)... <Return> to exit ","",1,79)
.D TMP
;
F S SEGDE=$O(^VAT(394.61,DFN,"SEG","B",SEGDE)) Q:SEGDE="" D
.S SEGMNU=$P($G(^VAT(394.71,SEGDE,0)),U,2)
.S SEGNM=$P($G(^VAT(394.71,SEGDE,0)),U,1)
.S VAQECNT=VAQECNT+1
.S X=$$SETFLD^VALM1(VAQECNT,"","ENTRY")
.S X=$$SETFLD^VALM1(SEGMNU,X,"SEGMENTS")
.S X=$$SETFLD^VALM1(SEGNM,X,"SEGNAME")
.D TMP
QUIT
;
TMP ; -- Set the array used by list processor
S VALMCNT=VALMCNT+1
S ^TMP("VAQD2",$J,VALMCNT,0)=$E(X,1,79)
S ^TMP("VAQD2",$J,"IDX",VALMCNT,VAQECNT)=""
S ^TMP("VAQIDXSG",$J,VAQECNT)=SEGDE_"^"_SEGMNU
QUIT
;
HD ; -- Make header line for list processor
N X0,X1,X2
S X0=$$TRNDATA^VAQUTL92(VAQDFN) ; -- sets variable from transaction file
S X1=$$SETSTR^VALM1("Patient: "_VAQPTNM,"",1,41)
S X1=$$SETSTR^VALM1("Remote Domain: "_VAQADOM,X1,42,79)
S:VAQPTID="" X2=$$SETSTR^VALM1(" SSN: "_VAQESSN,"",1,41)
S:VAQPTID'="" X2=$$SETSTR^VALM1(" ID: "_VAQPTID,"",1,41)
S X2=$$SETSTR^VALM1(" Date/Time: "_VAQADT,X2,42,79)
;
S VALMHDR(1)=" "
S VALMHDR(2)=$E(X1,1,79)
S VALMHDR(3)=$E(X2,1,79)
;
D KILLTRN^VAQUTL92 ; -- cleans up variables set in TRNDATA CALL
K X0,X1,X2
QUIT
;
; ------------------------ PROTOCOLS -------------------------------
SEL ; -- Selected segment(s) for display
D SEL^VALM2
Q:'$D(VALMY)
S VALMCNT=1
S ROOT="^TMP(""VAQD3"",$J)" K @ROOT
D CLEAR^VALM1
S X=$$DEVICE^VAQDIS17("SEL")
; -- Added call to INIT to clear variables
I X=-1 W !,"Error in getting device" D INIT S VALMBCK="R" QUIT
I X=0 S VALMBCK="R" G SEL2 ; -- allows for re-selection
S ENTRY=""
F S ENTRY=$O(VALMY(ENTRY)) Q:ENTRY="" D BLDDIS
D ENDLN
D EP^VAQDIS16
SEL2 D INIT
S VALMBCK="R"
QUIT
;
ALL ; -- Selects all segments for display
I '$D(^TMP("VAQIDXSG",$J)) S VALMBCK="Q" QUIT
S VALMCNT=1
S ROOT="^TMP(""VAQD3"",$J)" K @ROOT
D CLEAR^VALM1
S X=$$DEVICE^VAQDIS17("ALL")
I X=-1 W !,"Error in getting device" D INIT S VALMBCK="R" QUIT
I X=0 K VALMBCK QUIT
S ENTRY=""
F S ENTRY=$O(^TMP("VAQIDXSG",$J,ENTRY)) Q:ENTRY="" D BLDDIS
D ENDLN
D EP^VAQDIS16
K VALMBCK
QUIT
;
TRANEX D PAUSE^VALM1
S VALMBCK=$S(VAQFLAG=0:"R",1:"Q")
QUIT
;
BLDDIS ; -- Builds display
D:$D(XRTL) T0^%ZOSV ; -- Capacity start
S SDAT=$G(^TMP("VAQIDXSG",$J,ENTRY))
S SEGDE=$P(SDAT,U,1)
S OFFSET=$$BLDDSP^VAQUPD2(DFN,SEGDE,ROOT,VALMCNT)
S:+OFFSET'=-1 VALMCNT=VALMCNT+OFFSET
I +OFFSET=-1 S ERRMSG=$P($G(OFFSET),U,2) D ERRMSG
;W !,"Segment = ",SEGDE," Offset = ",OFFSET," VALMCNT = ",VALMCNT
S:$D(XRT0) XRTN=$T(+0) D:$D(XRT0) T1^%ZOSV ; -- Capacity stop
QUIT
;
ERRMSG ; -- Displays a message if segment could be extracted
S EROOT=$$ROOT^VAQDIS20(ROOT)
S VAQSEGND=""
S:SEGDE'="" VAQSEGND=$G(^VAT(394.71,SEGDE,0))
S VAQLN=$$REPEAT^VAQUTL1("-",79)
S VAQCTR="< "_$S($P(VAQSEGND,"^",1)'="":$P(VAQSEGND,"^",1),1:"Segment Description Missing")_" >"
S X=$$CENTER^VAQDIS20(VAQLN,VAQCTR) D ETMP
S X=$$SETSTR^VALM1(" ","",1,79) D ETMP
S X=$$SETSTR^VALM1(" ** "_ERRMSG,"",1,79) D ETMP
S X=$$SETSTR^VALM1(" ","",1,79) D ETMP
S X=$$SETSTR^VALM1(" ","",1,79) D ETMP
S OFFSET=VALMCNT
K VAQLN,VAQCTR,VAQSEGND,X,EROOT
QUIT
;
ENDLN ; -- End of display
S EROOT=$$ROOT^VAQDIS20(ROOT)
S X=$$SETSTR^VALM1(" ","",1,79) D ETMP
S X=$$SETSTR^VALM1(" [ End of Data ]","",1,79) D ETMP
K EROOT
QUIT
;
ETMP ; -- Display for error message
S VALMCNT=VALMCNT+1
S @EROOT@(VALMCNT,0)=$E(X,1,79)
QUIT
;
EXIT ; -- Note: The list processor cleans up its own variables.
; All other variables cleaned up here.
;
K ^TMP("VAQD2",$J),^TMP("VAQIDXSG",$J)
K SEGDE,SEGMNU,SEGNM
K ROOT,OFFSET
Q
;
END ; -- End of code
QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVAQDIS15 4265 printed Sep 23, 2025@20:00:59 Page 2
VAQDIS15 ;ALB/JFP - PDX,DISPLAY SEGMENTS FOR DISPLAY;01MAR93
+1 ;;1.5;PATIENT DATA EXCHANGE;**1,17**;NOV 17, 1993
EP ; -- Main entry point for the list processor
+1 ; -- K XQORS,VALMEVL (only kill on the first screen in)
+2 ; -- protocol = VAQ PDX11 (MENU)
DO EN^VALM("VAQ DISPLAY SEGMENT PDX11")
+3 ;K VALMBCK
+4 QUIT
+5 ;
INIT ; -- Initializes variables and defines screen
+1 KILL ^TMP("VAQD2",$JOB)
+2 SET (VAQECNT,VALMCNT,SEGDE)=0
+3 ;
+4 IF '$DATA(^VAT(394.61,DFN,"SEG",0))
Begin DoDot:1
+5 SET X=$$SETSTR^VALM1(" ","",1,79)
DO TMP
+6 SET X=$$SETSTR^VALM1(" ** No Segment(s)... <Return> to exit ","",1,79)
+7 DO TMP
End DoDot:1
QUIT
+8 ;
+9 FOR
SET SEGDE=$ORDER(^VAT(394.61,DFN,"SEG","B",SEGDE))
if SEGDE=""
QUIT
Begin DoDot:1
+10 SET SEGMNU=$PIECE($GET(^VAT(394.71,SEGDE,0)),U,2)
+11 SET SEGNM=$PIECE($GET(^VAT(394.71,SEGDE,0)),U,1)
+12 SET VAQECNT=VAQECNT+1
+13 SET X=$$SETFLD^VALM1(VAQECNT,"","ENTRY")
+14 SET X=$$SETFLD^VALM1(SEGMNU,X,"SEGMENTS")
+15 SET X=$$SETFLD^VALM1(SEGNM,X,"SEGNAME")
+16 DO TMP
End DoDot:1
+17 QUIT
+18 ;
TMP ; -- Set the array used by list processor
+1 SET VALMCNT=VALMCNT+1
+2 SET ^TMP("VAQD2",$JOB,VALMCNT,0)=$EXTRACT(X,1,79)
+3 SET ^TMP("VAQD2",$JOB,"IDX",VALMCNT,VAQECNT)=""
+4 SET ^TMP("VAQIDXSG",$JOB,VAQECNT)=SEGDE_"^"_SEGMNU
+5 QUIT
+6 ;
HD ; -- Make header line for list processor
+1 NEW X0,X1,X2
+2 ; -- sets variable from transaction file
SET X0=$$TRNDATA^VAQUTL92(VAQDFN)
+3 SET X1=$$SETSTR^VALM1("Patient: "_VAQPTNM,"",1,41)
+4 SET X1=$$SETSTR^VALM1("Remote Domain: "_VAQADOM,X1,42,79)
+5 if VAQPTID=""
SET X2=$$SETSTR^VALM1(" SSN: "_VAQESSN,"",1,41)
+6 if VAQPTID'=""
SET X2=$$SETSTR^VALM1(" ID: "_VAQPTID,"",1,41)
+7 SET X2=$$SETSTR^VALM1(" Date/Time: "_VAQADT,X2,42,79)
+8 ;
+9 SET VALMHDR(1)=" "
+10 SET VALMHDR(2)=$EXTRACT(X1,1,79)
+11 SET VALMHDR(3)=$EXTRACT(X2,1,79)
+12 ;
+13 ; -- cleans up variables set in TRNDATA CALL
DO KILLTRN^VAQUTL92
+14 KILL X0,X1,X2
+15 QUIT
+16 ;
+17 ; ------------------------ PROTOCOLS -------------------------------
SEL ; -- Selected segment(s) for display
+1 DO SEL^VALM2
+2 if '$DATA(VALMY)
QUIT
+3 SET VALMCNT=1
+4 SET ROOT="^TMP(""VAQD3"",$J)"
KILL @ROOT
+5 DO CLEAR^VALM1
+6 SET X=$$DEVICE^VAQDIS17("SEL")
+7 ; -- Added call to INIT to clear variables
+8 IF X=-1
WRITE !,"Error in getting device"
DO INIT
SET VALMBCK="R"
QUIT
+9 ; -- allows for re-selection
IF X=0
SET VALMBCK="R"
GOTO SEL2
+10 SET ENTRY=""
+11 FOR
SET ENTRY=$ORDER(VALMY(ENTRY))
if ENTRY=""
QUIT
DO BLDDIS
+12 DO ENDLN
+13 DO EP^VAQDIS16
SEL2 DO INIT
+1 SET VALMBCK="R"
+2 QUIT
+3 ;
ALL ; -- Selects all segments for display
+1 IF '$DATA(^TMP("VAQIDXSG",$JOB))
SET VALMBCK="Q"
QUIT
+2 SET VALMCNT=1
+3 SET ROOT="^TMP(""VAQD3"",$J)"
KILL @ROOT
+4 DO CLEAR^VALM1
+5 SET X=$$DEVICE^VAQDIS17("ALL")
+6 IF X=-1
WRITE !,"Error in getting device"
DO INIT
SET VALMBCK="R"
QUIT
+7 IF X=0
KILL VALMBCK
QUIT
+8 SET ENTRY=""
+9 FOR
SET ENTRY=$ORDER(^TMP("VAQIDXSG",$JOB,ENTRY))
if ENTRY=""
QUIT
DO BLDDIS
+10 DO ENDLN
+11 DO EP^VAQDIS16
+12 KILL VALMBCK
+13 QUIT
+14 ;
TRANEX DO PAUSE^VALM1
+1 SET VALMBCK=$SELECT(VAQFLAG=0:"R",1:"Q")
+2 QUIT
+3 ;
BLDDIS ; -- Builds display
+1 ; -- Capacity start
if $DATA(XRTL)
DO T0^%ZOSV
+2 SET SDAT=$GET(^TMP("VAQIDXSG",$JOB,ENTRY))
+3 SET SEGDE=$PIECE(SDAT,U,1)
+4 SET OFFSET=$$BLDDSP^VAQUPD2(DFN,SEGDE,ROOT,VALMCNT)
+5 if +OFFSET'=-1
SET VALMCNT=VALMCNT+OFFSET
+6 IF +OFFSET=-1
SET ERRMSG=$PIECE($GET(OFFSET),U,2)
DO ERRMSG
+7 ;W !,"Segment = ",SEGDE," Offset = ",OFFSET," VALMCNT = ",VALMCNT
+8 ; -- Capacity stop
if $DATA(XRT0)
SET XRTN=$TEXT(+0)
if $DATA(XRT0)
DO T1^%ZOSV
+9 QUIT
+10 ;
ERRMSG ; -- Displays a message if segment could be extracted
+1 SET EROOT=$$ROOT^VAQDIS20(ROOT)
+2 SET VAQSEGND=""
+3 if SEGDE'=""
SET VAQSEGND=$GET(^VAT(394.71,SEGDE,0))
+4 SET VAQLN=$$REPEAT^VAQUTL1("-",79)
+5 SET VAQCTR="< "_$SELECT($PIECE(VAQSEGND,"^",1)'="":$PIECE(VAQSEGND,"^",1),1:"Segment Description Missing")_" >"
+6 SET X=$$CENTER^VAQDIS20(VAQLN,VAQCTR)
DO ETMP
+7 SET X=$$SETSTR^VALM1(" ","",1,79)
DO ETMP
+8 SET X=$$SETSTR^VALM1(" ** "_ERRMSG,"",1,79)
DO ETMP
+9 SET X=$$SETSTR^VALM1(" ","",1,79)
DO ETMP
+10 SET X=$$SETSTR^VALM1(" ","",1,79)
DO ETMP
+11 SET OFFSET=VALMCNT
+12 KILL VAQLN,VAQCTR,VAQSEGND,X,EROOT
+13 QUIT
+14 ;
ENDLN ; -- End of display
+1 SET EROOT=$$ROOT^VAQDIS20(ROOT)
+2 SET X=$$SETSTR^VALM1(" ","",1,79)
DO ETMP
+3 SET X=$$SETSTR^VALM1(" [ End of Data ]","",1,79)
DO ETMP
+4 KILL EROOT
+5 QUIT
+6 ;
ETMP ; -- Display for error message
+1 SET VALMCNT=VALMCNT+1
+2 SET @EROOT@(VALMCNT,0)=$EXTRACT(X,1,79)
+3 QUIT
+4 ;
EXIT ; -- Note: The list processor cleans up its own variables.
+1 ; All other variables cleaned up here.
+2 ;
+3 KILL ^TMP("VAQD2",$JOB),^TMP("VAQIDXSG",$JOB)
+4 KILL SEGDE,SEGMNU,SEGNM
+5 KILL ROOT,OFFSET
+6 QUIT
+7 ;
END ; -- End of code
+1 QUIT
