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

DGPFUT64.m

Go to the documentation of this file.
  1. DGPFUT64 ;SHRPE/SGM - FLAG UTILITIES ; Aug 17, 2018 09:30
  1. ;;5.3;Registration;**951**;Aug 13, 1993;Build 135
  1. ; Last Edited: SHRPE/SGM - Aug 22, 2018 17:50
  1. ;
  1. ; This routine is to be invoked ONLY from ^DGPFUT6
  1. ;
  1. ; ICR# TYPE DESCRIPTION
  1. ;----- ---- ------------------------------------
  1. ; 2051 Sup $$FIND1^DIC
  1. ; 2056 Sup $$GET1^DIQ
  1. ;10006 Sup ^DIC
  1. ;
  1. ;=====================================================================
  1. FLAG(DGPFIN,SCR,TYPE) ;
  1. ; Does flag name and flag variable pointer match?
  1. ; INPUT PARAMETERS:
  1. ; DGPFIN - required - flag full name or variable-pointer syntax
  1. ; SCR - required - flag name to use as a screen if DGPFIN is
  1. ; var-pointer
  1. ; TYPE - optional - I:only return Cat I values
  1. ; II:only return Cat II values
  1. ; null or 0:return either Cat I or Cat II
  1. ; EXTRINSIC FUNCTION returns 0 or variable_pointer^flag_name
  1. ;
  1. I $G(SCR)="" Q 0
  1. N X,Y
  1. S X=$$FLAGCVRT(,$G(DGPFIN),$G(TYPE))
  1. S Y=$S(X=0:0,$P(X,U,2)=SCR:X,1:0)
  1. Q Y
  1. ;
  1. ;=====================================================================
  1. FLAGCVRT(DGRET,VAL,TYPE) ;
  1. ;Convert flag name to variable pointer / variable pointer to flag name
  1. ;INPUT PARAMETERS:
  1. ; TYPE - optional - I:only return Cat I values
  1. ; II:only return Cat II values
  1. ; null or 0:return either Cat I or Cat II
  1. ; VAL - required - flag name or variable pointer syntax
  1. ;
  1. ;EXTRINSIC FUNCTION and RETURN PARAMETER DGRET returns:
  1. ; 0 if no matches or error encountered
  1. ; else variable_pointer ^ name of flag
  1. ; This expects that there are not multiple flags with the same name
  1. ;
  1. N X,ERR,FLGX,NAME,PTR,ROOT
  1. S ERR=0
  1. S FLGX=$P($G(VAL),U) I FLGX="" Q 0
  1. S FLGX(1)=0 ; extrinsic function return value
  1. S TYPE=$G(TYPE)
  1. I TYPE="",FLGX["26.15," S TYPE="I"
  1. I TYPE="",FLGX["26.11," S TYPE="II"
  1. I $L(TYPE),TYPE'="I",TYPE'="II" S TYPE=""
  1. S (NAME,PTR,ROOT)=""
  1. I FLGX'["(26.1" S NAME=FLGX
  1. E D I ERR Q 0
  1. . N X,Y,GL
  1. . S Y=$P(FLGX,";"),GL=$P(FLGX,";",2)
  1. . I Y'=+Y S ERR=1 Q
  1. . I (GL'="DGPF(26.11,"),(GL'="DGPF(26.15,") S ERR=1 Q
  1. . S PTR=Y,ROOT=GL
  1. . Q
  1. I PTR D
  1. . N X,Y,DGERR,DIERR,FILE,IENS
  1. . S FILE=$P($P(ROOT,"(",2),",")
  1. . S IENS=PTR_","
  1. . S Y=$$GET1^DIQ(FILE,IENS,.01,,,"DGERR")
  1. . I '$D(DIERR),$L(Y) S FLGX(1)=FLGX_U_Y
  1. . Q
  1. I $L(NAME) D
  1. . N X,Y,DGERR,DIERR,FLAG
  1. . I TYPE'="II" D
  1. . . S Y=$$FIND1^DIC(26.15,,"QX",FLGX,"B",,"DGERR")
  1. . . I '$D(DIERR),Y>0 S FLGX("I")=Y_";DGPF(26.15,"_U_NAME
  1. . . Q
  1. . I TYPE'="I" D
  1. . . S Y=$$FIND1^DIC(26.11,,"QX",FLGX,"B",,"DGERR")
  1. . . I '$D(DIERR),Y>0 S FLGX("II")=Y_"DGPF(26.11,"_U_NAME
  1. . . Q
  1. . I $D(FLGX("I")),'$D(FLGX("II")) S FLGX(1)=FLGX("I")
  1. . I $D(FLGX("II")),'$D(FLGX("I")) S FLGX(1)=FLGX("II")
  1. . Q
  1. S DGRET=FLGX(1)
  1. Q:$Q DGRET
  1. Q
  1. ;
  1. ;=====================================================================
  1. SELASGN(DGSCR,FLG) ;
  1. ; select an existing assignment from from 26.13
  1. ;INPUT PARAMETER: DGSCR - optional - ^DIC input parameter DIC("S")
  1. ; FLG - optional. if "Z" then return zeroth node as
  1. ; second and subsequent "^"-pieces
  1. ;EXTRINSIC FUNCTION: ien or ien[^zeroth node] or 0 or -1
  1. ;
  1. N X,Y,DA,DIC,DTOUT,DUOUT,XQY0
  1. S DIC=26.13,DIC(0)="QAEMZ"
  1. S DIC("A")="Select PATIENT: "
  1. S DGSCR=$G(DGSCR) I $L(DGSCR) D
  1. . N BEH
  1. . I DGSCR'="BEH" S DIC("S")=DGSCR Q
  1. . S BEH=$$FLAGCVRT(,"BEHAVIORAL","I")
  1. . I BEH>0 S DIC("S")="I $P(^(0),U,2)="_$C(34)_$P(BEH,U)_$C(34)
  1. . Q
  1. S X="Select a Patient Record Flag Assignment"
  1. S:DGSCR="BEH" X="Select Patient who has a BEHAVIORAL flag assigned."
  1. W !!,X
  1. D ^DIC
  1. I Y>0 S X=+Y S:$G(FLG)="Z" X=X_U_Y(0) S Y=X
  1. Q $S($D(DTOUT):-1,Y>0:Y,1:0)