VAQREQ03 ;ALB/JFP - PDX, REQUEST PATIENT DATA, ASK DOMAIN/SEGMENT;01MAR93<<= NOT VERIFIED > [ 10/18/96 9:19 AM ]
;;1.5;PATIENT DATA EXCHANGE;**22,30**;NOV 17, 1993
EP ; -- Main entry point
; - Called from VAQREQ02
; - Calls ask segment routine VAQREQ04
; - Calls help routine VAQREQ09
;
REQ ; -- Request domain
N L,N,X,POP,INSTDA,DOMAIN,STNO,INST,DOMDA,FLAGS
N DIRUT,DTOUT,DUOUT
;
S SEGNO="",SEGNO=$O(^VAT(394.71,"C","PDX*MIN",SEGNO))
S SEGNME=$P($G(^VAT(394.71,SEGNO,0)),U,1)
;
F D ASKDOM Q:$D(DIRUT)
QUIT
;
ASKDOM ; -- Call to Dir to request domain
D:$D(^TMP("VAQSEG",$J)) LISTD
K ^TMP("VAQDOM",$J)
S POP=0
S DIR("A")="Enter 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
D EP^VAQREQ04 ; -- ask segments
QUIT
;
DOM ; -- Dic lookup to verify domain in file 4.2
S 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 STNO=$P(Y(0),U,13),DOMAIN=$P(Y,U,2)
I STNO="" W " ...Domain entered does not have a station number" S POP=1 QUIT
S INSTDA=$O(^DIC(4,"D",STNO,""))
I INSTDA="" W " ...Domain does not have a valid station number" S POP=1 QUIT
S INST=$P(^DIC(4,INSTDA,0),U,1)
S ^TMP("VAQSEG",$J,DOMAIN,"PDX*MIN")=SEGNO_"^"_SEGNME
S ^TMP("VAQDOM",$J,DOMAIN)=""
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 I=1:1 S INSTDA=$O(^VAT(394.83,GRPDA,"FAC","A-OUTGRP",INSTDA)) Q:'INSTDA D G2
QUIT
G2 F I=1:1 S DOMDA=$O(^VAT(394.83,GRPDA,"FAC","A-OUTGRP",INSTDA,DOMDA)) Q:'DOMDA D SETG
QUIT
;
SETG ; --
Q:'$$OKDOM(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("VAQSEG",$J,DOMAIN,"PDX*MIN")=SEGNO_"^"_SEGNME
S ^TMP("VAQDOM",$J,DOMAIN)=""
QUIT
OKDOM(GRPDA,INSTDA,DOMDA) ;
N REC
S REC=$G(^DIC(4.2,DOMDA,0))
Q:$P(REC,U,2)'["C" 1
; Domain is closed. Tell the user and delete the remote facility
; record from the group.
W !!,"Domain ",$P(REC,U,1)," is closed."
N FDA,VIEN
S VIEN=$O(^VAT(394.83,GRPDA,"FAC","B",INSTDA,0)) Q:'VIEN
S FDA(394.831,VIEN_","_GRPDA_",",.01)="@"
D FILE^DIE("","FDA")
W !,"Because of that, Facility '",$P($G(^DIC(4,INSTDA,0)),U,1),"'"
W !,"has been deleted from Outgoing Group '",$P($G(^VAT(394.83,GRPDA,0)),U,1),"'."
Q 0
;
DELDOM ; -- Deletes domain & segments associated with domain
S POP=1,X=$E(X,2,99)
I X="" W !!,"** NO ENTRIES SELECTED" QUIT
S X=$$PARTIC^VAQUTL94("^TMP(""VAQSEG"","_$J_")",X)
I X=-1 W " ... Not Selected" QUIT
I '$D(^TMP("VAQSEG",$J,X)) W " ... ",X," Not Selected" QUIT
K ^TMP("VAQSEG",$J,X)
W " ...domain deleted and associated segments"
QUIT
;
LISTD ; -- Displays a list domains selected
S POP=1
I '$D(^TMP("VAQSEG",$J)) W !!,"** NO DOMAIN(S) SELECTED" QUIT
W !!,"------------------------------ Domains Selected ------------------------------"
S N="" F L=0:1 S N=$O(^TMP("VAQSEG",$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[HVAQREQ03 3674 printed Dec 13, 2024@02:26:43 Page 2
VAQREQ03 ;ALB/JFP - PDX, REQUEST PATIENT DATA, ASK DOMAIN/SEGMENT;01MAR93<<= NOT VERIFIED > [ 10/18/96 9:19 AM ]
+1 ;;1.5;PATIENT DATA EXCHANGE;**22,30**;NOV 17, 1993
EP ; -- Main entry point
+1 ; - Called from VAQREQ02
+2 ; - Calls ask segment routine VAQREQ04
+3 ; - Calls help routine VAQREQ09
+4 ;
REQ ; -- Request domain
+1 NEW L,N,X,POP,INSTDA,DOMAIN,STNO,INST,DOMDA,FLAGS
+2 NEW DIRUT,DTOUT,DUOUT
+3 ;
+4 SET SEGNO=""
SET SEGNO=$ORDER(^VAT(394.71,"C","PDX*MIN",SEGNO))
+5 SET SEGNME=$PIECE($GET(^VAT(394.71,SEGNO,0)),U,1)
+6 ;
+7 FOR
DO ASKDOM
if $DATA(DIRUT)
QUIT
+8 QUIT
+9 ;
ASKDOM ; -- Call to Dir to request domain
+1 if $DATA(^TMP("VAQSEG",$JOB))
DO LISTD
+2 KILL ^TMP("VAQDOM",$JOB)
+3 SET POP=0
+4 SET DIR("A")="Enter Domain: "
+5 SET DIR(0)="FAO^1:30"
+6 SET DIR("?")="^D HLPDOM1^VAQREQ09"
+7 SET DIR("??")="^D HLPDOM2^VAQREQ09"
+8 WRITE !
DO ^DIR
KILL DIR
if $DATA(DIRUT)
QUIT
+9 SET X=Y
+10 IF X="*L"
DO LISTD
if POP
QUIT
+11 IF $EXTRACT(X,1,1)="-"
DO DELDOM
if POP
QUIT
+12 IF $EXTRACT(X,1,2)'="G."
DO DOM
if POP
QUIT
+13 IF $EXTRACT(X,1,2)="G."
DO GDOM
if POP
QUIT
+14 ; -- ask segments
DO EP^VAQREQ04
+15 QUIT
+16 ;
DOM ; -- Dic lookup to verify domain in file 4.2
+1 SET DIC=4.2
SET DIC(0)="EMQZ"
+2 DO ^DIC
KILL DIC
IF $DATA(DTOUT)!$DATA(DUOUT)!(Y<0)
SET POP=1
QUIT
+3 ; -- Check for closed domains
+4 SET FLAGS=$PIECE(Y(0),U,2)
+5 IF FLAGS["C"
WRITE $CHAR(7)," ...Domain is closed"
SET POP=1
QUIT
+6 ;
+7 SET STNO=$PIECE(Y(0),U,13)
SET DOMAIN=$PIECE(Y,U,2)
+8 IF STNO=""
WRITE " ...Domain entered does not have a station number"
SET POP=1
QUIT
+9 SET INSTDA=$ORDER(^DIC(4,"D",STNO,""))
+10 IF INSTDA=""
WRITE " ...Domain does not have a valid station number"
SET POP=1
QUIT
+11 SET INST=$PIECE(^DIC(4,INSTDA,0),U,1)
+12 SET ^TMP("VAQSEG",$JOB,DOMAIN,"PDX*MIN")=SEGNO_"^"_SEGNME
+13 SET ^TMP("VAQDOM",$JOB,DOMAIN)=""
+14 QUIT
+15 ;
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 I=1:1
SET INSTDA=$ORDER(^VAT(394.83,GRPDA,"FAC","A-OUTGRP",INSTDA))
if 'INSTDA
QUIT
DO G2
+2 QUIT
G2 FOR I=1:1
SET DOMDA=$ORDER(^VAT(394.83,GRPDA,"FAC","A-OUTGRP",INSTDA,DOMDA))
if 'DOMDA
QUIT
DO SETG
+1 QUIT
+2 ;
SETG ; --
+1 if '$$OKDOM(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("VAQSEG",$JOB,DOMAIN,"PDX*MIN")=SEGNO_"^"_SEGNME
+5 SET ^TMP("VAQDOM",$JOB,DOMAIN)=""
+6 QUIT
OKDOM(GRPDA,INSTDA,DOMDA) ;
+1 NEW REC
+2 SET REC=$GET(^DIC(4.2,DOMDA,0))
+3 if $PIECE(REC,U,2)'["C"
QUIT 1
+4 ; Domain is closed. Tell the user and delete the remote facility
+5 ; record from the group.
+6 WRITE !!,"Domain ",$PIECE(REC,U,1)," is closed."
+7 NEW FDA,VIEN
+8 SET VIEN=$ORDER(^VAT(394.83,GRPDA,"FAC","B",INSTDA,0))
if 'VIEN
QUIT
+9 SET FDA(394.831,VIEN_","_GRPDA_",",.01)="@"
+10 DO FILE^DIE("","FDA")
+11 WRITE !,"Because of that, Facility '",$PIECE($GET(^DIC(4,INSTDA,0)),U,1),"'"
+12 WRITE !,"has been deleted from Outgoing Group '",$PIECE($GET(^VAT(394.83,GRPDA,0)),U,1),"'."
+13 QUIT 0
+14 ;
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 SET X=$$PARTIC^VAQUTL94("^TMP(""VAQSEG"","_$JOB_")",X)
+4 IF X=-1
WRITE " ... Not Selected"
QUIT
+5 IF '$DATA(^TMP("VAQSEG",$JOB,X))
WRITE " ... ",X," Not Selected"
QUIT
+6 KILL ^TMP("VAQSEG",$JOB,X)
+7 WRITE " ...domain deleted and associated segments"
+8 QUIT
+9 ;
LISTD ; -- Displays a list domains selected
+1 SET POP=1
+2 IF '$DATA(^TMP("VAQSEG",$JOB))
WRITE !!,"** NO DOMAIN(S) SELECTED"
QUIT
+3 WRITE !!,"------------------------------ Domains Selected ------------------------------"
+4 SET N=""
FOR L=0:1
SET N=$ORDER(^TMP("VAQSEG",$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
