VAQREQ02 ;ALB/JFP - PDX, REQUEST PATIENT DATA, REQUEST SCREEN;01MAR93
;;1.5;PATIENT DATA EXCHANGE;;NOV 17, 1993
EP ; -- Main entry point for the list processor (called from protocol
; vaq create request)
; -- K XQORS,VALMEVL (only kill on the first screen in)
K ^TMP("VAQSEG",$J),^TMP("VAQNOTI",$J),^TMP("VAQCOPY",$J)
EP1 N X,K,DOM,SEG,SEGMENT,SP50,DISX
D EN^VALM("VAQ REQUEST PDX2")
K VALMBCK
QUIT
;
INIT ; -- Initializes variables and defines screen
K ^TMP("VAQR2",$J)
S (VAQECNT,VALMCNT)=0,(DOM,SEG)=""
;
S:VAQOPT="UNS" VALM("TITLE")="PDX V1.5 - UNSOLICITED"
I '$D(^TMP("VAQSEG",$J)) D
.S DISX=$$SETSTR^VALM1(" ","",1,79) D TMP
.S DISX=$$SETSTR^VALM1("** Select an option or <Return> to exit ","",1,79) D TMP
F S DOM=$O(^TMP("VAQSEG",$J,DOM)) Q:DOM="" D SETD
QUIT
;
SETD ;
S VAQECNT=VAQECNT+1,K=0
S DISX=$$SETFLD^VALM1(VAQECNT,"","ENTRY")
S DISX=$$SETFLD^VALM1(DOM,DISX,"DOMAIN")
S (SEGMENT,SEG)=""
F S SEG=$O(^TMP("VAQSEG",$J,DOM,SEG)) Q:SEG="" D WSEG
I K<3 D
.S DISX=$$SETFLD^VALM1(SEGMENT,DISX,"SEGMENTS")
.D TMP
S DISX=$$SETSTR^VALM1(" ","",1,79) D TMP
QUIT
;
WSEG ;
S K=K+1
S P1=K*14,POS=P1-14+K ; -- 3 segments across
S HSCOMPND=$$HLTHSEG^VAQDBIH1(SEG,0)
I $P(HSCOMPND,U,1)'=0 D SEGDIS^VAQEXT06
S SEGMENT=$$SETSTR^VALM1(SEG,SEGMENT,POS,14)
I K=3 D
.S DISX=$$SETFLD^VALM1(SEGMENT,DISX,"SEGMENTS")
.D TMP
.S SEGMENT="",DISX="",K=0
QUIT
;
TMP ; -- Set the array used by list processor
S VALMCNT=VALMCNT+1
S ^TMP("VAQR2",$J,VALMCNT,0)=$E(DISX,1,79)
S ^TMP("VAQR2",$J,"IDX",VALMCNT,VAQECNT)=""
S ^TMP("VAQIDX",$J,VAQECNT)=DOM
Q
;
HD ; -- Make header line for list processor
S SP50=$J("",50)
S VALMHDR(1)="Patient : "_$E(VAQNM_SP50,1,38)_"Type: "_VAQEELG
S VALMHDR(2)="Patient SSN: "_$E(VAQESSN_SP50,1,39)_"DOB: "_VAQEDOB
QUIT
;
; ------------------------ PROTOCOLS -------------------------------
REQ ; -- Request Domain and Segment
D CLEAR^VALM1
D EP^VAQREQ03
D INIT
S VALMBCK="R"
QUIT
;
COPY ; -- Copies segments selected from one domain to main domains
D SEL^VALM2
Q:'$D(VALMY)
D CLEAR^VALM1
D EP^VAQREQ05
D INIT
S VALMBCK="R"
QUIT
;
TRAN ; -- Transmits, Signature, Notify list)
S VAQFLAG=0,VAQCMNT="Unsolicited Request "
D CLEAR^VALM1
I '$D(^TMP("VAQSEG",$J)) W !," ** No request to transmit on file" D TRANEX QUIT
S X=$$VRFYUSER^VAQAUT(DUZ) ; -- Signature
I X<0 K X D TRANEX QUIT
D:VAQOPT="REQ" EP^VAQREQ07 ; -- Notify code
D:VAQOPT="UNS" EP^VAQREQ08 ; -- Comment for unsolicited
D EP^VAQREQ06 ; -- Transmit
K ^TMP("VAQSEG",$J)
;
TRANEX D PAUSE^VAQUTL95
S VALMBCK=$S(VAQFLAG=0:"R",1:"Q")
QUIT
;
;
PAT ; -- Change patient by exiting back to patient prompt
EXIT ; -- Note: The list processor cleans up its own variables.
; All other variables cleaned up here.
;
G:'$D(^TMP("VAQSEG",$J)) EXIT1
I $D(^TMP("VAQSEG",$J)) W !!,"WARNING...Exiting this option will delete untransmitted request for this patient" R !,"Exit request? N// ",X:DTIME
I ($E(X,1,1)="Y")!($E(X,1,1)="y") G EXIT1
I ($E(X,1,1))="^" G EXIT1
D EP1
;
EXIT1 K X,K,DOM,SEG,SEGMENT,SP50,DISX
K ^TMP("VAQSEG",$J),^TMP("VAQNOTI",$J),^TMP("VAQR2",$J),^TMP("VAQCOPY",$J)
K VAQEELG,VAQEDOB,VAQNM,VAQESSN,VAQECNT,VAQFLAG,VAQCMNT
K LPDOM,OLIMIT,TLIMIT,P1,POS,SEGND,SEGNME,SEGNO,HSCOMPND,OLDEF,TLDEF
K PARAMND
Q
;
END ; -- End of code
QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVAQREQ02 3430 printed Apr 09, 2024@21:27:20 Page 2
VAQREQ02 ;ALB/JFP - PDX, REQUEST PATIENT DATA, REQUEST SCREEN;01MAR93
+1 ;;1.5;PATIENT DATA EXCHANGE;;NOV 17, 1993
EP ; -- Main entry point for the list processor (called from protocol
+1 ; vaq create request)
+2 ; -- K XQORS,VALMEVL (only kill on the first screen in)
+3 KILL ^TMP("VAQSEG",$JOB),^TMP("VAQNOTI",$JOB),^TMP("VAQCOPY",$JOB)
EP1 NEW X,K,DOM,SEG,SEGMENT,SP50,DISX
+1 DO EN^VALM("VAQ REQUEST PDX2")
+2 KILL VALMBCK
+3 QUIT
+4 ;
INIT ; -- Initializes variables and defines screen
+1 KILL ^TMP("VAQR2",$JOB)
+2 SET (VAQECNT,VALMCNT)=0
SET (DOM,SEG)=""
+3 ;
+4 if VAQOPT="UNS"
SET VALM("TITLE")="PDX V1.5 - UNSOLICITED"
+5 IF '$DATA(^TMP("VAQSEG",$JOB))
Begin DoDot:1
+6 SET DISX=$$SETSTR^VALM1(" ","",1,79)
DO TMP
+7 SET DISX=$$SETSTR^VALM1("** Select an option or <Return> to exit ","",1,79)
DO TMP
End DoDot:1
+8 FOR
SET DOM=$ORDER(^TMP("VAQSEG",$JOB,DOM))
if DOM=""
QUIT
DO SETD
+9 QUIT
+10 ;
SETD ;
+1 SET VAQECNT=VAQECNT+1
SET K=0
+2 SET DISX=$$SETFLD^VALM1(VAQECNT,"","ENTRY")
+3 SET DISX=$$SETFLD^VALM1(DOM,DISX,"DOMAIN")
+4 SET (SEGMENT,SEG)=""
+5 FOR
SET SEG=$ORDER(^TMP("VAQSEG",$JOB,DOM,SEG))
if SEG=""
QUIT
DO WSEG
+6 IF K<3
Begin DoDot:1
+7 SET DISX=$$SETFLD^VALM1(SEGMENT,DISX,"SEGMENTS")
+8 DO TMP
End DoDot:1
+9 SET DISX=$$SETSTR^VALM1(" ","",1,79)
DO TMP
+10 QUIT
+11 ;
WSEG ;
+1 SET K=K+1
+2 ; -- 3 segments across
SET P1=K*14
SET POS=P1-14+K
+3 SET HSCOMPND=$$HLTHSEG^VAQDBIH1(SEG,0)
+4 IF $PIECE(HSCOMPND,U,1)'=0
DO SEGDIS^VAQEXT06
+5 SET SEGMENT=$$SETSTR^VALM1(SEG,SEGMENT,POS,14)
+6 IF K=3
Begin DoDot:1
+7 SET DISX=$$SETFLD^VALM1(SEGMENT,DISX,"SEGMENTS")
+8 DO TMP
+9 SET SEGMENT=""
SET DISX=""
SET K=0
End DoDot:1
+10 QUIT
+11 ;
TMP ; -- Set the array used by list processor
+1 SET VALMCNT=VALMCNT+1
+2 SET ^TMP("VAQR2",$JOB,VALMCNT,0)=$EXTRACT(DISX,1,79)
+3 SET ^TMP("VAQR2",$JOB,"IDX",VALMCNT,VAQECNT)=""
+4 SET ^TMP("VAQIDX",$JOB,VAQECNT)=DOM
+5 QUIT
+6 ;
HD ; -- Make header line for list processor
+1 SET SP50=$JUSTIFY("",50)
+2 SET VALMHDR(1)="Patient : "_$EXTRACT(VAQNM_SP50,1,38)_"Type: "_VAQEELG
+3 SET VALMHDR(2)="Patient SSN: "_$EXTRACT(VAQESSN_SP50,1,39)_"DOB: "_VAQEDOB
+4 QUIT
+5 ;
+6 ; ------------------------ PROTOCOLS -------------------------------
REQ ; -- Request Domain and Segment
+1 DO CLEAR^VALM1
+2 DO EP^VAQREQ03
+3 DO INIT
+4 SET VALMBCK="R"
+5 QUIT
+6 ;
COPY ; -- Copies segments selected from one domain to main domains
+1 DO SEL^VALM2
+2 if '$DATA(VALMY)
QUIT
+3 DO CLEAR^VALM1
+4 DO EP^VAQREQ05
+5 DO INIT
+6 SET VALMBCK="R"
+7 QUIT
+8 ;
TRAN ; -- Transmits, Signature, Notify list)
+1 SET VAQFLAG=0
SET VAQCMNT="Unsolicited Request "
+2 DO CLEAR^VALM1
+3 IF '$DATA(^TMP("VAQSEG",$JOB))
WRITE !," ** No request to transmit on file"
DO TRANEX
QUIT
+4 ; -- Signature
SET X=$$VRFYUSER^VAQAUT(DUZ)
+5 IF X<0
KILL X
DO TRANEX
QUIT
+6 ; -- Notify code
if VAQOPT="REQ"
DO EP^VAQREQ07
+7 ; -- Comment for unsolicited
if VAQOPT="UNS"
DO EP^VAQREQ08
+8 ; -- Transmit
DO EP^VAQREQ06
+9 KILL ^TMP("VAQSEG",$JOB)
+10 ;
TRANEX DO PAUSE^VAQUTL95
+1 SET VALMBCK=$SELECT(VAQFLAG=0:"R",1:"Q")
+2 QUIT
+3 ;
+4 ;
PAT ; -- Change patient by exiting back to patient prompt
EXIT ; -- Note: The list processor cleans up its own variables.
+1 ; All other variables cleaned up here.
+2 ;
+3 if '$DATA(^TMP("VAQSEG",$JOB))
GOTO EXIT1
+4 IF $DATA(^TMP("VAQSEG",$JOB))
WRITE !!,"WARNING...Exiting this option will delete untransmitted request for this patient"
READ !,"Exit request? N// ",X:DTIME
+5 IF ($EXTRACT(X,1,1)="Y")!($EXTRACT(X,1,1)="y")
GOTO EXIT1
+6 IF ($EXTRACT(X,1,1))="^"
GOTO EXIT1
+7 DO EP1
+8 ;
EXIT1 KILL X,K,DOM,SEG,SEGMENT,SP50,DISX
+1 KILL ^TMP("VAQSEG",$JOB),^TMP("VAQNOTI",$JOB),^TMP("VAQR2",$JOB),^TMP("VAQCOPY",$JOB)
+2 KILL VAQEELG,VAQEDOB,VAQNM,VAQESSN,VAQECNT,VAQFLAG,VAQCMNT
+3 KILL LPDOM,OLIMIT,TLIMIT,P1,POS,SEGND,SEGNME,SEGNO,HSCOMPND,OLDEF,TLDEF
+4 KILL PARAMND
+5 QUIT
+6 ;
END ; -- End of code
+1 QUIT
