VAQEXT01 ;ALB/JFP - PDX, PROCESS EXTERNAL (MANUAL),PROCESS SCREEN;01MAR93
;;1.5;PATIENT DATA EXCHANGE;**14,35**;NOV 17, 1993
EP ; -- Main entry point for the list processor
K XQORS,VALMEVL
N VALMCNT S VALMCNT=0
D EN^VALM("VAQ PROCESS PDX3")
QUIT
;
INIT ; -- Builds array of PDX transactions for manual processing
; (transactions with status VAQ-PROC)
; NOTE: VAQ-PROC is a hard coded mnemonic, ^VAT(394.85,
;
K ^TMP("VAQR3",$J),^TMP("VAQR3","VAQIDX",$J)
N STATPT,TRDE,NODE,ND,X,Y,K,J,DATETIME,SEGMENT,SEGDE,SEG,SDI,VALMY,SDAT
N VAQECNT,VAQTRNO,VAQPTNM,VAQISSN,VAQIDOB,VAQEDOB,VAQPTID,VAQAUST
N VAQAUADD,VAQRES,VAQTRDE,VAQDFN,VAQDOM,VAQSIG,VAQTRN,VAQESSN,VAQLMT
N VAQRST,VAQCST
;
D:$D(XRTL) T0^%ZOSV
S (STATPT,TRDE,RELPTR)="",(VAQECNT,VALMCNT)=0
S STATPT=$O(^VAT(394.85,"B","VAQ-PROC",STATPT))
S RELPTR=$O(^VAT(394.85,"B","VAQ-RQACK",RELPTR))
F S TRDE=$O(^VAT(394.61,"STATUS",STATPT,TRDE)) Q:TRDE="" D SETD
I VAQECNT=0 D
.S VAQTRNO=0,X=$$SETSTR^VALM1(" ","",1,79) D TMP
.S X=$$SETSTR^VALM1(" ** No pending transactions queued for manual processing... ","",1,80) D TMP
S:$D(XRT0) XRTN=$T(+0) D:$D(XRT0) T1^%ZOSV
QUIT
;
SETD ; -- Set data for display in list processor
; -- Filter out transactions marked as purged OR exceed life cap
S VAQFLAG=$$EXPTRN^VAQUTL97(TRDE)
Q:VAQFLAG=1
Q:$$CLOSTRAN^VAQUTL97(TRDE,"RQST2") ; Filter out (and mark for purging) transactions from closed domains.
F ND=0,"QRY","RQST1","RQST2","ATHR1","ATHR2" S NODE(ND)=$G(^VAT(394.61,TRDE,ND))
; -- release status set, skip entry
S VAQCST=+$P(NODE(0),U,2),VAQRST=+$P(NODE(0),U,5)
I ($P($G(^VAT(394.85,VAQCST,0)),U,1)'="VAQ-PROC") QUIT
I ($P($G(^VAT(394.85,VAQRST,0)),U,1)'="VAQ-RQACK") QUIT
D SETD1
D SEG^VAQEXT06 ; -- gather segments
D DISDEMO
D DISSEG
S X=$$SETSTR^VALM1(" ","",1,80) D TMP ; -- null line
D DISMAX^VAQEXT06
S X=$$SETSTR^VALM1(" ","",1,80) D TMP ; -- null line
QUIT
;
SETD1 ; -- Extracts data for display
S VAQTRNO=$P(NODE(0),U,1)
S (Y,VAQTDTE)=$P(NODE("RQST1"),U,1)
X ^DD("DD") S DATETIME=Y_" (Rq)"
S VAQDOM=$P(NODE("RQST2"),U,1)
S VAQPTNM=$P(NODE("QRY"),U,1)
S VAQISSN=$P(NODE("QRY"),U,2)
S VAQIDOB=$P(NODE("QRY"),U,3),VAQEDOB=$$DOBFMT^VAQUTL99(VAQIDOB)
S VAQPTID=$P(NODE("QRY"),U,4)
S VAQRQST=$P(NODE("RQST2"),U,1),VAQRQADD=$P(NODE("RQST2"),U,2)
I VAQISSN'="" S VAQRES=$$RES^VAQUTL99(VAQRQADD,VAQISSN) ;-- reason for manual
I VAQISSN="" S VAQRES=$$RES^VAQUTL99(VAQRQADD,VAQPTNM) ;-- reason for manual
; -- Check to see if requested segments exceed max time/occurrence limits
;W !,"VAQRES = ",VAQRES
I $P(VAQRES,U,1)>0 D
.S VAQLMT=$$AUTO^VAQEXT05(TRDE)
.I (+VAQLMT)<0 S VAQRES=VAQLMT
QUIT
;
DISDEMO ; -- Displays the entries requiring manual process
S VAQECNT=VAQECNT+1
S X=$$SETSTR^VALM1("Entry # : "_VAQECNT,"",1,39)
S X=$$SETSTR^VALM1(" Trans #: "_VAQTRNO,X,40,39) D TMP
S X=$$SETSTR^VALM1("Patient : "_VAQPTNM,"",1,39)
S X=$$SETSTR^VALM1("Date/Time: "_DATETIME,X,40,39) D TMP
I VAQPTID="" D
.S VAQESSN=$$DASHSSN^VAQUTL99(VAQISSN)
.S X=$$SETSTR^VALM1("Patient SS: "_VAQESSN,"",1,39)
S:VAQPTID'="" X=$$SETSTR^VALM1("Patient ID: "_VAQPTID,"",1,39)
S X=$$SETSTR^VALM1(" DOB: "_VAQEDOB,X,40,39) D TMP
S X=$$SETSTR^VALM1("Domain : "_VAQDOM,"",1,39)
S X=$$SETSTR^VALM1(" Reason: "_$P(VAQRES,U,2),X,40,39) D TMP
QUIT
;
DISSEG ; -- Displays selected segments
F K=0:0 S K=$O(SEGMENT($J,K)) Q:K="" D
.S SEGMENT=SEGMENT($J,K)
.I K=1 S X=$$SETSTR^VALM1("Segments : "_SEGMENT,"",1,80) D TMP
.I K'=1 S X=$$SETSTR^VALM1(" : "_SEGMENT,"",1,80) D TMP
QUIT
;
TMP ; -- Set the array used by list processor
S VALMCNT=VALMCNT+1
S ^TMP("VAQR3",$J,VALMCNT,0)=$E(X,1,79)
S ^TMP("VAQR3",$J,"IDX",VALMCNT,VAQECNT)=""
S ^TMP("VAQR3","VAQIDX",$J,VAQECNT)=VALMCNT_"^"_VAQTRNO
Q
;
HD ; -- Make header line for list processor
S VALMHDR(1)="PDX Activity Requiring Manual Processing"
QUIT
;
EXIT ; -- Task entries for batch processing, Cleans up variables
I $D(VAQTRN) D TASK^VAQEXT04
;
K ^TMP("VAQR3",$J),^TMP("VAQR3","VAQIDX",$J)
K STATPT,TRDE,NODE,ND,X,Y,K,J,DATETIME,SEGMENT,SEGDE,SEG,SDI,VALMY,SDAT
K VAQECNT,VAQTRNO,VAQPTNM,VAQISSN,VAQIDOB,VAQEDOB,VAQPTID,VAQAUST
K VAQAUADD,VAQRES,VAQTRDE,VAQDFN,VAQDOM,VAQSIG,VAQTRN
K VAQFLAG,VAQTDTE,VAQESSN,VAQLMT
K RELPTR,VAQCST,VAQRST
Q
;
END ; -- End of code
QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVAQEXT01 4422 printed Sep 23, 2025@20:01:19 Page 2
VAQEXT01 ;ALB/JFP - PDX, PROCESS EXTERNAL (MANUAL),PROCESS SCREEN;01MAR93
+1 ;;1.5;PATIENT DATA EXCHANGE;**14,35**;NOV 17, 1993
EP ; -- Main entry point for the list processor
+1 KILL XQORS,VALMEVL
+2 NEW VALMCNT
SET VALMCNT=0
+3 DO EN^VALM("VAQ PROCESS PDX3")
+4 QUIT
+5 ;
INIT ; -- Builds array of PDX transactions for manual processing
+1 ; (transactions with status VAQ-PROC)
+2 ; NOTE: VAQ-PROC is a hard coded mnemonic, ^VAT(394.85,
+3 ;
+4 KILL ^TMP("VAQR3",$JOB),^TMP("VAQR3","VAQIDX",$JOB)
+5 NEW STATPT,TRDE,NODE,ND,X,Y,K,J,DATETIME,SEGMENT,SEGDE,SEG,SDI,VALMY,SDAT
+6 NEW VAQECNT,VAQTRNO,VAQPTNM,VAQISSN,VAQIDOB,VAQEDOB,VAQPTID,VAQAUST
+7 NEW VAQAUADD,VAQRES,VAQTRDE,VAQDFN,VAQDOM,VAQSIG,VAQTRN,VAQESSN,VAQLMT
+8 NEW VAQRST,VAQCST
+9 ;
+10 if $DATA(XRTL)
DO T0^%ZOSV
+11 SET (STATPT,TRDE,RELPTR)=""
SET (VAQECNT,VALMCNT)=0
+12 SET STATPT=$ORDER(^VAT(394.85,"B","VAQ-PROC",STATPT))
+13 SET RELPTR=$ORDER(^VAT(394.85,"B","VAQ-RQACK",RELPTR))
+14 FOR
SET TRDE=$ORDER(^VAT(394.61,"STATUS",STATPT,TRDE))
if TRDE=""
QUIT
DO SETD
+15 IF VAQECNT=0
Begin DoDot:1
+16 SET VAQTRNO=0
SET X=$$SETSTR^VALM1(" ","",1,79)
DO TMP
+17 SET X=$$SETSTR^VALM1(" ** No pending transactions queued for manual processing... ","",1,80)
DO TMP
End DoDot:1
+18 if $DATA(XRT0)
SET XRTN=$TEXT(+0)
if $DATA(XRT0)
DO T1^%ZOSV
+19 QUIT
+20 ;
SETD ; -- Set data for display in list processor
+1 ; -- Filter out transactions marked as purged OR exceed life cap
+2 SET VAQFLAG=$$EXPTRN^VAQUTL97(TRDE)
+3 if VAQFLAG=1
QUIT
+4 ; Filter out (and mark for purging) transactions from closed domains.
if $$CLOSTRAN^VAQUTL97(TRDE,"RQST2")
QUIT
+5 FOR ND=0,"QRY","RQST1","RQST2","ATHR1","ATHR2"
SET NODE(ND)=$GET(^VAT(394.61,TRDE,ND))
+6 ; -- release status set, skip entry
+7 SET VAQCST=+$PIECE(NODE(0),U,2)
SET VAQRST=+$PIECE(NODE(0),U,5)
+8 IF ($PIECE($GET(^VAT(394.85,VAQCST,0)),U,1)'="VAQ-PROC")
QUIT
+9 IF ($PIECE($GET(^VAT(394.85,VAQRST,0)),U,1)'="VAQ-RQACK")
QUIT
+10 DO SETD1
+11 ; -- gather segments
DO SEG^VAQEXT06
+12 DO DISDEMO
+13 DO DISSEG
+14 ; -- null line
SET X=$$SETSTR^VALM1(" ","",1,80)
DO TMP
+15 DO DISMAX^VAQEXT06
+16 ; -- null line
SET X=$$SETSTR^VALM1(" ","",1,80)
DO TMP
+17 QUIT
+18 ;
SETD1 ; -- Extracts data for display
+1 SET VAQTRNO=$PIECE(NODE(0),U,1)
+2 SET (Y,VAQTDTE)=$PIECE(NODE("RQST1"),U,1)
+3 XECUTE ^DD("DD")
SET DATETIME=Y_" (Rq)"
+4 SET VAQDOM=$PIECE(NODE("RQST2"),U,1)
+5 SET VAQPTNM=$PIECE(NODE("QRY"),U,1)
+6 SET VAQISSN=$PIECE(NODE("QRY"),U,2)
+7 SET VAQIDOB=$PIECE(NODE("QRY"),U,3)
SET VAQEDOB=$$DOBFMT^VAQUTL99(VAQIDOB)
+8 SET VAQPTID=$PIECE(NODE("QRY"),U,4)
+9 SET VAQRQST=$PIECE(NODE("RQST2"),U,1)
SET VAQRQADD=$PIECE(NODE("RQST2"),U,2)
+10 ;-- reason for manual
IF VAQISSN'=""
SET VAQRES=$$RES^VAQUTL99(VAQRQADD,VAQISSN)
+11 ;-- reason for manual
IF VAQISSN=""
SET VAQRES=$$RES^VAQUTL99(VAQRQADD,VAQPTNM)
+12 ; -- Check to see if requested segments exceed max time/occurrence limits
+13 ;W !,"VAQRES = ",VAQRES
+14 IF $PIECE(VAQRES,U,1)>0
Begin DoDot:1
+15 SET VAQLMT=$$AUTO^VAQEXT05(TRDE)
+16 IF (+VAQLMT)<0
SET VAQRES=VAQLMT
End DoDot:1
+17 QUIT
+18 ;
DISDEMO ; -- Displays the entries requiring manual process
+1 SET VAQECNT=VAQECNT+1
+2 SET X=$$SETSTR^VALM1("Entry # : "_VAQECNT,"",1,39)
+3 SET X=$$SETSTR^VALM1(" Trans #: "_VAQTRNO,X,40,39)
DO TMP
+4 SET X=$$SETSTR^VALM1("Patient : "_VAQPTNM,"",1,39)
+5 SET X=$$SETSTR^VALM1("Date/Time: "_DATETIME,X,40,39)
DO TMP
+6 IF VAQPTID=""
Begin DoDot:1
+7 SET VAQESSN=$$DASHSSN^VAQUTL99(VAQISSN)
+8 SET X=$$SETSTR^VALM1("Patient SS: "_VAQESSN,"",1,39)
End DoDot:1
+9 if VAQPTID'=""
SET X=$$SETSTR^VALM1("Patient ID: "_VAQPTID,"",1,39)
+10 SET X=$$SETSTR^VALM1(" DOB: "_VAQEDOB,X,40,39)
DO TMP
+11 SET X=$$SETSTR^VALM1("Domain : "_VAQDOM,"",1,39)
+12 SET X=$$SETSTR^VALM1(" Reason: "_$PIECE(VAQRES,U,2),X,40,39)
DO TMP
+13 QUIT
+14 ;
DISSEG ; -- Displays selected segments
+1 FOR K=0:0
SET K=$ORDER(SEGMENT($JOB,K))
if K=""
QUIT
Begin DoDot:1
+2 SET SEGMENT=SEGMENT($JOB,K)
+3 IF K=1
SET X=$$SETSTR^VALM1("Segments : "_SEGMENT,"",1,80)
DO TMP
+4 IF K'=1
SET X=$$SETSTR^VALM1(" : "_SEGMENT,"",1,80)
DO TMP
End DoDot:1
+5 QUIT
+6 ;
TMP ; -- Set the array used by list processor
+1 SET VALMCNT=VALMCNT+1
+2 SET ^TMP("VAQR3",$JOB,VALMCNT,0)=$EXTRACT(X,1,79)
+3 SET ^TMP("VAQR3",$JOB,"IDX",VALMCNT,VAQECNT)=""
+4 SET ^TMP("VAQR3","VAQIDX",$JOB,VAQECNT)=VALMCNT_"^"_VAQTRNO
+5 QUIT
+6 ;
HD ; -- Make header line for list processor
+1 SET VALMHDR(1)="PDX Activity Requiring Manual Processing"
+2 QUIT
+3 ;
EXIT ; -- Task entries for batch processing, Cleans up variables
+1 IF $DATA(VAQTRN)
DO TASK^VAQEXT04
+2 ;
+3 KILL ^TMP("VAQR3",$JOB),^TMP("VAQR3","VAQIDX",$JOB)
+4 KILL STATPT,TRDE,NODE,ND,X,Y,K,J,DATETIME,SEGMENT,SEGDE,SEG,SDI,VALMY,SDAT
+5 KILL VAQECNT,VAQTRNO,VAQPTNM,VAQISSN,VAQIDOB,VAQEDOB,VAQPTID,VAQAUST
+6 KILL VAQAUADD,VAQRES,VAQTRDE,VAQDFN,VAQDOM,VAQSIG,VAQTRN
+7 KILL VAQFLAG,VAQTDTE,VAQESSN,VAQLMT
+8 KILL RELPTR,VAQCST,VAQRST
+9 QUIT
+10 ;
END ; -- End of code
+1 QUIT
