DGPFUT64 ;SHRPE/SGM - FLAG UTILITIES ; Aug 17, 2018 09:30
;;5.3;Registration;**951**;Aug 13, 1993;Build 135
; Last Edited: SHRPE/SGM - Aug 22, 2018 17:50
;
; This routine is to be invoked ONLY from ^DGPFUT6
;
; ICR# TYPE DESCRIPTION
;----- ---- ------------------------------------
; 2051 Sup $$FIND1^DIC
; 2056 Sup $$GET1^DIQ
;10006 Sup ^DIC
;
;=====================================================================
FLAG(DGPFIN,SCR,TYPE) ;
; Does flag name and flag variable pointer match?
; INPUT PARAMETERS:
; DGPFIN - required - flag full name or variable-pointer syntax
; SCR - required - flag name to use as a screen if DGPFIN is
; var-pointer
; TYPE - optional - I:only return Cat I values
; II:only return Cat II values
; null or 0:return either Cat I or Cat II
; EXTRINSIC FUNCTION returns 0 or variable_pointer^flag_name
;
I $G(SCR)="" Q 0
N X,Y
S X=$$FLAGCVRT(,$G(DGPFIN),$G(TYPE))
S Y=$S(X=0:0,$P(X,U,2)=SCR:X,1:0)
Q Y
;
;=====================================================================
FLAGCVRT(DGRET,VAL,TYPE) ;
;Convert flag name to variable pointer / variable pointer to flag name
;INPUT PARAMETERS:
; TYPE - optional - I:only return Cat I values
; II:only return Cat II values
; null or 0:return either Cat I or Cat II
; VAL - required - flag name or variable pointer syntax
;
;EXTRINSIC FUNCTION and RETURN PARAMETER DGRET returns:
; 0 if no matches or error encountered
; else variable_pointer ^ name of flag
; This expects that there are not multiple flags with the same name
;
N X,ERR,FLGX,NAME,PTR,ROOT
S ERR=0
S FLGX=$P($G(VAL),U) I FLGX="" Q 0
S FLGX(1)=0 ; extrinsic function return value
S TYPE=$G(TYPE)
I TYPE="",FLGX["26.15," S TYPE="I"
I TYPE="",FLGX["26.11," S TYPE="II"
I $L(TYPE),TYPE'="I",TYPE'="II" S TYPE=""
S (NAME,PTR,ROOT)=""
I FLGX'["(26.1" S NAME=FLGX
E D I ERR Q 0
. N X,Y,GL
. S Y=$P(FLGX,";"),GL=$P(FLGX,";",2)
. I Y'=+Y S ERR=1 Q
. I (GL'="DGPF(26.11,"),(GL'="DGPF(26.15,") S ERR=1 Q
. S PTR=Y,ROOT=GL
. Q
I PTR D
. N X,Y,DGERR,DIERR,FILE,IENS
. S FILE=$P($P(ROOT,"(",2),",")
. S IENS=PTR_","
. S Y=$$GET1^DIQ(FILE,IENS,.01,,,"DGERR")
. I '$D(DIERR),$L(Y) S FLGX(1)=FLGX_U_Y
. Q
I $L(NAME) D
. N X,Y,DGERR,DIERR,FLAG
. I TYPE'="II" D
. . S Y=$$FIND1^DIC(26.15,,"QX",FLGX,"B",,"DGERR")
. . I '$D(DIERR),Y>0 S FLGX("I")=Y_";DGPF(26.15,"_U_NAME
. . Q
. I TYPE'="I" D
. . S Y=$$FIND1^DIC(26.11,,"QX",FLGX,"B",,"DGERR")
. . I '$D(DIERR),Y>0 S FLGX("II")=Y_"DGPF(26.11,"_U_NAME
. . Q
. I $D(FLGX("I")),'$D(FLGX("II")) S FLGX(1)=FLGX("I")
. I $D(FLGX("II")),'$D(FLGX("I")) S FLGX(1)=FLGX("II")
. Q
S DGRET=FLGX(1)
Q:$Q DGRET
Q
;
;=====================================================================
SELASGN(DGSCR,FLG) ;
; select an existing assignment from from 26.13
;INPUT PARAMETER: DGSCR - optional - ^DIC input parameter DIC("S")
; FLG - optional. if "Z" then return zeroth node as
; second and subsequent "^"-pieces
;EXTRINSIC FUNCTION: ien or ien[^zeroth node] or 0 or -1
;
N X,Y,DA,DIC,DTOUT,DUOUT,XQY0
S DIC=26.13,DIC(0)="QAEMZ"
S DIC("A")="Select PATIENT: "
S DGSCR=$G(DGSCR) I $L(DGSCR) D
. N BEH
. I DGSCR'="BEH" S DIC("S")=DGSCR Q
. S BEH=$$FLAGCVRT(,"BEHAVIORAL","I")
. I BEH>0 S DIC("S")="I $P(^(0),U,2)="_$C(34)_$P(BEH,U)_$C(34)
. Q
S X="Select a Patient Record Flag Assignment"
S:DGSCR="BEH" X="Select Patient who has a BEHAVIORAL flag assigned."
W !!,X
D ^DIC
I Y>0 S X=+Y S:$G(FLG)="Z" X=X_U_Y(0) S Y=X
Q $S($D(DTOUT):-1,Y>0:Y,1:0)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPFUT64 3797 printed Apr 09, 2024@21:38:47 Page 2
DGPFUT64 ;SHRPE/SGM - FLAG UTILITIES ; Aug 17, 2018 09:30
+1 ;;5.3;Registration;**951**;Aug 13, 1993;Build 135
+2 ; Last Edited: SHRPE/SGM - Aug 22, 2018 17:50
+3 ;
+4 ; This routine is to be invoked ONLY from ^DGPFUT6
+5 ;
+6 ; ICR# TYPE DESCRIPTION
+7 ;----- ---- ------------------------------------
+8 ; 2051 Sup $$FIND1^DIC
+9 ; 2056 Sup $$GET1^DIQ
+10 ;10006 Sup ^DIC
+11 ;
+12 ;=====================================================================
FLAG(DGPFIN,SCR,TYPE) ;
+1 ; Does flag name and flag variable pointer match?
+2 ; INPUT PARAMETERS:
+3 ; DGPFIN - required - flag full name or variable-pointer syntax
+4 ; SCR - required - flag name to use as a screen if DGPFIN is
+5 ; var-pointer
+6 ; TYPE - optional - I:only return Cat I values
+7 ; II:only return Cat II values
+8 ; null or 0:return either Cat I or Cat II
+9 ; EXTRINSIC FUNCTION returns 0 or variable_pointer^flag_name
+10 ;
+11 IF $GET(SCR)=""
QUIT 0
+12 NEW X,Y
+13 SET X=$$FLAGCVRT(,$GET(DGPFIN),$GET(TYPE))
+14 SET Y=$SELECT(X=0:0,$PIECE(X,U,2)=SCR:X,1:0)
+15 QUIT Y
+16 ;
+17 ;=====================================================================
FLAGCVRT(DGRET,VAL,TYPE) ;
+1 ;Convert flag name to variable pointer / variable pointer to flag name
+2 ;INPUT PARAMETERS:
+3 ; TYPE - optional - I:only return Cat I values
+4 ; II:only return Cat II values
+5 ; null or 0:return either Cat I or Cat II
+6 ; VAL - required - flag name or variable pointer syntax
+7 ;
+8 ;EXTRINSIC FUNCTION and RETURN PARAMETER DGRET returns:
+9 ; 0 if no matches or error encountered
+10 ; else variable_pointer ^ name of flag
+11 ; This expects that there are not multiple flags with the same name
+12 ;
+13 NEW X,ERR,FLGX,NAME,PTR,ROOT
+14 SET ERR=0
+15 SET FLGX=$PIECE($GET(VAL),U)
IF FLGX=""
QUIT 0
+16 ; extrinsic function return value
SET FLGX(1)=0
+17 SET TYPE=$GET(TYPE)
+18 IF TYPE=""
IF FLGX["26.15,"
SET TYPE="I"
+19 IF TYPE=""
IF FLGX["26.11,"
SET TYPE="II"
+20 IF $LENGTH(TYPE)
IF TYPE'="I"
IF TYPE'="II"
SET TYPE=""
+21 SET (NAME,PTR,ROOT)=""
+22 IF FLGX'["(26.1"
SET NAME=FLGX
+23 IF '$TEST
Begin DoDot:1
+24 NEW X,Y,GL
+25 SET Y=$PIECE(FLGX,";")
SET GL=$PIECE(FLGX,";",2)
+26 IF Y'=+Y
SET ERR=1
QUIT
+27 IF (GL'="DGPF(26.11,")
IF (GL'="DGPF(26.15,")
SET ERR=1
QUIT
+28 SET PTR=Y
SET ROOT=GL
+29 QUIT
End DoDot:1
IF ERR
QUIT 0
+30 IF PTR
Begin DoDot:1
+31 NEW X,Y,DGERR,DIERR,FILE,IENS
+32 SET FILE=$PIECE($PIECE(ROOT,"(",2),",")
+33 SET IENS=PTR_","
+34 SET Y=$$GET1^DIQ(FILE,IENS,.01,,,"DGERR")
+35 IF '$DATA(DIERR)
IF $LENGTH(Y)
SET FLGX(1)=FLGX_U_Y
+36 QUIT
End DoDot:1
+37 IF $LENGTH(NAME)
Begin DoDot:1
+38 NEW X,Y,DGERR,DIERR,FLAG
+39 IF TYPE'="II"
Begin DoDot:2
+40 SET Y=$$FIND1^DIC(26.15,,"QX",FLGX,"B",,"DGERR")
+41 IF '$DATA(DIERR)
IF Y>0
SET FLGX("I")=Y_";DGPF(26.15,"_U_NAME
+42 QUIT
End DoDot:2
+43 IF TYPE'="I"
Begin DoDot:2
+44 SET Y=$$FIND1^DIC(26.11,,"QX",FLGX,"B",,"DGERR")
+45 IF '$DATA(DIERR)
IF Y>0
SET FLGX("II")=Y_"DGPF(26.11,"_U_NAME
+46 QUIT
End DoDot:2
+47 IF $DATA(FLGX("I"))
IF '$DATA(FLGX("II"))
SET FLGX(1)=FLGX("I")
+48 IF $DATA(FLGX("II"))
IF '$DATA(FLGX("I"))
SET FLGX(1)=FLGX("II")
+49 QUIT
End DoDot:1
+50 SET DGRET=FLGX(1)
+51 if $QUIT
QUIT DGRET
+52 QUIT
+53 ;
+54 ;=====================================================================
SELASGN(DGSCR,FLG) ;
+1 ; select an existing assignment from from 26.13
+2 ;INPUT PARAMETER: DGSCR - optional - ^DIC input parameter DIC("S")
+3 ; FLG - optional. if "Z" then return zeroth node as
+4 ; second and subsequent "^"-pieces
+5 ;EXTRINSIC FUNCTION: ien or ien[^zeroth node] or 0 or -1
+6 ;
+7 NEW X,Y,DA,DIC,DTOUT,DUOUT,XQY0
+8 SET DIC=26.13
SET DIC(0)="QAEMZ"
+9 SET DIC("A")="Select PATIENT: "
+10 SET DGSCR=$GET(DGSCR)
IF $LENGTH(DGSCR)
Begin DoDot:1
+11 NEW BEH
+12 IF DGSCR'="BEH"
SET DIC("S")=DGSCR
QUIT
+13 SET BEH=$$FLAGCVRT(,"BEHAVIORAL","I")
+14 IF BEH>0
SET DIC("S")="I $P(^(0),U,2)="_$CHAR(34)_$PIECE(BEH,U)_$CHAR(34)
+15 QUIT
End DoDot:1
+16 SET X="Select a Patient Record Flag Assignment"
+17 if DGSCR="BEH"
SET X="Select Patient who has a BEHAVIORAL flag assigned."
+18 WRITE !!,X
+19 DO ^DIC
+20 IF Y>0
SET X=+Y
if $GET(FLG)="Z"
SET X=X_U_Y(0)
SET Y=X
+21 QUIT $SELECT($DATA(DTOUT):-1,Y>0:Y,1:0)
