VAQREQ05 ;ALB/JFP - REQUEST PDX RECORD, COPY DOMAIN;01MAR93
;;1.5;PATIENT DATA EXCHANGE;**30**;NOV 17, 1993
EP ; -- Main entry point for the list processor
; - Called from VAQREQ02
;
REQ ; -- Request domain
N SDI,SDAT,DIRUT,DTOUT,DUOUT,X,Y,N,L,POP
N INSTDA,INST,STNO,GRP,GRPDA,DOMDA,DOMAIN,DOM,DOMNODE
S SDI=0
F S SDI=$O(VALMY(SDI)) Q:SDI="" D
.S SDAT=$G(^TMP("VAQIDX",$J,SDI))
;
F D ASKDOM Q:$D(DIRUT)
D:$D(^TMP("VAQCOPY",$J)) COPY
K SDI,SDAT,VALMY,DIRUT,DTOUT,DUOUT,X,Y,N,L,POP
K INSTDA,INST,STNO,GRP,GRPDA,DOMDA,DOMAIN,DOM,DOMNODE
K ^TMP("VAQCOPY",$J),SEGNODE
QUIT
;
ASKDOM ; -- Call to Dir to request domain
D:$D(^TMP("VAQCOPY",$J)) LISTD
S POP=0
S DIR("A")="Copy to Domain: "
S DIR(0)="FAO^1:30"
S DIR("?")="^D HLPDOM1^VAQREQ09"
S DIR("??")="^D HLPDOM2^VAQREQ09"
W ! D ^DIR K DIR Q:$D(DIRUT)
S X=Y
I X="*L" D LISTD Q:POP
I $E(X,1,1)="-" D DELDOM Q:POP
I $E(X,1,2)'="G." D DOM Q:POP
I $E(X,1,2)="G." D GDOM Q:POP
QUIT
;
DOM ; -- Dic lookup to verify domain in file 4.2
N FLAGS
S DIC="^DIC(4.2,",DIC(0)="EMQZ"
D ^DIC K DIC I $D(DTOUT)!$D(DUOUT)!(Y<0) S POP=1 QUIT
; -- Check for closed domains
S FLAGS=$P(Y(0),U,2)
I FLAGS["C" W $C(7)," ...Domain is closed" S POP=1 QUIT
;
S INSTDA=$P(Y(0),U,13),DOMAIN=$P(Y,U,2)
I INSTDA="" W " ...Domain entered does not have a station number" S POP=1 QUIT
S STNO=$O(^DIC(4,"D",INSTDA,""))
I STNO="" W " ...Domain does not have a valid station number" S POP=1 QUIT
S INST=$P(^DIC(4,STNO,0),U,1),^TMP("VAQCOPY",$J,DOMAIN)=INSTDA_"^"_INST
QUIT
;
GDOM ; -- Dic lookup to verify domain group name in file 394.83
S X=$P(X,".",2) ; -- strip off G.
S DIC="^VAT(394.83,"
S DIC(0)="EMQZ"
D ^DIC K DIC I $D(DTOUT)!$D(DUOUT)!(Y<0) S POP=1 QUIT
S GRP=$P(Y,U,2),GRPDA="",GRPDA=$O(^VAT(394.83,"B",GRP,GRPDA))
D G1
QUIT
;
G1 S (INSTDA,DOMDA)=""
F S INSTDA=$O(^VAT(394.83,GRPDA,"FAC","A-OUTGRP",INSTDA)) Q:'INSTDA D G2
QUIT
G2 F S DOMDA=$O(^VAT(394.83,GRPDA,"FAC","A-OUTGRP",INSTDA,DOMDA)) Q:'DOMDA D SETG
QUIT
;
SETG ; --
Q:'$$OKDOM^VAQREQ03(GRPDA,INSTDA,DOMDA)
S INST=$P($G(^DIC(4,INSTDA,0)),U,1)
S DOMAIN=$P($G(^DIC(4.2,DOMDA,0)),U,1)
S ^TMP("VAQCOPY",$J,DOMAIN)=INSTDA_"^"_INST
QUIT
;
DELDOM ; -- Deletes domain & segments associated with domain
S POP=1,X=$E(X,2,99)
I X="" W !!,"** NO ENTRIES SELECTED" QUIT
I '$D(^TMP("VAQCOPY",$J,X)) W " ... ",X," Not Selected" QUIT
K ^TMP("VAQCOPY",$J,X)
QUIT
;
COPY ; -- Copies segments to new domain(s)
S DOM=""
F S DOM=$O(^TMP("VAQCOPY",$J,DOM)) Q:DOM="" D C1
QUIT
;
C1 S DOMNODE=$G(^TMP("VAQCOPY",$J,DOM)),^TMP("VAQSEG",$J,DOM)=DOMNODE,SEG=""
F S SEG=$O(^TMP("VAQSEG",$J,SDAT,SEG)) Q:SEG="" D C2
QUIT
C2 S SEGNODE=$G(^TMP("VAQSEG",$J,SDAT,SEG)),^TMP("VAQSEG",$J,DOM,SEG)=SEGNODE
QUIT
;
LISTD ; -- Displays a list domains selected
S POP=1
I '$D(^TMP("VAQCOPY",$J)) W !!,"** NO DOMAIN(S) SELECTED" QUIT
W !!,"------------------------------ Domains Selected ------------------------------"
S N="" F L=0:1 S N=$O(^TMP("VAQCOPY",$J,N)) Q:N="" W:'(L#8) ! W ?L#8*40 W N
W !,"-------------------------------------------------------------------------------"
W ! QUIT
;
END ; -- End of code
QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVAQREQ05 3292 printed Apr 09, 2024@21:29:16 Page 2
VAQREQ05 ;ALB/JFP - REQUEST PDX RECORD, COPY DOMAIN;01MAR93
+1 ;;1.5;PATIENT DATA EXCHANGE;**30**;NOV 17, 1993
EP ; -- Main entry point for the list processor
+1 ; - Called from VAQREQ02
+2 ;
REQ ; -- Request domain
+1 NEW SDI,SDAT,DIRUT,DTOUT,DUOUT,X,Y,N,L,POP
+2 NEW INSTDA,INST,STNO,GRP,GRPDA,DOMDA,DOMAIN,DOM,DOMNODE
+3 SET SDI=0
+4 FOR
SET SDI=$ORDER(VALMY(SDI))
if SDI=""
QUIT
Begin DoDot:1
+5 SET SDAT=$GET(^TMP("VAQIDX",$JOB,SDI))
End DoDot:1
+6 ;
+7 FOR
DO ASKDOM
if $DATA(DIRUT)
QUIT
+8 if $DATA(^TMP("VAQCOPY",$JOB))
DO COPY
+9 KILL SDI,SDAT,VALMY,DIRUT,DTOUT,DUOUT,X,Y,N,L,POP
+10 KILL INSTDA,INST,STNO,GRP,GRPDA,DOMDA,DOMAIN,DOM,DOMNODE
+11 KILL ^TMP("VAQCOPY",$JOB),SEGNODE
+12 QUIT
+13 ;
ASKDOM ; -- Call to Dir to request domain
+1 if $DATA(^TMP("VAQCOPY",$JOB))
DO LISTD
+2 SET POP=0
+3 SET DIR("A")="Copy to Domain: "
+4 SET DIR(0)="FAO^1:30"
+5 SET DIR("?")="^D HLPDOM1^VAQREQ09"
+6 SET DIR("??")="^D HLPDOM2^VAQREQ09"
+7 WRITE !
DO ^DIR
KILL DIR
if $DATA(DIRUT)
QUIT
+8 SET X=Y
+9 IF X="*L"
DO LISTD
if POP
QUIT
+10 IF $EXTRACT(X,1,1)="-"
DO DELDOM
if POP
QUIT
+11 IF $EXTRACT(X,1,2)'="G."
DO DOM
if POP
QUIT
+12 IF $EXTRACT(X,1,2)="G."
DO GDOM
if POP
QUIT
+13 QUIT
+14 ;
DOM ; -- Dic lookup to verify domain in file 4.2
+1 NEW FLAGS
+2 SET DIC="^DIC(4.2,"
SET DIC(0)="EMQZ"
+3 DO ^DIC
KILL DIC
IF $DATA(DTOUT)!$DATA(DUOUT)!(Y<0)
SET POP=1
QUIT
+4 ; -- Check for closed domains
+5 SET FLAGS=$PIECE(Y(0),U,2)
+6 IF FLAGS["C"
WRITE $CHAR(7)," ...Domain is closed"
SET POP=1
QUIT
+7 ;
+8 SET INSTDA=$PIECE(Y(0),U,13)
SET DOMAIN=$PIECE(Y,U,2)
+9 IF INSTDA=""
WRITE " ...Domain entered does not have a station number"
SET POP=1
QUIT
+10 SET STNO=$ORDER(^DIC(4,"D",INSTDA,""))
+11 IF STNO=""
WRITE " ...Domain does not have a valid station number"
SET POP=1
QUIT
+12 SET INST=$PIECE(^DIC(4,STNO,0),U,1)
SET ^TMP("VAQCOPY",$JOB,DOMAIN)=INSTDA_"^"_INST
+13 QUIT
+14 ;
GDOM ; -- Dic lookup to verify domain group name in file 394.83
+1 ; -- strip off G.
SET X=$PIECE(X,".",2)
+2 SET DIC="^VAT(394.83,"
+3 SET DIC(0)="EMQZ"
+4 DO ^DIC
KILL DIC
IF $DATA(DTOUT)!$DATA(DUOUT)!(Y<0)
SET POP=1
QUIT
+5 SET GRP=$PIECE(Y,U,2)
SET GRPDA=""
SET GRPDA=$ORDER(^VAT(394.83,"B",GRP,GRPDA))
+6 DO G1
+7 QUIT
+8 ;
G1 SET (INSTDA,DOMDA)=""
+1 FOR
SET INSTDA=$ORDER(^VAT(394.83,GRPDA,"FAC","A-OUTGRP",INSTDA))
if 'INSTDA
QUIT
DO G2
+2 QUIT
G2 FOR
SET DOMDA=$ORDER(^VAT(394.83,GRPDA,"FAC","A-OUTGRP",INSTDA,DOMDA))
if 'DOMDA
QUIT
DO SETG
+1 QUIT
+2 ;
SETG ; --
+1 if '$$OKDOM^VAQREQ03(GRPDA,INSTDA,DOMDA)
QUIT
+2 SET INST=$PIECE($GET(^DIC(4,INSTDA,0)),U,1)
+3 SET DOMAIN=$PIECE($GET(^DIC(4.2,DOMDA,0)),U,1)
+4 SET ^TMP("VAQCOPY",$JOB,DOMAIN)=INSTDA_"^"_INST
+5 QUIT
+6 ;
DELDOM ; -- Deletes domain & segments associated with domain
+1 SET POP=1
SET X=$EXTRACT(X,2,99)
+2 IF X=""
WRITE !!,"** NO ENTRIES SELECTED"
QUIT
+3 IF '$DATA(^TMP("VAQCOPY",$JOB,X))
WRITE " ... ",X," Not Selected"
QUIT
+4 KILL ^TMP("VAQCOPY",$JOB,X)
+5 QUIT
+6 ;
COPY ; -- Copies segments to new domain(s)
+1 SET DOM=""
+2 FOR
SET DOM=$ORDER(^TMP("VAQCOPY",$JOB,DOM))
if DOM=""
QUIT
DO C1
+3 QUIT
+4 ;
C1 SET DOMNODE=$GET(^TMP("VAQCOPY",$JOB,DOM))
SET ^TMP("VAQSEG",$JOB,DOM)=DOMNODE
SET SEG=""
+1 FOR
SET SEG=$ORDER(^TMP("VAQSEG",$JOB,SDAT,SEG))
if SEG=""
QUIT
DO C2
+2 QUIT
C2 SET SEGNODE=$GET(^TMP("VAQSEG",$JOB,SDAT,SEG))
SET ^TMP("VAQSEG",$JOB,DOM,SEG)=SEGNODE
+1 QUIT
+2 ;
LISTD ; -- Displays a list domains selected
+1 SET POP=1
+2 IF '$DATA(^TMP("VAQCOPY",$JOB))
WRITE !!,"** NO DOMAIN(S) SELECTED"
QUIT
+3 WRITE !!,"------------------------------ Domains Selected ------------------------------"
+4 SET N=""
FOR L=0:1
SET N=$ORDER(^TMP("VAQCOPY",$JOB,N))
if N=""
QUIT
if '(L#8)
WRITE !
WRITE ?L#8*40
WRITE N
+5 WRITE !,"-------------------------------------------------------------------------------"
+6 WRITE !
QUIT
+7 ;
END ; -- End of code
+1 QUIT
