VAQREQ03.m

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 ---VAQREQ03   3674     printed  Feb 18, 2025@23:52:46                                                                                                                                                                                                    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