Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: VAQREQ03

VAQREQ03.m

Go to the documentation of this file.
  1. 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
  1. EP ; -- Main entry point
  1. ; - Called from VAQREQ02
  1. ; - Calls ask segment routine VAQREQ04
  1. ; - Calls help routine VAQREQ09
  1. ;
  1. REQ ; -- Request domain
  1. N L,N,X,POP,INSTDA,DOMAIN,STNO,INST,DOMDA,FLAGS
  1. N DIRUT,DTOUT,DUOUT
  1. ;
  1. S SEGNO="",SEGNO=$O(^VAT(394.71,"C","PDX*MIN",SEGNO))
  1. S SEGNME=$P($G(^VAT(394.71,SEGNO,0)),U,1)
  1. ;
  1. F D ASKDOM Q:$D(DIRUT)
  1. QUIT
  1. ;
  1. ASKDOM ; -- Call to Dir to request domain
  1. D:$D(^TMP("VAQSEG",$J)) LISTD
  1. K ^TMP("VAQDOM",$J)
  1. S POP=0
  1. S DIR("A")="Enter Domain: "
  1. S DIR(0)="FAO^1:30"
  1. S DIR("?")="^D HLPDOM1^VAQREQ09"
  1. S DIR("??")="^D HLPDOM2^VAQREQ09"
  1. W ! D ^DIR K DIR Q:$D(DIRUT)
  1. S X=Y
  1. I X="*L" D LISTD Q:POP
  1. I $E(X,1,1)="-" D DELDOM Q:POP
  1. I $E(X,1,2)'="G." D DOM Q:POP
  1. I $E(X,1,2)="G." D GDOM Q:POP
  1. D EP^VAQREQ04 ; -- ask segments
  1. QUIT
  1. ;
  1. DOM ; -- Dic lookup to verify domain in file 4.2
  1. S DIC=4.2,DIC(0)="EMQZ"
  1. D ^DIC K DIC I $D(DTOUT)!$D(DUOUT)!(Y<0) S POP=1 QUIT
  1. ; -- Check for closed domains
  1. S FLAGS=$P(Y(0),U,2)
  1. I FLAGS["C" W $C(7)," ...Domain is closed" S POP=1 QUIT
  1. ;
  1. S STNO=$P(Y(0),U,13),DOMAIN=$P(Y,U,2)
  1. I STNO="" W " ...Domain entered does not have a station number" S POP=1 QUIT
  1. S INSTDA=$O(^DIC(4,"D",STNO,""))
  1. I INSTDA="" W " ...Domain does not have a valid station number" S POP=1 QUIT
  1. S INST=$P(^DIC(4,INSTDA,0),U,1)
  1. S ^TMP("VAQSEG",$J,DOMAIN,"PDX*MIN")=SEGNO_"^"_SEGNME
  1. S ^TMP("VAQDOM",$J,DOMAIN)=""
  1. QUIT
  1. ;
  1. GDOM ; -- Dic lookup to verify domain group name in file 394.83
  1. S X=$P(X,".",2) ; -- strip off G.
  1. S DIC="^VAT(394.83,"
  1. S DIC(0)="EMQZ"
  1. D ^DIC K DIC I $D(DTOUT)!$D(DUOUT)!(Y<0) S POP=1 QUIT
  1. S GRP=$P(Y,U,2),GRPDA="",GRPDA=$O(^VAT(394.83,"B",GRP,GRPDA))
  1. D G1
  1. QUIT
  1. ;
  1. G1 S (INSTDA,DOMDA)=""
  1. F I=1:1 S INSTDA=$O(^VAT(394.83,GRPDA,"FAC","A-OUTGRP",INSTDA)) Q:'INSTDA D G2
  1. QUIT
  1. G2 F I=1:1 S DOMDA=$O(^VAT(394.83,GRPDA,"FAC","A-OUTGRP",INSTDA,DOMDA)) Q:'DOMDA D SETG
  1. QUIT
  1. ;
  1. SETG ; --
  1. Q:'$$OKDOM(GRPDA,INSTDA,DOMDA)
  1. S INST=$P($G(^DIC(4,INSTDA,0)),U,1)
  1. S DOMAIN=$P($G(^DIC(4.2,DOMDA,0)),U,1)
  1. S ^TMP("VAQSEG",$J,DOMAIN,"PDX*MIN")=SEGNO_"^"_SEGNME
  1. S ^TMP("VAQDOM",$J,DOMAIN)=""
  1. QUIT
  1. OKDOM(GRPDA,INSTDA,DOMDA) ;
  1. N REC
  1. S REC=$G(^DIC(4.2,DOMDA,0))
  1. Q:$P(REC,U,2)'["C" 1
  1. ; Domain is closed. Tell the user and delete the remote facility
  1. ; record from the group.
  1. W !!,"Domain ",$P(REC,U,1)," is closed."
  1. N FDA,VIEN
  1. S VIEN=$O(^VAT(394.83,GRPDA,"FAC","B",INSTDA,0)) Q:'VIEN
  1. S FDA(394.831,VIEN_","_GRPDA_",",.01)="@"
  1. D FILE^DIE("","FDA")
  1. W !,"Because of that, Facility '",$P($G(^DIC(4,INSTDA,0)),U,1),"'"
  1. W !,"has been deleted from Outgoing Group '",$P($G(^VAT(394.83,GRPDA,0)),U,1),"'."
  1. Q 0
  1. ;
  1. DELDOM ; -- Deletes domain & segments associated with domain
  1. S POP=1,X=$E(X,2,99)
  1. I X="" W !!,"** NO ENTRIES SELECTED" QUIT
  1. S X=$$PARTIC^VAQUTL94("^TMP(""VAQSEG"","_$J_")",X)
  1. I X=-1 W " ... Not Selected" QUIT
  1. I '$D(^TMP("VAQSEG",$J,X)) W " ... ",X," Not Selected" QUIT
  1. K ^TMP("VAQSEG",$J,X)
  1. W " ...domain deleted and associated segments"
  1. QUIT
  1. ;
  1. LISTD ; -- Displays a list domains selected
  1. S POP=1
  1. I '$D(^TMP("VAQSEG",$J)) W !!,"** NO DOMAIN(S) SELECTED" QUIT
  1. W !!,"------------------------------ Domains Selected ------------------------------"
  1. S N="" F L=0:1 S N=$O(^TMP("VAQSEG",$J,N)) Q:N="" W:'(L#8) ! W ?L#8*40 W N
  1. W !,"-------------------------------------------------------------------------------"
  1. W ! QUIT
  1. ;
  1. END ; -- End of code
  1. QUIT