VAQUPD1 ;ALB/JRP - DATA LOOKUP ROUTINES;8-APR-93
;;1.5;PATIENT DATA EXCHANGE;;NOV 17, 1993
TRNEXT(TRANPTR,ROOT) ;RECREATE ALL EXTRACTION ARRAYS FOR A TRANSACTION
;INPUT : TRANPTR - Pointer to VAQ - TRANSACTION file
; ROOT - Where to store the information (full global reference)
; Defaluts to ^TMP("VAQ",$J)
;OUTPUT : 0 - Success
; -1^Error_Text - Error
;NOTES : Segments returning Extraction Arrays will be stored in
; ROOT(Segment_Abbreviation,"VALUE",File,Field,Sequence_Number)
; ROOT(Segment_Abbreviation,"ID",File,Field,Sequence_Number)
; Segments returning Display Arrays will be stored in
; ROOT(Segment_Abbreviation,"DISPLAY",Line_Number)
; : Deletion of the outupt array before calling this routine
; is the responsiblity of the calling application.
;
;CHECK INPUT
S TRANPTR=+$G(TRANPTR)
Q:('TRANPTR) "-1^Pointer to VAQ - TRANSACTION file not passed"
Q:('$D(^VAT(394.61,TRANPTR))) "-1^Transaction did not exist"
S ROOT=$G(ROOT)
S:(ROOT="") ROOT="^TMP(""VAQ"","_$J_")"
;DECLARE VARIABLES
N LOOP,SEGABB,ERROR,X,TRANSEG,SEG,TMP,Y,TMPROOT
Q:('$D(^VAT(394.61,TRANPTR,"SEG"))) "-1^Transaction did not contain any data segments"
S ERROR=0
S TRANSEG=0
;LOOP THROUGH EACH DATA SEGMENT CONTAINED IN TRANSACTION
F LOOP=0:0 D Q:((ERROR)!('TRANSEG))
.S TRANSEG=$O(^VAT(394.61,TRANPTR,"SEG",TRANSEG))
.Q:('TRANSEG)
.S SEG=+$G(^VAT(394.61,TRANPTR,"SEG",TRANSEG,0))
.Q:('SEG)
.;GET SEGMENT ABBREVIATION
.S SEGABB=$P($G(^VAT(394.71,SEG,0)),"^",2)
.Q:(SEGABB="")
.;MAKE SEGMENT ABBREVIATION NEXT SUBSCRIPT IN ROOT
.S TMP=$P(ROOT,"(",1)
.S X=$P(ROOT,"(",2)
.S Y=$P(X,")",1)
.S:(Y="") TMPROOT=TMP_"("_$C(34)_SEGABB_$C(34)_")"
.S:(Y'="") TMPROOT=TMP_"("_Y_","_$C(34)_SEGABB_$C(34)_")"
.S X=$$SEGEXT(TRANPTR,SEG,TMPROOT)
Q 0
SEGEXT(TRANPTR,SEGPTR,ROOT) ;MOVE SEGMENT IN DATA FILE TO EXTRACTION ARRAY
;INPUT : TRANPTR - Pointer to VAQ - TRANSACTION file
; SEGPTR - Pointer to VAQ - DATA SEGMENT file
; ROOT - Where to store the information (full global reference)
;OUTPUT : 0 - Success
; -1^Error_Text - Error
;
;CHECK INPUT
Q:('$D(^VAT(394.61,+$G(TRANPTR),0))) "-1^Valid pointer to VAQ - TRANSACTION file not passed"
Q:('$D(^VAT(394.71,+$G(SEGPTR),0))) "-1^Valid pointer to VAQ - DATA SEGMENT file not passed"
Q:('$D(^VAT(394.62,"A-SEGMENT",TRANPTR,SEGPTR))) "-1^Transaction does not contain wanted information"
;DECLARE VARIABLES
N DSPRDY,FILE,FIELD,SEQ,VALUE,ID,LOOP,TMP,DATAIFN
;DETERMINE IF DATA SEGMENT IS DISPLAY READY
S DATAIFN=$O(^VAT(394.62,"A-SEGMENT",TRANPTR,SEGPTR,""))
Q:(DATAIFN="") "-1^Transaction does not contain wanted information"
S DSPRDY=$D(^VAT(394.62,"A-DISPLAY",TRANPTR,SEGPTR))
;DISPLAY READY
I DSPRDY D Q 0
.S SEQ=0
.F S SEQ=$O(^VAT(394.62,DATAIFN,"DSP",SEQ)) Q:(SEQ="") D
..S @ROOT@("DISPLAY",SEQ,0)=$G(^VAT(394.62,DATAIFN,"DSP",SEQ,0))
;NOT DISPLAY READY - MOVE INFO TO AN EXTRACTION ARRAY
S DATAIFN=""
F S DATAIFN=$O(^VAT(394.62,"A-SEGMENT",TRANPTR,SEGPTR,DATAIFN)) Q:(DATAIFN="") D
.S TMP=$G(^VAT(394.62,DATAIFN,0))
.S FILE=$P(TMP,"^",3)
.Q:(FILE="")
.S FIELD=$P(TMP,"^",4)
.Q:(FIELD="")
.S SEQ=$G(^VAT(394.62,DATAIFN,"SQNCE"))
.Q:(SEQ="")
.S VALUE=$G(^VAT(394.62,DATAIFN,"VAL"))
.S ID=$G(^VAT(394.62,DATAIFN,"IDNT1"))
.S @ROOT@("ID",FILE,FIELD,SEQ)=ID
.S @ROOT@("VALUE",FILE,FIELD,SEQ)=VALUE
Q 0
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVAQUPD1 3485 printed Sep 23, 2025@20:02:32 Page 2
VAQUPD1 ;ALB/JRP - DATA LOOKUP ROUTINES;8-APR-93
+1 ;;1.5;PATIENT DATA EXCHANGE;;NOV 17, 1993
TRNEXT(TRANPTR,ROOT) ;RECREATE ALL EXTRACTION ARRAYS FOR A TRANSACTION
+1 ;INPUT : TRANPTR - Pointer to VAQ - TRANSACTION file
+2 ; ROOT - Where to store the information (full global reference)
+3 ; Defaluts to ^TMP("VAQ",$J)
+4 ;OUTPUT : 0 - Success
+5 ; -1^Error_Text - Error
+6 ;NOTES : Segments returning Extraction Arrays will be stored in
+7 ; ROOT(Segment_Abbreviation,"VALUE",File,Field,Sequence_Number)
+8 ; ROOT(Segment_Abbreviation,"ID",File,Field,Sequence_Number)
+9 ; Segments returning Display Arrays will be stored in
+10 ; ROOT(Segment_Abbreviation,"DISPLAY",Line_Number)
+11 ; : Deletion of the outupt array before calling this routine
+12 ; is the responsiblity of the calling application.
+13 ;
+14 ;CHECK INPUT
+15 SET TRANPTR=+$GET(TRANPTR)
+16 if ('TRANPTR)
QUIT "-1^Pointer to VAQ - TRANSACTION file not passed"
+17 if ('$DATA(^VAT(394.61,TRANPTR)))
QUIT "-1^Transaction did not exist"
+18 SET ROOT=$GET(ROOT)
+19 if (ROOT="")
SET ROOT="^TMP(""VAQ"","_$JOB_")"
+20 ;DECLARE VARIABLES
+21 NEW LOOP,SEGABB,ERROR,X,TRANSEG,SEG,TMP,Y,TMPROOT
+22 if ('$DATA(^VAT(394.61,TRANPTR,"SEG")))
QUIT "-1^Transaction did not contain any data segments"
+23 SET ERROR=0
+24 SET TRANSEG=0
+25 ;LOOP THROUGH EACH DATA SEGMENT CONTAINED IN TRANSACTION
+26 FOR LOOP=0:0
Begin DoDot:1
+27 SET TRANSEG=$ORDER(^VAT(394.61,TRANPTR,"SEG",TRANSEG))
+28 if ('TRANSEG)
QUIT
+29 SET SEG=+$GET(^VAT(394.61,TRANPTR,"SEG",TRANSEG,0))
+30 if ('SEG)
QUIT
+31 ;GET SEGMENT ABBREVIATION
+32 SET SEGABB=$PIECE($GET(^VAT(394.71,SEG,0)),"^",2)
+33 if (SEGABB="")
QUIT
+34 ;MAKE SEGMENT ABBREVIATION NEXT SUBSCRIPT IN ROOT
+35 SET TMP=$PIECE(ROOT,"(",1)
+36 SET X=$PIECE(ROOT,"(",2)
+37 SET Y=$PIECE(X,")",1)
+38 if (Y="")
SET TMPROOT=TMP_"("_$CHAR(34)_SEGABB_$CHAR(34)_")"
+39 if (Y'="")
SET TMPROOT=TMP_"("_Y_","_$CHAR(34)_SEGABB_$CHAR(34)_")"
+40 SET X=$$SEGEXT(TRANPTR,SEG,TMPROOT)
End DoDot:1
if ((ERROR)!('TRANSEG))
QUIT
+41 QUIT 0
SEGEXT(TRANPTR,SEGPTR,ROOT) ;MOVE SEGMENT IN DATA FILE TO EXTRACTION ARRAY
+1 ;INPUT : TRANPTR - Pointer to VAQ - TRANSACTION file
+2 ; SEGPTR - Pointer to VAQ - DATA SEGMENT file
+3 ; ROOT - Where to store the information (full global reference)
+4 ;OUTPUT : 0 - Success
+5 ; -1^Error_Text - Error
+6 ;
+7 ;CHECK INPUT
+8 if ('$DATA(^VAT(394.61,+$GET(TRANPTR),0)))
QUIT "-1^Valid pointer to VAQ - TRANSACTION file not passed"
+9 if ('$DATA(^VAT(394.71,+$GET(SEGPTR),0)))
QUIT "-1^Valid pointer to VAQ - DATA SEGMENT file not passed"
+10 if ('$DATA(^VAT(394.62,"A-SEGMENT",TRANPTR,SEGPTR)))
QUIT "-1^Transaction does not contain wanted information"
+11 ;DECLARE VARIABLES
+12 NEW DSPRDY,FILE,FIELD,SEQ,VALUE,ID,LOOP,TMP,DATAIFN
+13 ;DETERMINE IF DATA SEGMENT IS DISPLAY READY
+14 SET DATAIFN=$ORDER(^VAT(394.62,"A-SEGMENT",TRANPTR,SEGPTR,""))
+15 if (DATAIFN="")
QUIT "-1^Transaction does not contain wanted information"
+16 SET DSPRDY=$DATA(^VAT(394.62,"A-DISPLAY",TRANPTR,SEGPTR))
+17 ;DISPLAY READY
+18 IF DSPRDY
Begin DoDot:1
+19 SET SEQ=0
+20 FOR
SET SEQ=$ORDER(^VAT(394.62,DATAIFN,"DSP",SEQ))
if (SEQ="")
QUIT
Begin DoDot:2
+21 SET @ROOT@("DISPLAY",SEQ,0)=$GET(^VAT(394.62,DATAIFN,"DSP",SEQ,0))
End DoDot:2
End DoDot:1
QUIT 0
+22 ;NOT DISPLAY READY - MOVE INFO TO AN EXTRACTION ARRAY
+23 SET DATAIFN=""
+24 FOR
SET DATAIFN=$ORDER(^VAT(394.62,"A-SEGMENT",TRANPTR,SEGPTR,DATAIFN))
if (DATAIFN="")
QUIT
Begin DoDot:1
+25 SET TMP=$GET(^VAT(394.62,DATAIFN,0))
+26 SET FILE=$PIECE(TMP,"^",3)
+27 if (FILE="")
QUIT
+28 SET FIELD=$PIECE(TMP,"^",4)
+29 if (FIELD="")
QUIT
+30 SET SEQ=$GET(^VAT(394.62,DATAIFN,"SQNCE"))
+31 if (SEQ="")
QUIT
+32 SET VALUE=$GET(^VAT(394.62,DATAIFN,"VAL"))
+33 SET ID=$GET(^VAT(394.62,DATAIFN,"IDNT1"))
+34 SET @ROOT@("ID",FILE,FIELD,SEQ)=ID
+35 SET @ROOT@("VALUE",FILE,FIELD,SEQ)=VALUE
End DoDot:1
+36 QUIT 0
