| [613] | 1 | VAQREQ05 ;ALB/JFP - REQUEST PDX RECORD, COPY DOMAIN;01MAR93
|
|---|
| 2 | ;;1.5;PATIENT DATA EXCHANGE;**30**;NOV 17, 1993
|
|---|
| 3 | EP ; -- Main entry point for the list processor
|
|---|
| 4 | ; - Called from VAQREQ02
|
|---|
| 5 | ;
|
|---|
| 6 | REQ ; -- Request domain
|
|---|
| 7 | N SDI,SDAT,DIRUT,DTOUT,DUOUT,X,Y,N,L,POP
|
|---|
| 8 | N INSTDA,INST,STNO,GRP,GRPDA,DOMDA,DOMAIN,DOM,DOMNODE
|
|---|
| 9 | S SDI=0
|
|---|
| 10 | F S SDI=$O(VALMY(SDI)) Q:SDI="" D
|
|---|
| 11 | .S SDAT=$G(^TMP("VAQIDX",$J,SDI))
|
|---|
| 12 | ;
|
|---|
| 13 | F D ASKDOM Q:$D(DIRUT)
|
|---|
| 14 | D:$D(^TMP("VAQCOPY",$J)) COPY
|
|---|
| 15 | K SDI,SDAT,VALMY,DIRUT,DTOUT,DUOUT,X,Y,N,L,POP
|
|---|
| 16 | K INSTDA,INST,STNO,GRP,GRPDA,DOMDA,DOMAIN,DOM,DOMNODE
|
|---|
| 17 | K ^TMP("VAQCOPY",$J),SEGNODE
|
|---|
| 18 | QUIT
|
|---|
| 19 | ;
|
|---|
| 20 | ASKDOM ; -- Call to Dir to request domain
|
|---|
| 21 | D:$D(^TMP("VAQCOPY",$J)) LISTD
|
|---|
| 22 | S POP=0
|
|---|
| 23 | S DIR("A")="Copy to Domain: "
|
|---|
| 24 | S DIR(0)="FAO^1:30"
|
|---|
| 25 | S DIR("?")="^D HLPDOM1^VAQREQ09"
|
|---|
| 26 | S DIR("??")="^D HLPDOM2^VAQREQ09"
|
|---|
| 27 | W ! D ^DIR K DIR Q:$D(DIRUT)
|
|---|
| 28 | S X=Y
|
|---|
| 29 | I X="*L" D LISTD Q:POP
|
|---|
| 30 | I $E(X,1,1)="-" D DELDOM Q:POP
|
|---|
| 31 | I $E(X,1,2)'="G." D DOM Q:POP
|
|---|
| 32 | I $E(X,1,2)="G." D GDOM Q:POP
|
|---|
| 33 | QUIT
|
|---|
| 34 | ;
|
|---|
| 35 | DOM ; -- Dic lookup to verify domain in file 4.2
|
|---|
| 36 | N FLAGS
|
|---|
| 37 | S DIC="^DIC(4.2,",DIC(0)="EMQZ"
|
|---|
| 38 | D ^DIC K DIC I $D(DTOUT)!$D(DUOUT)!(Y<0) S POP=1 QUIT
|
|---|
| 39 | ; -- Check for closed domains
|
|---|
| 40 | S FLAGS=$P(Y(0),U,2)
|
|---|
| 41 | I FLAGS["C" W $C(7)," ...Domain is closed" S POP=1 QUIT
|
|---|
| 42 | ;
|
|---|
| 43 | S INSTDA=$P(Y(0),U,13),DOMAIN=$P(Y,U,2)
|
|---|
| 44 | I INSTDA="" W " ...Domain entered does not have a station number" S POP=1 QUIT
|
|---|
| 45 | S STNO=$O(^DIC(4,"D",INSTDA,""))
|
|---|
| 46 | I STNO="" W " ...Domain does not have a valid station number" S POP=1 QUIT
|
|---|
| 47 | S INST=$P(^DIC(4,STNO,0),U,1),^TMP("VAQCOPY",$J,DOMAIN)=INSTDA_"^"_INST
|
|---|
| 48 | QUIT
|
|---|
| 49 | ;
|
|---|
| 50 | GDOM ; -- Dic lookup to verify domain group name in file 394.83
|
|---|
| 51 | S X=$P(X,".",2) ; -- strip off G.
|
|---|
| 52 | S DIC="^VAT(394.83,"
|
|---|
| 53 | S DIC(0)="EMQZ"
|
|---|
| 54 | D ^DIC K DIC I $D(DTOUT)!$D(DUOUT)!(Y<0) S POP=1 QUIT
|
|---|
| 55 | S GRP=$P(Y,U,2),GRPDA="",GRPDA=$O(^VAT(394.83,"B",GRP,GRPDA))
|
|---|
| 56 | D G1
|
|---|
| 57 | QUIT
|
|---|
| 58 | ;
|
|---|
| 59 | G1 S (INSTDA,DOMDA)=""
|
|---|
| 60 | F S INSTDA=$O(^VAT(394.83,GRPDA,"FAC","A-OUTGRP",INSTDA)) Q:'INSTDA D G2
|
|---|
| 61 | QUIT
|
|---|
| 62 | G2 F S DOMDA=$O(^VAT(394.83,GRPDA,"FAC","A-OUTGRP",INSTDA,DOMDA)) Q:'DOMDA D SETG
|
|---|
| 63 | QUIT
|
|---|
| 64 | ;
|
|---|
| 65 | SETG ; --
|
|---|
| 66 | Q:'$$OKDOM^VAQREQ03(GRPDA,INSTDA,DOMDA)
|
|---|
| 67 | S INST=$P($G(^DIC(4,INSTDA,0)),U,1)
|
|---|
| 68 | S DOMAIN=$P($G(^DIC(4.2,DOMDA,0)),U,1)
|
|---|
| 69 | S ^TMP("VAQCOPY",$J,DOMAIN)=INSTDA_"^"_INST
|
|---|
| 70 | QUIT
|
|---|
| 71 | ;
|
|---|
| 72 | DELDOM ; -- Deletes domain & segments associated with domain
|
|---|
| 73 | S POP=1,X=$E(X,2,99)
|
|---|
| 74 | I X="" W !!,"** NO ENTRIES SELECTED" QUIT
|
|---|
| 75 | I '$D(^TMP("VAQCOPY",$J,X)) W " ... ",X," Not Selected" QUIT
|
|---|
| 76 | K ^TMP("VAQCOPY",$J,X)
|
|---|
| 77 | QUIT
|
|---|
| 78 | ;
|
|---|
| 79 | COPY ; -- Copies segments to new domain(s)
|
|---|
| 80 | S DOM=""
|
|---|
| 81 | F S DOM=$O(^TMP("VAQCOPY",$J,DOM)) Q:DOM="" D C1
|
|---|
| 82 | QUIT
|
|---|
| 83 | ;
|
|---|
| 84 | C1 S DOMNODE=$G(^TMP("VAQCOPY",$J,DOM)),^TMP("VAQSEG",$J,DOM)=DOMNODE,SEG=""
|
|---|
| 85 | F S SEG=$O(^TMP("VAQSEG",$J,SDAT,SEG)) Q:SEG="" D C2
|
|---|
| 86 | QUIT
|
|---|
| 87 | C2 S SEGNODE=$G(^TMP("VAQSEG",$J,SDAT,SEG)),^TMP("VAQSEG",$J,DOM,SEG)=SEGNODE
|
|---|
| 88 | QUIT
|
|---|
| 89 | ;
|
|---|
| 90 | LISTD ; -- Displays a list domains selected
|
|---|
| 91 | S POP=1
|
|---|
| 92 | I '$D(^TMP("VAQCOPY",$J)) W !!,"** NO DOMAIN(S) SELECTED" QUIT
|
|---|
| 93 | W !!,"------------------------------ Domains Selected ------------------------------"
|
|---|
| 94 | S N="" F L=0:1 S N=$O(^TMP("VAQCOPY",$J,N)) Q:N="" W:'(L#8) ! W ?L#8*40 W N
|
|---|
| 95 | W !,"-------------------------------------------------------------------------------"
|
|---|
| 96 | W ! QUIT
|
|---|
| 97 | ;
|
|---|
| 98 | END ; -- End of code
|
|---|
| 99 | QUIT
|
|---|
