- 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 Jan 18, 2025@03:49:39 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)