- 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 Jan 18, 2025@03:01:20 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")