GMTSRM2 ; SLC/DLT - Edit HS Type - Help/Dupe/Delete ; 09/21/2001
;;2.7;Health Summary;**47**;Oct 20, 1995
;
; External Calls
; DBIA 10013 ^DIK
; DBIA 10026 ^DIR
; DBIA 10102 DISP^XQORM1
;
HELP ; Display Help Text
N GMI,GMTSTXT,HLP
S HLP=$S(X="??":"HTX1",1:"HTX1") W ! F GMI=1:1 S GMTSTXT=$T(@HLP+GMI) Q:GMTSTXT["ZZZZ" W !,$P(GMTSTXT,";",3,99)
D REDISP
Q
REDISP ; Ask Whether or not to redisplay menu
N I,DIR,X,Y
S DIR(0)="Y",DIR("A")="Redisplay items",DIR("B")="YES" D ^DIR Q:'Y
W @IOF
D DISP^XQORM1 W !
Q
HTX1 ; Help Text for "?" and "??"
;;
;; Select ONE or MORE items from the menu, separated by commas.
;;
;; ALL items may be selected by typing "ALL".
;;
;; EXCEPTIONS may be entered by preceding them with a minus.
;; For example, "ALL,-THIS,-THAT" selects all but "THIS" and "THAT".
;;
;;ZZZZ
;;
Q
ADEL(X) ; Ask to Delete
N GMTSIEN,GMTSN,ADEL,DIR S GMTSIEN=+($G(X)),ADEL="" Q:GMTSIEN=0 Q:'$D(^GMT(142,GMTSIEN,0)) Q:$D(^GMT(142,GMTSIEN,1,"B"))
S GMTSN=$P($G(^GMT(142,GMTSIEN,0)),"^",1) Q:'$L(GMTSN) S DIR("A",1)=" Health Summary Type '"_GMTSN_"' has no Components",DIR("A")=" Do you want to delete this type? (Y/N) ",DIR("B")="Yes",DIR(0)="YAO",DIR("?")=" Enter either 'Y' or 'N'."
W ! D ^DIR D:Y>0 DEL(+($G(GMTSIEN)))
Q
DEL(X) ; Delete
N DIK,DA,GMTSN S DA=+($G(X))
Q:DA=0 Q:'$D(^GMT(142,DA,0)) S DIK="^GMT(142,",GMTSN=$P($G(^GMT(142,DA,0)),"^",1) Q:'$L(GMTSN) D ^DIK I '$D(^GMT(142,DA,0)) W:$D(ADEL) " < deleted >" W:'$D(ADEL) !,?2,GMTSN," < deleted >"
Q
DUP(X) ; Look for a Duplicate 1 = duplicate found, 0 = unique
Q:'$L($G(X)) 1 S X=$G(X) N TYPE,UTYPE S TYPE=X,UTYPE=$$UP(TYPE)
N TYPES,TYPEO,TYPEI,TYPEN S TYPEO=$E(UTYPE,1,30),TYPEO=$E(TYPEO,1,($L(TYPEO)-1))_$C($A($E(TYPEO,$L(TYPEO)))-1)_"~"
F S TYPEO=$O(^GMT(142,"AB",TYPEO)) Q:TYPEO=0!(TYPEO'[$E(UTYPE,1,30)) D
. S TYPEI=0 F S TYPEI=$O(^GMT(142,"AB",TYPEO,TYPEI)) Q:+TYPEI=0 D
. . S TYPEN=$$UP($P($G(^GMT(142,TYPEI,0)),"^",1)) Q:TYPEN'=UTYPE Q:TYPEI=+($G(DA))
. . S TYPES(TYPEI)=TYPEN_"^"_TYPE
Q $S($O(TYPES(0))>0:1,1:0)
UP(X) Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMTSRM2 2205 printed Oct 16, 2024@18:00:55 Page 2
GMTSRM2 ; SLC/DLT - Edit HS Type - Help/Dupe/Delete ; 09/21/2001
+1 ;;2.7;Health Summary;**47**;Oct 20, 1995
+2 ;
+3 ; External Calls
+4 ; DBIA 10013 ^DIK
+5 ; DBIA 10026 ^DIR
+6 ; DBIA 10102 DISP^XQORM1
+7 ;
HELP ; Display Help Text
+1 NEW GMI,GMTSTXT,HLP
+2 SET HLP=$SELECT(X="??":"HTX1",1:"HTX1")
WRITE !
FOR GMI=1:1
SET GMTSTXT=$TEXT(@HLP+GMI)
if GMTSTXT["ZZZZ"
QUIT
WRITE !,$PIECE(GMTSTXT,";",3,99)
+3 DO REDISP
+4 QUIT
REDISP ; Ask Whether or not to redisplay menu
+1 NEW I,DIR,X,Y
+2 SET DIR(0)="Y"
SET DIR("A")="Redisplay items"
SET DIR("B")="YES"
DO ^DIR
if 'Y
QUIT
+3 WRITE @IOF
+4 DO DISP^XQORM1
WRITE !
+5 QUIT
HTX1 ; Help Text for "?" and "??"
+1 ;;
+2 ;; Select ONE or MORE items from the menu, separated by commas.
+3 ;;
+4 ;; ALL items may be selected by typing "ALL".
+5 ;;
+6 ;; EXCEPTIONS may be entered by preceding them with a minus.
+7 ;; For example, "ALL,-THIS,-THAT" selects all but "THIS" and "THAT".
+8 ;;
+9 ;;ZZZZ
+10 ;;
+11 QUIT
ADEL(X) ; Ask to Delete
+1 NEW GMTSIEN,GMTSN,ADEL,DIR
SET GMTSIEN=+($GET(X))
SET ADEL=""
if GMTSIEN=0
QUIT
if '$DATA(^GMT(142,GMTSIEN,0))
QUIT
if $DATA(^GMT(142,GMTSIEN,1,"B"))
QUIT
+2 SET GMTSN=$PIECE($GET(^GMT(142,GMTSIEN,0)),"^",1)
if '$LENGTH(GMTSN)
QUIT
SET DIR("A",1)=" Health Summary Type '"_GMTSN_"' has no Components"
SET DIR("A")=" Do you want to delete this type? (Y/N) "
SET DIR("B")="Yes"
SET DIR(0)="YAO"
SET DIR("?")=" Enter either 'Y' or 'N'."
+3 WRITE !
DO ^DIR
if Y>0
DO DEL(+($GET(GMTSIEN)))
+4 QUIT
DEL(X) ; Delete
+1 NEW DIK,DA,GMTSN
SET DA=+($GET(X))
+2 if DA=0
QUIT
if '$DATA(^GMT(142,DA,0))
QUIT
SET DIK="^GMT(142,"
SET GMTSN=$PIECE($GET(^GMT(142,DA,0)),"^",1)
if '$LENGTH(GMTSN)
QUIT
DO ^DIK
IF '$DATA(^GMT(142,DA,0))
if $DATA(ADEL)
WRITE " < deleted >"
if '$DATA(ADEL)
WRITE !,?2,GMTSN," < deleted >"
+3 QUIT
DUP(X) ; Look for a Duplicate 1 = duplicate found, 0 = unique
+1 if '$LENGTH($GET(X))
QUIT 1
SET X=$GET(X)
NEW TYPE,UTYPE
SET TYPE=X
SET UTYPE=$$UP(TYPE)
+2 NEW TYPES,TYPEO,TYPEI,TYPEN
SET TYPEO=$EXTRACT(UTYPE,1,30)
SET TYPEO=$EXTRACT(TYPEO,1,($LENGTH(TYPEO)-1))_$CHAR($ASCII($EXTRACT(TYPEO,$LENGTH(TYPEO)))-1)_"~"
+3 FOR
SET TYPEO=$ORDER(^GMT(142,"AB",TYPEO))
if TYPEO=0!(TYPEO'[$EXTRACT(UTYPE,1,30))
QUIT
Begin DoDot:1
+4 SET TYPEI=0
FOR
SET TYPEI=$ORDER(^GMT(142,"AB",TYPEO,TYPEI))
if +TYPEI=0
QUIT
Begin DoDot:2
+5 SET TYPEN=$$UP($PIECE($GET(^GMT(142,TYPEI,0)),"^",1))
if TYPEN'=UTYPE
QUIT
if TYPEI=+($GET(DA))
QUIT
+6 SET TYPES(TYPEI)=TYPEN_"^"_TYPE
End DoDot:2
End DoDot:1
+7 QUIT $SELECT($ORDER(TYPES(0))>0:1,1:0)
UP(X) QUIT $TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
