GMTSXAP2 ; SLC/KER - List Parameters/Precedence 2 ; 02/27/2002
;;2.7;Health Summary;**47,49**;Oct 20, 1995
Q
;
; External References in GMTSXAP2
; DBIA 2056 $$GET1^DIQ
; DBIA 2343 $$ACTIVE^XUSER
; DBIA 10006 ^DIC
; DBIA 10026 ^DIR
; DBIA 10018 ^DIE
; DBIA 10013 ^DIK
;
; Check to see if Compiled Order is correct
OK(X) ; Ask if Ok
N Y,DIR,GMTSTOT,GMTSOLD S GMTSNEW=$G(GMTSNEW),GMTSOLD=$$OLD
S GMTSTOT=$$ORT S:GMTSTOT=1 X=$$OKO S:GMTSTOT>1 X=$$OKM S:GMTSTOT'>0 X=0
Q X
OKM(X) ; Multiple entities selected i.e. USR;SYS
N DIR,Y,DIROUT,DUOUT,DTOUT S X=1 D OKA Q:'$D(DIR) 0
D YND
Q X
OKO(X) ; Only one entity selected i.e. USR
I '$L($G(GMTSORD(1)))!($L($P(GMTSORD(1),"^",1))'=3)!($L($P(GMTSORD(1),"^",3))'>0) Q 0
N DIR,Y,DIROUT,DUOUT,DTOUT D OKA Q:'$D(DIR) 0
D YND
Q X
OKA ; Set up Prompts - DIR("A")
N GMTSC,GMTSI,GMTST S (GMTSC,GMTSI)=0 S GMTST=$$ORT
MUL ; Multiple Entities
I GMTST>1 D Q
. K DIR N GMTSTC,GMTSA,GMTSC S GMTSC=0,GMTSA=GMTST+4 S GMTSTC=$S(GMTST=2:"two",GMTST=3:"three",1:"several")
. S DIR("A",1)="",DIR("A",2)=" You have selected "_GMTSTC_" Health Summary Types, arranged "
. S DIR("A",3)=" in the following order:",DIR("A",4)=""
. F GMTSA=1:1:GMTST S DIR("A",(4+GMTSA))=" "_$J(GMTSA,2)_" "_$P($G(GMTSORD(+GMTSA)),"^",3)
. S GMTSA=+($O(DIR("A"," "),-1))+1,DIR("A",GMTSA)="",DIR("A")=" Is this precedence correct? (Y/N) ",DIR(0)="YAO",DIR("B")="Y"
ONE ; One Entity
I GMTST=1 D Q
. I $L($G(GMTSORD(1))),$L($P(GMTSORD(1),"^",1))=3,$L($P(GMTSORD(1),"^",3))>0 D Q
. . K DIR S DIR("A",1)=""
. . S DIR("A",2)=" You have selected one Health Summary Type"
. . S DIR("A",3)=""
. . S DIR("A",4)=" "_$P($G(GMTSORD(1)),"^",3)
. . S DIR("A",5)=""
. . S DIR("A")=" Is this correct? (Y/N) "
. . S DIR(0)="YAO",DIR("B")="Y"
. K DIR
K DIR
Q
;
YND ; Yes/No/Delete
W ! S X=$G(X) S:$L($G(DIR("A"))) DIR("A")=" Is this correct? (Y/N) "
S (DIR("?"),DIR("??"))="^D YNDH^GMTSXAP2"
S DIR(0)="FAO^1;3^K:$$YNDI^GMTSXAP2(X)'>0 X",DIR("B")="Y"
D ^DIR S X=$$YNDO(X) S:X["^" GMTSEXIT=1 S:X="@" GMTSEXIT=1,GMTSCPL("@")=""
S:X="N"&($L(GMTSNEW))&(GMTSNEW=GMTSOLD) GMTSEXIT=1,GMTSCPL("@")=""
S X=$S(X="Y":1,X="N":0,1:-1)
Q
YNDI(X) ; Input Transform
N GMTS S GMTS=$$UP^GMTSXA($G(X)) Q:$L(GMTS)&("^Y^YE^YES^N^NO^@^^^^^"'[("^"_GMTS_"^")) 0 Q 1
YNDO(X) ; Output Transform
N GMTS S GMTS=$$UP^GMTSXA($G(X)) S X=$S($E(GMTS,1)="Y":"Y",$E(GMTS,1)="N":"N",$E(GMTS,1)="@":"@",GMTS["^^":"^^",1:"^")
S X=$S($D(DUOUT):"^",1:X),X=$S($D(DTOUT):"^^",$D(DIROUT):"^^",1:X) Q X
YNDH ; Help
W !," Enter either 'Y'es, 'N'o, or '^' to exit" Q
Q
;
EDIT(GMTSUXR,X) ; Edit "Append/Overwrite"
N DIC,DIE,DTOUT,DUOUT,Y,DR,DA,GMTSACT,GMTSDAT,GMTSPREF,GMTSA
S GMTSDAT=$G(X),GMTSUSR=+($G(GMTSUSR)) Q:GMTSUSR=0 S GMTSACT=$$ACTIVE^XUSER(+GMTSUSR) D:+GMTSACT'>0 DP(GMTSUSR) Q:+GMTSACT'>0
S GMTSPREF=$$PENT(GMTSUSR) Q:+GMTSPREF'>0
S DIE="^GMT(142.98,",DA=+($G(GMTSUSR)),DR="11///^S X=GMTSDAT"
ED ; Lock Record, Edit Entry
L +^GMT(142.98,+GMTSPREF):0 I $T D ^DIE L -^GMT(142.98,+GMTSPREF) Q
S GMTSA=+($G(GMTSA))+1 Q:GMTSA>3 H 1 G ED
Q
;
; Deletions
ADEL ; Ask for Deletion of Precedence
N X,Y,GMTSU,GMTSACT,GMTSDEF S GMTSU=$G(GMTSUSR),GMTSACT=$$ACTIVE^XUSER(+GMTSU) D:+GMTSACT'>0 DP(GMTSUSR) Q:+GMTSACT'>0 S X=$$UNM^GMTSXAW3(+($G(GMTSUSR))) Q:'$L(X)
Q:'$D(^GMT(142.98,+GMTSUSR,1)) S GMTSDEF=$P($G(^GMT(142.98,+GMTSUSR,1)),"^",2) Q:'$L(GMTSDEF)
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,GMTSA S DIR("B")="N",(GMTSA,DIR("A"))="Delete '"_GMTSDEF_"'? (Y/N) " S:$D(GMTSEL("@")) DIR("A")=" "_GMTSA S:$D(GMTSORD("@")) DIR("A")=" "_GMTSA
S:$D(GMTSCPL("@")) DIR("A")=" "_GMTSA K GMTSEL("@"),GMTSORD("@"),GMTSCPL("@")
S DIR(0)="YAO" W ! D ^DIR S:+Y>0 $P(^GMT(142.98,+GMTSUSR,1),"^",2)=""
Q
DP(X) ; Delete Record of Inactive User
N DA,DIK,DIC,DTOUT,DUOUT,GMTSUSR S GMTSUSR=+($G(X))
S X=$$UNM^GMTSXAW3(+($G(GMTSUSR))) Q:'$L(X)
S DIC="^GMT(142.98,",DIC(0)="M" D ^DIC I +Y>0 S DIK=DIC,DA=+Y D ^DIK
Q
;
; Miscellaneous
OLD(X) ; Old Entry
Q $$GET1^DIQ(142.98,+($G(GMTSUSR)),11)
ORT(X) ; Total Entities Ordered
N GMTSI S (X,GMTSI)=0 F S GMTSI=$O(GMTSORD(GMTSI)) Q:+GMTSI=0 S X=X+1
Q X
SLT(X) ; Total Selected
N GMTSI S (X,GMTSI)=0 F S GMTSI=$O(GMTSEL(GMTSI)) Q:+GMTSI=0 S X=X+1
Q X
PENT(GMTSUSR) ; Get User Preference Entry
N DIC,DTOUT,DUOUT,GMTSACT,DLAYGO S GMTSUSR=+($G(GMTSUSR)) Q:GMTSUSR=0 -1
S GMTSACT=$$ACTIVE^XUSER(+GMTSUSR) D:+GMTSACT'>0 DP(GMTSUSR) Q:+GMTSACT'>0 -1
S X=$$UNM^GMTSXAW3(+($G(GMTSUSR))) Q:'$L(X) -1
S DIC="^GMT(142.98,",DIC(0)="LM",DLAYGO=142.98 D ^DIC
S X=+($G(Y)) Q X
PIT(X) ; Precedence Input Transform
N GMTSIN S GMTSIN=$$UP^GMTSXA($G(X)) Q:GMTSIN="" 1 N GMTSC,GMTSI,GMTSA,GMTS S GMTSC="^NAT^SYS^USR^",GMTS="" F GMTSI=1:1 Q:GMTSI>$L(GMTSIN,";") D
. S GMTSA=$P($G(GMTSIN),";",GMTSI) Q:$L(GMTSA)'=3 Q:GMTSC'[("^"_GMTSA_"^") Q:GMTS[(";"_GMTSA) S GMTS=GMTS_";"_GMTSA
S GMTS=$$TRIM^GMTSXA(GMTS,";",3),X=$S(GMTS=GMTSIN:1,1:0) Q X
USRD(X) ; User Precedence/Default
N GMTSUSR S GMTSUSR=$G(X),X=$P($G(^GMT(142.98,+($G(GMTSUSR)),1)),"^",2)
S:X="" X=$$DEF^GMTSXAW(GMTSUSR) Q X
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMTSXAP2 5338 printed Sep 23, 2025@19:36:55 Page 2
GMTSXAP2 ; SLC/KER - List Parameters/Precedence 2 ; 02/27/2002
+1 ;;2.7;Health Summary;**47,49**;Oct 20, 1995
+2 QUIT
+3 ;
+4 ; External References in GMTSXAP2
+5 ; DBIA 2056 $$GET1^DIQ
+6 ; DBIA 2343 $$ACTIVE^XUSER
+7 ; DBIA 10006 ^DIC
+8 ; DBIA 10026 ^DIR
+9 ; DBIA 10018 ^DIE
+10 ; DBIA 10013 ^DIK
+11 ;
+12 ; Check to see if Compiled Order is correct
OK(X) ; Ask if Ok
+1 NEW Y,DIR,GMTSTOT,GMTSOLD
SET GMTSNEW=$GET(GMTSNEW)
SET GMTSOLD=$$OLD
+2 SET GMTSTOT=$$ORT
if GMTSTOT=1
SET X=$$OKO
if GMTSTOT>1
SET X=$$OKM
if GMTSTOT'>0
SET X=0
+3 QUIT X
OKM(X) ; Multiple entities selected i.e. USR;SYS
+1 NEW DIR,Y,DIROUT,DUOUT,DTOUT
SET X=1
DO OKA
if '$DATA(DIR)
QUIT 0
+2 DO YND
+3 QUIT X
OKO(X) ; Only one entity selected i.e. USR
+1 IF '$LENGTH($GET(GMTSORD(1)))!($LENGTH($PIECE(GMTSORD(1),"^",1))'=3)!($LENGTH($PIECE(GMTSORD(1),"^",3))'>0)
QUIT 0
+2 NEW DIR,Y,DIROUT,DUOUT,DTOUT
DO OKA
if '$DATA(DIR)
QUIT 0
+3 DO YND
+4 QUIT X
OKA ; Set up Prompts - DIR("A")
+1 NEW GMTSC,GMTSI,GMTST
SET (GMTSC,GMTSI)=0
SET GMTST=$$ORT
MUL ; Multiple Entities
+1 IF GMTST>1
Begin DoDot:1
+2 KILL DIR
NEW GMTSTC,GMTSA,GMTSC
SET GMTSC=0
SET GMTSA=GMTST+4
SET GMTSTC=$SELECT(GMTST=2:"two",GMTST=3:"three",1:"several")
+3 SET DIR("A",1)=""
SET DIR("A",2)=" You have selected "_GMTSTC_" Health Summary Types, arranged "
+4 SET DIR("A",3)=" in the following order:"
SET DIR("A",4)=""
+5 FOR GMTSA=1:1:GMTST
SET DIR("A",(4+GMTSA))=" "_$JUSTIFY(GMTSA,2)_" "_$PIECE($GET(GMTSORD(+GMTSA)),"^",3)
+6 SET GMTSA=+($ORDER(DIR("A"," "),-1))+1
SET DIR("A",GMTSA)=""
SET DIR("A")=" Is this precedence correct? (Y/N) "
SET DIR(0)="YAO"
SET DIR("B")="Y"
End DoDot:1
QUIT
ONE ; One Entity
+1 IF GMTST=1
Begin DoDot:1
+2 IF $LENGTH($GET(GMTSORD(1)))
IF $LENGTH($PIECE(GMTSORD(1),"^",1))=3
IF $LENGTH($PIECE(GMTSORD(1),"^",3))>0
Begin DoDot:2
+3 KILL DIR
SET DIR("A",1)=""
+4 SET DIR("A",2)=" You have selected one Health Summary Type"
+5 SET DIR("A",3)=""
+6 SET DIR("A",4)=" "_$PIECE($GET(GMTSORD(1)),"^",3)
+7 SET DIR("A",5)=""
+8 SET DIR("A")=" Is this correct? (Y/N) "
+9 SET DIR(0)="YAO"
SET DIR("B")="Y"
End DoDot:2
QUIT
+10 KILL DIR
End DoDot:1
QUIT
+11 KILL DIR
+12 QUIT
+13 ;
YND ; Yes/No/Delete
+1 WRITE !
SET X=$GET(X)
if $LENGTH($GET(DIR("A")))
SET DIR("A")=" Is this correct? (Y/N) "
+2 SET (DIR("?"),DIR("??"))="^D YNDH^GMTSXAP2"
+3 SET DIR(0)="FAO^1;3^K:$$YNDI^GMTSXAP2(X)'>0 X"
SET DIR("B")="Y"
+4 DO ^DIR
SET X=$$YNDO(X)
if X["^"
SET GMTSEXIT=1
if X="@"
SET GMTSEXIT=1
SET GMTSCPL("@")=""
+5 if X="N"&($LENGTH(GMTSNEW))&(GMTSNEW=GMTSOLD)
SET GMTSEXIT=1
SET GMTSCPL("@")=""
+6 SET X=$SELECT(X="Y":1,X="N":0,1:-1)
+7 QUIT
YNDI(X) ; Input Transform
+1 NEW GMTS
SET GMTS=$$UP^GMTSXA($GET(X))
if $LENGTH(GMTS)&("^Y^YE^YES^N^NO^@^^^^^"'[("^"_GMTS_"^"))
QUIT 0
QUIT 1
YNDO(X) ; Output Transform
+1 NEW GMTS
SET GMTS=$$UP^GMTSXA($GET(X))
SET X=$SELECT($EXTRACT(GMTS,1)="Y":"Y",$EXTRACT(GMTS,1)="N":"N",$EXTRACT(GMTS,1)="@":"@",GMTS["^^":"^^",1:"^")
+2 SET X=$SELECT($DATA(DUOUT):"^",1:X)
SET X=$SELECT($DATA(DTOUT):"^^",$DATA(DIROUT):"^^",1:X)
QUIT X
YNDH ; Help
+1 WRITE !," Enter either 'Y'es, 'N'o, or '^' to exit"
QUIT
+2 QUIT
+3 ;
EDIT(GMTSUXR,X) ; Edit "Append/Overwrite"
+1 NEW DIC,DIE,DTOUT,DUOUT,Y,DR,DA,GMTSACT,GMTSDAT,GMTSPREF,GMTSA
+2 SET GMTSDAT=$GET(X)
SET GMTSUSR=+($GET(GMTSUSR))
if GMTSUSR=0
QUIT
SET GMTSACT=$$ACTIVE^XUSER(+GMTSUSR)
if +GMTSACT'>0
DO DP(GMTSUSR)
if +GMTSACT'>0
QUIT
+3 SET GMTSPREF=$$PENT(GMTSUSR)
if +GMTSPREF'>0
QUIT
+4 SET DIE="^GMT(142.98,"
SET DA=+($GET(GMTSUSR))
SET DR="11///^S X=GMTSDAT"
ED ; Lock Record, Edit Entry
+1 LOCK +^GMT(142.98,+GMTSPREF):0
IF $TEST
DO ^DIE
LOCK -^GMT(142.98,+GMTSPREF)
QUIT
+2 SET GMTSA=+($GET(GMTSA))+1
if GMTSA>3
QUIT
HANG 1
GOTO ED
+3 QUIT
+4 ;
+5 ; Deletions
ADEL ; Ask for Deletion of Precedence
+1 NEW X,Y,GMTSU,GMTSACT,GMTSDEF
SET GMTSU=$GET(GMTSUSR)
SET GMTSACT=$$ACTIVE^XUSER(+GMTSU)
if +GMTSACT'>0
DO DP(GMTSUSR)
if +GMTSACT'>0
QUIT
SET X=$$UNM^GMTSXAW3(+($GET(GMTSUSR)))
if '$LENGTH(X)
QUIT
+2 if '$DATA(^GMT(142.98,+GMTSUSR,1))
QUIT
SET GMTSDEF=$PIECE($GET(^GMT(142.98,+GMTSUSR,1)),"^",2)
if '$LENGTH(GMTSDEF)
QUIT
+3 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,GMTSA
SET DIR("B")="N"
SET (GMTSA,DIR("A"))="Delete '"_GMTSDEF_"'? (Y/N) "
if $DATA(GMTSEL("@"))
SET DIR("A")=" "_GMTSA
if $DATA(GMTSORD("@"))
SET DIR("A")=" "_GMTSA
+4 if $DATA(GMTSCPL("@"))
SET DIR("A")=" "_GMTSA
KILL GMTSEL("@"),GMTSORD("@"),GMTSCPL("@")
+5 SET DIR(0)="YAO"
WRITE !
DO ^DIR
if +Y>0
SET $PIECE(^GMT(142.98,+GMTSUSR,1),"^",2)=""
+6 QUIT
DP(X) ; Delete Record of Inactive User
+1 NEW DA,DIK,DIC,DTOUT,DUOUT,GMTSUSR
SET GMTSUSR=+($GET(X))
+2 SET X=$$UNM^GMTSXAW3(+($GET(GMTSUSR)))
if '$LENGTH(X)
QUIT
+3 SET DIC="^GMT(142.98,"
SET DIC(0)="M"
DO ^DIC
IF +Y>0
SET DIK=DIC
SET DA=+Y
DO ^DIK
+4 QUIT
+5 ;
+6 ; Miscellaneous
OLD(X) ; Old Entry
+1 QUIT $$GET1^DIQ(142.98,+($GET(GMTSUSR)),11)
ORT(X) ; Total Entities Ordered
+1 NEW GMTSI
SET (X,GMTSI)=0
FOR
SET GMTSI=$ORDER(GMTSORD(GMTSI))
if +GMTSI=0
QUIT
SET X=X+1
+2 QUIT X
SLT(X) ; Total Selected
+1 NEW GMTSI
SET (X,GMTSI)=0
FOR
SET GMTSI=$ORDER(GMTSEL(GMTSI))
if +GMTSI=0
QUIT
SET X=X+1
+2 QUIT X
PENT(GMTSUSR) ; Get User Preference Entry
+1 NEW DIC,DTOUT,DUOUT,GMTSACT,DLAYGO
SET GMTSUSR=+($GET(GMTSUSR))
if GMTSUSR=0
QUIT -1
+2 SET GMTSACT=$$ACTIVE^XUSER(+GMTSUSR)
if +GMTSACT'>0
DO DP(GMTSUSR)
if +GMTSACT'>0
QUIT -1
+3 SET X=$$UNM^GMTSXAW3(+($GET(GMTSUSR)))
if '$LENGTH(X)
QUIT -1
+4 SET DIC="^GMT(142.98,"
SET DIC(0)="LM"
SET DLAYGO=142.98
DO ^DIC
+5 SET X=+($GET(Y))
QUIT X
PIT(X) ; Precedence Input Transform
+1 NEW GMTSIN
SET GMTSIN=$$UP^GMTSXA($GET(X))
if GMTSIN=""
QUIT 1
NEW GMTSC,GMTSI,GMTSA,GMTS
SET GMTSC="^NAT^SYS^USR^"
SET GMTS=""
FOR GMTSI=1:1
if GMTSI>$LENGTH(GMTSIN,";")
QUIT
Begin DoDot:1
+2 SET GMTSA=$PIECE($GET(GMTSIN),";",GMTSI)
if $LENGTH(GMTSA)'=3
QUIT
if GMTSC'[("^"_GMTSA_"^")
QUIT
if GMTS[(";"_GMTSA)
QUIT
SET GMTS=GMTS_";"_GMTSA
End DoDot:1
+3 SET GMTS=$$TRIM^GMTSXA(GMTS,";",3)
SET X=$SELECT(GMTS=GMTSIN:1,1:0)
QUIT X
USRD(X) ; User Precedence/Default
+1 NEW GMTSUSR
SET GMTSUSR=$GET(X)
SET X=$PIECE($GET(^GMT(142.98,+($GET(GMTSUSR)),1)),"^",2)
+2 if X=""
SET X=$$DEF^GMTSXAW(GMTSUSR)
QUIT X
