VAQREQ04 ;ALB/JFP - PDX, REQUEST PATIENT DATA, ASK SEGMENT;01MAR93
;;1.5;PATIENT DATA EXCHANGE;;NOV 17, 1993
EP ; -- Entry point, second level of loop in VAQREQ03
; NOTE: PDX*MIN is hard coded in this routine
; - Called from VAQREQ03
; - Calls help routine VAQREQ09
;
REQ ; -- Request segment
N DIRUT,DTOUT,DUOUT,X,I,N,L
N GRPDA,SEGDA,SEGMNU,SEGNODE,SEGNO,SEGNME,GTYPE,GDUZ,GRP
;
DRIVER ; -- Driver loop
I $D(^TMP("VAQSEG",$J,DOMAIN)) D LISTS ; -- displays segments on edit
F D ASKSEG Q:$D(DIRUT)
; -- Cleanup and exit
K DIRUT,DTOUT,DUOUT,X,I,N,L
K SEGDA,SEGMNU,SEGNODE,SEGNO,SEGNME,GTYPE,GDUZ,GRP,GRPDA
QUIT
;
ASKSEG ; -- Prompts for segments
; -- Sets default segment to PDX*MIN, Minimum patient information
; Note: PDX*MIN is hard coded in this routine, if this mnuemonic
; changes, the routine must change (ASKSEG+3)
;
I '$D(^TMP("VAQSEG",$J,DOMAIN,"PDX*MIN")) D
.S SEGNO="",SEGNO=$O(^VAT(394.71,"C","PDX*MIN",SEGNO))
.S SEGNME=$P($G(^VAT(394.71,SEGNO,0)),U,1)
.S ^TMP("VAQSEG",$J,DOMAIN,"PDX*MIN")=SEGNO_"^"_SEGNME
;
; -- Call to Dir to request segments
S POP=0
S DIR("A")=" Enter Segment: "
S DIR(0)="FAO^1:30"
S DIR("?")="^D HLPSEG1^VAQREQ09"
S DIR("??")="^D HLPSEG2^VAQREQ09"
W ! D ^DIR K DIR Q:$D(DIRUT)
S X=Y
I X="*L" D LISTS Q:POP
I $E(X,1,1)="-" D DELSEG Q:POP
I $E(X,1,2)'="G." D SEG Q:POP
I $E(X,1,2)="G." D GSEG Q:POP
QUIT
;
SEG ; -- Dic lookup to verify segment in file 394.71
S DIC="^VAT(394.71,",DIC(0)="EMQZ"
D ^DIC K DIC I $D(DTOUT)!$D(DUOUT)!(Y<0) S POP=1 QUIT
S SEGNME=$P(Y(0),U,1),SEGMNU=$P(Y(0),U,2)
S SEGDA="",SEGDA=$O(^VAT(394.71,"C",SEGMNU,SEGDA))
S HSCOMPND=$$HLTHSEG^VAQDBIH1(SEGMNU,0)
I $P(HSCOMPND,U,1)'=0 D EP^VAQREQ11 ; -- Time and occurrence
D FLESEG
QUIT
;
GSEG ; -- Dic lookup to verify segment group name in file 394.84
S X=$P(X,".",2) ; -- strip off G.
S DIC="^VAT(394.84,"
S DIC(0)="EMQZ"
D ^DIC K DIC I $D(DTOUT)!$D(DUOUT)!(Y<0) S POP=1 QUIT
S GTYPE=$P(Y(0),U,2),GDUZ=$P(Y(0),U,3)
I (GTYPE="0")&(DUZ'=GDUZ) D QUIT
.W " ...Private group selected not associated with user"
.S POP=1
S GRP=$P(Y,U,2),GRPDA="",GRPDA=$O(^VAT(394.84,"B",GRP,GRPDA))
D S1
QUIT
;
S1 S SEGDA=""
F S SEGDA=$O(^VAT(394.84,GRPDA,"SEG","B",SEGDA)) Q:SEGDA="" D SETS
QUIT
SETS S SEGNODE=$G(^VAT(394.71,SEGDA,0))
Q:SEGNODE=""
S SEGNME=$P(SEGNODE,U,1),SEGMNU=$P(SEGNODE,U,2)
S HSCOMPND=$$HLTHSEG^VAQDBIH1(SEGMNU,0)
I $P(HSCOMPND,U,1)'=0 D GROUP ; -- Time and occurrence
D FLESEG
QUIT
;
GROUP ; -- Sets time and occurrence limits for segment groups selected
S PARAMND=$G(^VAT(394.81,1,"LIMITS")) ; -- sets time & occ defaults
S TLDEF=$P(PARAMND,U,1)
S OLDEF=$P(PARAMND,U,2)
;
S POS="",POS=$O(^VAT(394.84,GRPDA,"SEG","B",SEGDA,POS))
S GRPSEGND=$G(^VAT(394.84,GRPDA,"SEG",POS,0))
S TLIMIT=$P(GRPSEGND,U,4) I TLIMIT="" S TLIMIT=TLDEF
S OLIMIT=$P(GRPSEGND,U,5) I OLIMIT="" S OLIMIT=OLDEF
I $P(HSCOMPND,U,2)=0 S TLIMIT=""
I $P(HSCOMPND,U,3)=0 S OLIMIT=""
QUIT
;
FLESEG ; -- Loops thru domains filing segment data in ^TMP array
S LPDOM=""
F S LPDOM=$O(^TMP("VAQDOM",$J,LPDOM)) Q:LPDOM="" D FILE
QUIT
;
FILE ;
S:'$D(TLIMIT) TLIMIT=""
S:'$D(OLIMIT) OLIMIT=""
S ^TMP("VAQSEG",$J,LPDOM,SEGMNU)=SEGDA_"^"_SEGNME_"^"_TLIMIT_"^"_OLIMIT
QUIT
;
DELSEG ; -- Deletes selected segments
S POP=1,X=$P(X,"-",2)
I X="" W " ...No entries selected" QUIT
S ARRAY="^TMP(""VAQSEG"","_$J_","_$C(34)_DOMAIN_$C(34)_")"
S X=$$PARTIC^VAQUTL94(ARRAY,X)
I X=-1 W " ... Not Selected" QUIT
I X="PDX*MIN" W " ...required segment, not deleted" QUIT
I '$D(^TMP("VAQSEG",$J,DOMAIN,X)) W !,X," Not Selected" QUIT
K ^TMP("VAQSEG",$J,DOMAIN,X)
W " ...Segment Deleted"
QUIT
;
LISTS ; -- Displays a list segments selected for domain
S POP=1
I '$D(^TMP("VAQSEG",$J,DOMAIN)) W !!,"** NO SEGMENT(S) SELECTED" QUIT
W !!,"------------------------------ Segments Selected ------------------------------"
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
W !,"-------------------------------------------------------------------------------"
W ! QUIT
;
END ; -- End of code
QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVAQREQ04 4258 printed Apr 09, 2024@21:27:33 Page 2
VAQREQ04 ;ALB/JFP - PDX, REQUEST PATIENT DATA, ASK SEGMENT;01MAR93
+1 ;;1.5;PATIENT DATA EXCHANGE;;NOV 17, 1993
EP ; -- Entry point, second level of loop in VAQREQ03
+1 ; NOTE: PDX*MIN is hard coded in this routine
+2 ; - Called from VAQREQ03
+3 ; - Calls help routine VAQREQ09
+4 ;
REQ ; -- Request segment
+1 NEW DIRUT,DTOUT,DUOUT,X,I,N,L
+2 NEW GRPDA,SEGDA,SEGMNU,SEGNODE,SEGNO,SEGNME,GTYPE,GDUZ,GRP
+3 ;
DRIVER ; -- Driver loop
+1 ; -- displays segments on edit
IF $DATA(^TMP("VAQSEG",$JOB,DOMAIN))
DO LISTS
+2 FOR
DO ASKSEG
if $DATA(DIRUT)
QUIT
+3 ; -- Cleanup and exit
+4 KILL DIRUT,DTOUT,DUOUT,X,I,N,L
+5 KILL SEGDA,SEGMNU,SEGNODE,SEGNO,SEGNME,GTYPE,GDUZ,GRP,GRPDA
+6 QUIT
+7 ;
ASKSEG ; -- Prompts for segments
+1 ; -- Sets default segment to PDX*MIN, Minimum patient information
+2 ; Note: PDX*MIN is hard coded in this routine, if this mnuemonic
+3 ; changes, the routine must change (ASKSEG+3)
+4 ;
+5 IF '$DATA(^TMP("VAQSEG",$JOB,DOMAIN,"PDX*MIN"))
Begin DoDot:1
+6 SET SEGNO=""
SET SEGNO=$ORDER(^VAT(394.71,"C","PDX*MIN",SEGNO))
+7 SET SEGNME=$PIECE($GET(^VAT(394.71,SEGNO,0)),U,1)
+8 SET ^TMP("VAQSEG",$JOB,DOMAIN,"PDX*MIN")=SEGNO_"^"_SEGNME
End DoDot:1
+9 ;
+10 ; -- Call to Dir to request segments
+11 SET POP=0
+12 SET DIR("A")=" Enter Segment: "
+13 SET DIR(0)="FAO^1:30"
+14 SET DIR("?")="^D HLPSEG1^VAQREQ09"
+15 SET DIR("??")="^D HLPSEG2^VAQREQ09"
+16 WRITE !
DO ^DIR
KILL DIR
if $DATA(DIRUT)
QUIT
+17 SET X=Y
+18 IF X="*L"
DO LISTS
if POP
QUIT
+19 IF $EXTRACT(X,1,1)="-"
DO DELSEG
if POP
QUIT
+20 IF $EXTRACT(X,1,2)'="G."
DO SEG
if POP
QUIT
+21 IF $EXTRACT(X,1,2)="G."
DO GSEG
if POP
QUIT
+22 QUIT
+23 ;
SEG ; -- Dic lookup to verify segment in file 394.71
+1 SET DIC="^VAT(394.71,"
SET DIC(0)="EMQZ"
+2 DO ^DIC
KILL DIC
IF $DATA(DTOUT)!$DATA(DUOUT)!(Y<0)
SET POP=1
QUIT
+3 SET SEGNME=$PIECE(Y(0),U,1)
SET SEGMNU=$PIECE(Y(0),U,2)
+4 SET SEGDA=""
SET SEGDA=$ORDER(^VAT(394.71,"C",SEGMNU,SEGDA))
+5 SET HSCOMPND=$$HLTHSEG^VAQDBIH1(SEGMNU,0)
+6 ; -- Time and occurrence
IF $PIECE(HSCOMPND,U,1)'=0
DO EP^VAQREQ11
+7 DO FLESEG
+8 QUIT
+9 ;
GSEG ; -- Dic lookup to verify segment group name in file 394.84
+1 ; -- strip off G.
SET X=$PIECE(X,".",2)
+2 SET DIC="^VAT(394.84,"
+3 SET DIC(0)="EMQZ"
+4 DO ^DIC
KILL DIC
IF $DATA(DTOUT)!$DATA(DUOUT)!(Y<0)
SET POP=1
QUIT
+5 SET GTYPE=$PIECE(Y(0),U,2)
SET GDUZ=$PIECE(Y(0),U,3)
+6 IF (GTYPE="0")&(DUZ'=GDUZ)
Begin DoDot:1
+7 WRITE " ...Private group selected not associated with user"
+8 SET POP=1
End DoDot:1
QUIT
+9 SET GRP=$PIECE(Y,U,2)
SET GRPDA=""
SET GRPDA=$ORDER(^VAT(394.84,"B",GRP,GRPDA))
+10 DO S1
+11 QUIT
+12 ;
S1 SET SEGDA=""
+1 FOR
SET SEGDA=$ORDER(^VAT(394.84,GRPDA,"SEG","B",SEGDA))
if SEGDA=""
QUIT
DO SETS
+2 QUIT
SETS SET SEGNODE=$GET(^VAT(394.71,SEGDA,0))
+1 if SEGNODE=""
QUIT
+2 SET SEGNME=$PIECE(SEGNODE,U,1)
SET SEGMNU=$PIECE(SEGNODE,U,2)
+3 SET HSCOMPND=$$HLTHSEG^VAQDBIH1(SEGMNU,0)
+4 ; -- Time and occurrence
IF $PIECE(HSCOMPND,U,1)'=0
DO GROUP
+5 DO FLESEG
+6 QUIT
+7 ;
GROUP ; -- Sets time and occurrence limits for segment groups selected
+1 ; -- sets time & occ defaults
SET PARAMND=$GET(^VAT(394.81,1,"LIMITS"))
+2 SET TLDEF=$PIECE(PARAMND,U,1)
+3 SET OLDEF=$PIECE(PARAMND,U,2)
+4 ;
+5 SET POS=""
SET POS=$ORDER(^VAT(394.84,GRPDA,"SEG","B",SEGDA,POS))
+6 SET GRPSEGND=$GET(^VAT(394.84,GRPDA,"SEG",POS,0))
+7 SET TLIMIT=$PIECE(GRPSEGND,U,4)
IF TLIMIT=""
SET TLIMIT=TLDEF
+8 SET OLIMIT=$PIECE(GRPSEGND,U,5)
IF OLIMIT=""
SET OLIMIT=OLDEF
+9 IF $PIECE(HSCOMPND,U,2)=0
SET TLIMIT=""
+10 IF $PIECE(HSCOMPND,U,3)=0
SET OLIMIT=""
+11 QUIT
+12 ;
FLESEG ; -- Loops thru domains filing segment data in ^TMP array
+1 SET LPDOM=""
+2 FOR
SET LPDOM=$ORDER(^TMP("VAQDOM",$JOB,LPDOM))
if LPDOM=""
QUIT
DO FILE
+3 QUIT
+4 ;
FILE ;
+1 if '$DATA(TLIMIT)
SET TLIMIT=""
+2 if '$DATA(OLIMIT)
SET OLIMIT=""
+3 SET ^TMP("VAQSEG",$JOB,LPDOM,SEGMNU)=SEGDA_"^"_SEGNME_"^"_TLIMIT_"^"_OLIMIT
+4 QUIT
+5 ;
DELSEG ; -- Deletes selected segments
+1 SET POP=1
SET X=$PIECE(X,"-",2)
+2 IF X=""
WRITE " ...No entries selected"
QUIT
+3 SET ARRAY="^TMP(""VAQSEG"","_$JOB_","_$CHAR(34)_DOMAIN_$CHAR(34)_")"
+4 SET X=$$PARTIC^VAQUTL94(ARRAY,X)
+5 IF X=-1
WRITE " ... Not Selected"
QUIT
+6 IF X="PDX*MIN"
WRITE " ...required segment, not deleted"
QUIT
+7 IF '$DATA(^TMP("VAQSEG",$JOB,DOMAIN,X))
WRITE !,X," Not Selected"
QUIT
+8 KILL ^TMP("VAQSEG",$JOB,DOMAIN,X)
+9 WRITE " ...Segment Deleted"
+10 QUIT
+11 ;
LISTS ; -- Displays a list segments selected for domain
+1 SET POP=1
+2 IF '$DATA(^TMP("VAQSEG",$JOB,DOMAIN))
WRITE !!,"** NO SEGMENT(S) SELECTED"
QUIT
+3 WRITE !!,"------------------------------ Segments Selected ------------------------------"
+4 SET N=""
FOR L=0:1
SET N=$ORDER(^TMP("VAQSEG",$JOB,DOMAIN,N))
if N=""
QUIT
if '(L#8)
WRITE !
WRITE ?L#8*10
WRITE N
+5 WRITE !,"-------------------------------------------------------------------------------"
+6 WRITE !
QUIT
+7 ;
END ; -- End of code
+1 QUIT
