- 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 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