Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: VAQREQ04

VAQREQ04.m

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