VAQREQ05.m

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 ---VAQREQ05   3292     printed  Feb 18, 2025@23:52:48                                                                                                                                                                                                    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