- 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 Feb 18, 2025@23:52:47 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