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