| [613] | 1 | VAQREQ04 ;ALB/JFP - PDX, REQUEST PATIENT DATA, ASK SEGMENT;01MAR93
|
|---|
| 2 | ;;1.5;PATIENT DATA EXCHANGE;;NOV 17, 1993
|
|---|
| 3 | EP ; -- Entry point, second level of loop in VAQREQ03
|
|---|
| 4 | ; NOTE: PDX*MIN is hard coded in this routine
|
|---|
| 5 | ; - Called from VAQREQ03
|
|---|
| 6 | ; - Calls help routine VAQREQ09
|
|---|
| 7 | ;
|
|---|
| 8 | REQ ; -- Request segment
|
|---|
| 9 | N DIRUT,DTOUT,DUOUT,X,I,N,L
|
|---|
| 10 | N GRPDA,SEGDA,SEGMNU,SEGNODE,SEGNO,SEGNME,GTYPE,GDUZ,GRP
|
|---|
| 11 | ;
|
|---|
| 12 | DRIVER ; -- Driver loop
|
|---|
| 13 | I $D(^TMP("VAQSEG",$J,DOMAIN)) D LISTS ; -- displays segments on edit
|
|---|
| 14 | F D ASKSEG Q:$D(DIRUT)
|
|---|
| 15 | ; -- Cleanup and exit
|
|---|
| 16 | K DIRUT,DTOUT,DUOUT,X,I,N,L
|
|---|
| 17 | K SEGDA,SEGMNU,SEGNODE,SEGNO,SEGNME,GTYPE,GDUZ,GRP,GRPDA
|
|---|
| 18 | QUIT
|
|---|
| 19 | ;
|
|---|
| 20 | ASKSEG ; -- Prompts for segments
|
|---|
| 21 | ; -- Sets default segment to PDX*MIN, Minimum patient information
|
|---|
| 22 | ; Note: PDX*MIN is hard coded in this routine, if this mnuemonic
|
|---|
| 23 | ; changes, the routine must change (ASKSEG+3)
|
|---|
| 24 | ;
|
|---|
| 25 | I '$D(^TMP("VAQSEG",$J,DOMAIN,"PDX*MIN")) D
|
|---|
| 26 | .S SEGNO="",SEGNO=$O(^VAT(394.71,"C","PDX*MIN",SEGNO))
|
|---|
| 27 | .S SEGNME=$P($G(^VAT(394.71,SEGNO,0)),U,1)
|
|---|
| 28 | .S ^TMP("VAQSEG",$J,DOMAIN,"PDX*MIN")=SEGNO_"^"_SEGNME
|
|---|
| 29 | ;
|
|---|
| 30 | ; -- Call to Dir to request segments
|
|---|
| 31 | S POP=0
|
|---|
| 32 | S DIR("A")=" Enter Segment: "
|
|---|
| 33 | S DIR(0)="FAO^1:30"
|
|---|
| 34 | S DIR("?")="^D HLPSEG1^VAQREQ09"
|
|---|
| 35 | S DIR("??")="^D HLPSEG2^VAQREQ09"
|
|---|
| 36 | W ! D ^DIR K DIR Q:$D(DIRUT)
|
|---|
| 37 | S X=Y
|
|---|
| 38 | I X="*L" D LISTS Q:POP
|
|---|
| 39 | I $E(X,1,1)="-" D DELSEG Q:POP
|
|---|
| 40 | I $E(X,1,2)'="G." D SEG Q:POP
|
|---|
| 41 | I $E(X,1,2)="G." D GSEG Q:POP
|
|---|
| 42 | QUIT
|
|---|
| 43 | ;
|
|---|
| 44 | SEG ; -- Dic lookup to verify segment in file 394.71
|
|---|
| 45 | S DIC="^VAT(394.71,",DIC(0)="EMQZ"
|
|---|
| 46 | D ^DIC K DIC I $D(DTOUT)!$D(DUOUT)!(Y<0) S POP=1 QUIT
|
|---|
| 47 | S SEGNME=$P(Y(0),U,1),SEGMNU=$P(Y(0),U,2)
|
|---|
| 48 | S SEGDA="",SEGDA=$O(^VAT(394.71,"C",SEGMNU,SEGDA))
|
|---|
| 49 | S HSCOMPND=$$HLTHSEG^VAQDBIH1(SEGMNU,0)
|
|---|
| 50 | I $P(HSCOMPND,U,1)'=0 D EP^VAQREQ11 ; -- Time and occurrence
|
|---|
| 51 | D FLESEG
|
|---|
| 52 | QUIT
|
|---|
| 53 | ;
|
|---|
| 54 | GSEG ; -- Dic lookup to verify segment group name in file 394.84
|
|---|
| 55 | S X=$P(X,".",2) ; -- strip off G.
|
|---|
| 56 | S DIC="^VAT(394.84,"
|
|---|
| 57 | S DIC(0)="EMQZ"
|
|---|
| 58 | D ^DIC K DIC I $D(DTOUT)!$D(DUOUT)!(Y<0) S POP=1 QUIT
|
|---|
| 59 | S GTYPE=$P(Y(0),U,2),GDUZ=$P(Y(0),U,3)
|
|---|
| 60 | I (GTYPE="0")&(DUZ'=GDUZ) D QUIT
|
|---|
| 61 | .W " ...Private group selected not associated with user"
|
|---|
| 62 | .S POP=1
|
|---|
| 63 | S GRP=$P(Y,U,2),GRPDA="",GRPDA=$O(^VAT(394.84,"B",GRP,GRPDA))
|
|---|
| 64 | D S1
|
|---|
| 65 | QUIT
|
|---|
| 66 | ;
|
|---|
| 67 | S1 S SEGDA=""
|
|---|
| 68 | F S SEGDA=$O(^VAT(394.84,GRPDA,"SEG","B",SEGDA)) Q:SEGDA="" D SETS
|
|---|
| 69 | QUIT
|
|---|
| 70 | SETS S SEGNODE=$G(^VAT(394.71,SEGDA,0))
|
|---|
| 71 | Q:SEGNODE=""
|
|---|
| 72 | S SEGNME=$P(SEGNODE,U,1),SEGMNU=$P(SEGNODE,U,2)
|
|---|
| 73 | S HSCOMPND=$$HLTHSEG^VAQDBIH1(SEGMNU,0)
|
|---|
| 74 | I $P(HSCOMPND,U,1)'=0 D GROUP ; -- Time and occurrence
|
|---|
| 75 | D FLESEG
|
|---|
| 76 | QUIT
|
|---|
| 77 | ;
|
|---|
| 78 | GROUP ; -- Sets time and occurrence limits for segment groups selected
|
|---|
| 79 | S PARAMND=$G(^VAT(394.81,1,"LIMITS")) ; -- sets time & occ defaults
|
|---|
| 80 | S TLDEF=$P(PARAMND,U,1)
|
|---|
| 81 | S OLDEF=$P(PARAMND,U,2)
|
|---|
| 82 | ;
|
|---|
| 83 | S POS="",POS=$O(^VAT(394.84,GRPDA,"SEG","B",SEGDA,POS))
|
|---|
| 84 | S GRPSEGND=$G(^VAT(394.84,GRPDA,"SEG",POS,0))
|
|---|
| 85 | S TLIMIT=$P(GRPSEGND,U,4) I TLIMIT="" S TLIMIT=TLDEF
|
|---|
| 86 | S OLIMIT=$P(GRPSEGND,U,5) I OLIMIT="" S OLIMIT=OLDEF
|
|---|
| 87 | I $P(HSCOMPND,U,2)=0 S TLIMIT=""
|
|---|
| 88 | I $P(HSCOMPND,U,3)=0 S OLIMIT=""
|
|---|
| 89 | QUIT
|
|---|
| 90 | ;
|
|---|
| 91 | FLESEG ; -- Loops thru domains filing segment data in ^TMP array
|
|---|
| 92 | S LPDOM=""
|
|---|
| 93 | F S LPDOM=$O(^TMP("VAQDOM",$J,LPDOM)) Q:LPDOM="" D FILE
|
|---|
| 94 | QUIT
|
|---|
| 95 | ;
|
|---|
| 96 | FILE ;
|
|---|
| 97 | S:'$D(TLIMIT) TLIMIT=""
|
|---|
| 98 | S:'$D(OLIMIT) OLIMIT=""
|
|---|
| 99 | S ^TMP("VAQSEG",$J,LPDOM,SEGMNU)=SEGDA_"^"_SEGNME_"^"_TLIMIT_"^"_OLIMIT
|
|---|
| 100 | QUIT
|
|---|
| 101 | ;
|
|---|
| 102 | DELSEG ; -- Deletes selected segments
|
|---|
| 103 | S POP=1,X=$P(X,"-",2)
|
|---|
| 104 | I X="" W " ...No entries selected" QUIT
|
|---|
| 105 | S ARRAY="^TMP(""VAQSEG"","_$J_","_$C(34)_DOMAIN_$C(34)_")"
|
|---|
| 106 | S X=$$PARTIC^VAQUTL94(ARRAY,X)
|
|---|
| 107 | I X=-1 W " ... Not Selected" QUIT
|
|---|
| 108 | I X="PDX*MIN" W " ...required segment, not deleted" QUIT
|
|---|
| 109 | I '$D(^TMP("VAQSEG",$J,DOMAIN,X)) W !,X," Not Selected" QUIT
|
|---|
| 110 | K ^TMP("VAQSEG",$J,DOMAIN,X)
|
|---|
| 111 | W " ...Segment Deleted"
|
|---|
| 112 | QUIT
|
|---|
| 113 | ;
|
|---|
| 114 | LISTS ; -- Displays a list segments selected for domain
|
|---|
| 115 | S POP=1
|
|---|
| 116 | I '$D(^TMP("VAQSEG",$J,DOMAIN)) W !!,"** NO SEGMENT(S) SELECTED" QUIT
|
|---|
| 117 | W !!,"------------------------------ Segments Selected ------------------------------"
|
|---|
| 118 | S N="" F L=0:1 S N=$O(^TMP("VAQSEG",$J,DOMAIN,N)) Q:N="" W:'(L#8) ! W ?L#8*10 W N
|
|---|
| 119 | W !,"-------------------------------------------------------------------------------"
|
|---|
| 120 | W ! QUIT
|
|---|
| 121 | ;
|
|---|
| 122 | END ; -- End of code
|
|---|
| 123 | QUIT
|
|---|
