GMTSXPD4 ; SLC/KER - Health Summary Dist (Re-Build) ; 08/27/2002
;;2.7;Health Summary;**35,56**;Oct 20, 1995
;
; External References
; DBIA 10013 ^DIK (file #142)
; DBIA 2052 $$GET1^DID
; DBIA 10018 ^DIE (file #142)
; DBIA 10086 HOME^%ZIS
; DBIA 10060 ^VA(200,
; DBIA 2056 $$GET1^DIQ (file 200)
; DBIA 10141 BMES^XPDUTL
; DBIA 10141 MES^XPDUTL
;
Q
; Re-Build Ad Hoc Health Summary Type
;
; Input Variables INCLUDE
; 0 exclude DISABLED components
; 1 include DISABLED components
;
IN ; Re-Build w/INCLUDE
N INCLUDE S INCLUDE=1 D RB Q
EX ; Re-Build w/EXCLUDE
N INCLUDE S INCLUDE=0 D RB Q
RB ; Re-Build (main)
N GMTSENV S GMTSENV=$$ENV Q:'GMTSENV
N DA,DIC,DIE,DIK,DLAYGO,DR,GMTSC,GMTSDA,GMTSDIAB,GMTSE,GMTSEG,GMTSEL
N GMTSELC,GMTSELT,GMTSEQ,GMTSI,GMTSICD,GMTSIFN,GMTSISEQ,GMTSITEM
N GMTSJ,GMTSL,GMTSLOC,GMTSNAR,GMTSCPT,GMTSNEW,GMTSNM,GMTSOCC,GMTSOK
N GMTSORD,GMTSQ,GMTST1,GMTST2,GMTST3,GMTSTIM,GMTSTYP,X,Y
S GMTSOK=0,GMTSE=59,GMTSC=0 D BM(" Ad Hoc Summary") S GMTST1=" Gathering Ad Hoc Summary information",GMTST2=" Purging old Ad Hoc Summary",GMTST3=" Rebuilding Ad Hoc Summary"
D M($G(GMTST1)) N GMTSNEW,GMTSTYP,DLAYGO S DLAYGO=142
S DIC=142,DIC(0)="LXF",X="GMTS HS ADHOC OPTION" S Y=$$TYPE^GMTSULT K DIC
I +Y'>0 D BM("** GMTS AD HOC OPTION Summary Type is missing **") Q
D GA,RN D:+($G(GMTSOK))>0 BM(" Ad Hoc Health Summary successfully rebuilt")
D:+($G(GMTSOK))'>0 BM(" Failed to successfully rebuild the Ad Hoc Health Summary")
Q
GA ; Gather Information
N GMTSL,GMTSQ,GMTSC,GMTSE
S GMTSE=59,GMTSC=0,GMTSL=$L($G(GMTST1))
S (GMTSIFN,GMTSTYP)=+Y,GMTSNEW=+$P(Y,"^",3)
S:'$D(^GMT(142,GMTSIFN,1,0)) ^(0)="^142.01IA^0^0"
S GMTSC=0,GMTSNM="" F GMTSC=1:1 S GMTSNM=$O(^GMT(142.1,"B",GMTSNM)) Q:GMTSNM']"" S GMTSC=+($G(GMTSC))+1
S GMTSC=GMTSC-1,GMTSQ=GMTSC\(GMTSE-$L(GMTST1))
S GMTSC=0,GMTSNM="" F GMTSC=1:1 S GMTSNM=$O(^GMT(142.1,"B",GMTSNM)) Q:GMTSNM']"" D
. S GMTSJ=$O(^(GMTSNM,0)) Q:GMTSJ'>0 D LA
. Q:$D(GMTSQT) Q:+GMTSQ'>0
. S GMTSC=GMTSC+1 S:GMTSC#GMTSQ=0 GMTSL=GMTSL+1 Q:GMTSL>GMTSE
. W:GMTSC#GMTSQ=0 "."
I '$D(GMTSQT),GMTSL'>GMTSE F S GMTSL=GMTSL+1 Q:GMTSL>GMTSE W "."
W:'$D(GMTSQT) ?GMTSE," < done >"
S GMTSI=0 I 'GMTSNEW D PA
Q
PA ; Purge Ad Hoc Health Summary
N GMTSI,GMTSL,GMTSQ,GMTSC,GMTSE S GMTSE=59,GMTSL=$L($G(GMTST2)) D M($G(GMTST2))
S (GMTSC,GMTSI)=0 F S GMTSI=$O(^GMT(142,GMTSIFN,1,GMTSI)) Q:GMTSI'>0 S GMTSC=+($G(GMTSC))+1
S GMTSC=GMTSC-1,GMTSQ=GMTSC\(GMTSE-$L(GMTST1))
S (GMTSC,GMTSI)=0 F S GMTSI=$O(^GMT(142,GMTSIFN,1,GMTSI)) Q:GMTSI'>0 D
. N DA,DIK S U="^",DA(1)=GMTSIFN,DA=GMTSI,DIK="^GMT(142,"_GMTSIFN_",1," D ^DIK
. Q:$D(GMTSQT) Q:+GMTSQ'>0
. S GMTSC=GMTSC+1 S:GMTSC#GMTSQ=0 GMTSL=GMTSL+1 Q:GMTSL>GMTSE
. W:GMTSC#GMTSQ=0 "."
I '$D(GMTSQT),GMTSL'>GMTSE F S GMTSL=GMTSL+1 Q:GMTSL>GMTSE W "."
W:'$D(GMTSQT) ?GMTSE," < done >"
Q
RN ; Renumber - Resets ^GMT(142,GMTSIFN,1,
N DA,DR,DIE,GMTSEQ,GMTSL
N GMTSL,GMTSQ,GMTSC,GMTSE S GMTSE=59,GMTSL=$L($G(GMTST3)) D M($G(GMTST3))
S (GMTSEQ,GMTSC)=0 F S GMTSEQ=$O(GMTSEG(GMTSEQ)) Q:GMTSEQ'>0 S GMTSC=+($G(GMTSC))+1
S GMTSC=GMTSC-1,GMTSQ=GMTSC\(GMTSE-$L(GMTST3))
S (GMTSEQ,GMTSC)=0 F S GMTSEQ=$O(GMTSEG(GMTSEQ)) Q:GMTSEQ'>0 D
. K DA S DIE="^GMT(142,"_GMTSIFN_",1,",DA(1)=GMTSIFN D AC
. Q:$D(GMTSQT) Q:+GMTSQ'>0
. S GMTSC=GMTSC+1 S:GMTSC#GMTSQ=0 GMTSL=GMTSL+1 Q:GMTSL>GMTSE
. W:GMTSC#GMTSQ=0 "."
I '$D(GMTSQT),GMTSL'>GMTSE F S GMTSL=GMTSL+1 Q:GMTSL>GMTSE W "."
W:'$D(GMTSQT) ?GMTSE," < done >" S GMTSOK=1
Q
LA ; Load Array GMTSEG(#)
N GMTSOCC,GMTSTIM,GMTSORD,GMTSLOC,GMTSICD,GMTSNAR,GMTSCPT
Q:'$D(^GMT(142.1,GMTSJ,0))
S GMTSORD=$O(^GMT(142,"AE",GMTSJ,GMTSTYP,0))
I GMTSORD>0 D
. S GMTSOCC=$S($P(^GMT(142.1,GMTSJ,0),"^",5)="Y":$P($G(^GMT(142,GMTSTYP,1,GMTSORD,0)),"^",3),1:"")
. S GMTSTIM=$S($P(^GMT(142.1,GMTSJ,0),"^",3)="Y":$P($G(^GMT(142,GMTSTYP,1,GMTSORD,0)),"^",4),1:"")
. S GMTSLOC=$S($P(^GMT(142.1,GMTSJ,0),"^",10)="Y":$P($G(^GMT(142,GMTSTYP,1,GMTSORD,0)),"^",6),1:"")
. S GMTSICD=$S($P(^GMT(142.1,GMTSJ,0),"^",11)="Y":$P($G(^GMT(142,GMTSTYP,1,GMTSORD,0)),"^",7),1:"")
. S GMTSNAR=$S($P(^GMT(142.1,GMTSJ,0),"^",12)="Y":$P($G(^GMT(142,GMTSTYP,1,GMTSORD,0)),"^",8),1:"")
. S GMTSCPT=$S($P(^GMT(142.1,GMTSJ,0),"^",14)="Y":$P($G(^GMT(142,GMTSTYP,1,GMTSORD,0)),"^",9),1:"")
E D
. S GMTSOCC=$S($P(^GMT(142.1,GMTSJ,0),"^",5)="Y":10,1:"")
. S GMTSTIM=$S($P(^GMT(142.1,GMTSJ,0),"^",3)="Y":"1Y",1:"")
. S GMTSLOC=$S($P(^GMT(142.1,GMTSJ,0),"^",10)="Y":"Y",1:"")
. S GMTSICD=$S($P(^GMT(142.1,GMTSJ,0),"^",11)="Y":"L",1:"")
. S GMTSNAR=$S($P(^GMT(142.1,GMTSJ,0),"^",12)="Y":"Y",1:"")
. S GMTSCPT=$S($P(^GMT(142.1,GMTSJ,0),"^",12)="Y":"Y",1:"")
; Defaults for CPT Modifiers
S:$P(^GMT(142.1,GMTSJ,0),"^",14)="Y"&(GMTSCPT="") GMTSCPT="Y"
S:$$GET1^DID(142.1,14,,"LABEL")="" GMTSCPT=""
D SG
Q
SG ; Set GMTSEG(#) Component
; Disabled
N GMTSDIAB S GMTSDIAB=$S($P(^GMT(142.1,GMTSJ,0),"^",6)="P":1,$P(^(0),"^",6)="T":1,1:0) I (INCLUDE=0),(GMTSDIAB=1) Q
; Include
S GMTSEG(GMTSC)=(5*GMTSC)_"^"_GMTSJ_"^"_GMTSOCC_"^"_GMTSTIM_"^^"_GMTSLOC_"^"_GMTSICD_"^"_GMTSNAR_"^"_GMTSCPT I GMTSORD>0 D SL
Q
SL ; Set GMTSEG(#,#) Selection item
N GMTSELT,GMTSITEM
S GMTSELT=0 F S GMTSELT=$O(^GMT(142,GMTSTYP,1,+GMTSORD,1,GMTSELT)) Q:GMTSELT'>0 D
. S GMTSITEM=^(GMTSELT,0) S GMTSEG(GMTSC,GMTSELT)=GMTSITEM
Q
AC ; Add Components to Ad Hoc Summary
N GMTSISEQ,DA,DIE,DR,GMTSELC,GMTSDA,GMTSEL
S (GMTSISEQ,DA)=GMTSEQ*5,DIE="^GMT(142,"_GMTSIFN_",1,",DA(1)=GMTSIFN
S DR=".01///"_DA
S:$L($P(GMTSEG(GMTSEQ),"^",2)) DR=DR_";1///"_$P(GMTSEG(GMTSEQ),"^",2)
S:$L($P(GMTSEG(GMTSEQ),"^",3)) DR=DR_";2///"_$P(GMTSEG(GMTSEQ),"^",3)
S:$L($P(GMTSEG(GMTSEQ),"^",4)) DR=DR_";3///"_$P(GMTSEG(GMTSEQ),"^",4)
S:$L($P(GMTSEG(GMTSEQ),"^",5)) DR=DR_";5///"_$P(GMTSEG(GMTSEQ),"^",5)
S:$L($P(GMTSEG(GMTSEQ),"^",6)) DR=DR_";6///"_$P(GMTSEG(GMTSEQ),"^",6)
S:$L($P(GMTSEG(GMTSEQ),"^",7)) DR=DR_";7///"_$P(GMTSEG(GMTSEQ),"^",7)
S:$L($P(GMTSEG(GMTSEQ),"^",8)) DR=DR_";8///"_$P(GMTSEG(GMTSEQ),"^",8)
S:$L($P($G(GMTSEG(GMTSEQ)),"^",9))>0&($L($$GET1^DID(142.1,14,,"LABEL"))>0) DR=DR_";9///"_$P(GMTSEG(GMTSEQ),"^",9)
D ^DIE S (GMTSELC,GMTSEL)=0 F S GMTSEL=$O(GMTSEG(GMTSEQ,GMTSEL)) Q:'GMTSEL D AS
I GMTSELC>0 S:'$D(^GMT(142,GMTSIFN,1,GMTSISEQ,1,0)) ^(0)="^142.14V^"_GMTSDA_"^"_GMTSELC
Q
AS ; Add Selection Items to Ad Hoc Summary
N DIE,DA,DR
S:'$D(^GMT(142,GMTSIFN,1,GMTSISEQ,1,0)) ^(0)="^142.14V^^"
S DIE="^GMT(142,"_GMTSIFN_",1,"_GMTSISEQ_",1,"
S DA(2)=GMTSIFN,DA(1)=GMTSISEQ,DA=GMTSEL
S DR=".01////"_"^S X=GMTSEG(GMTSEQ,GMTSEL)" D ^DIE
S GMTSDA=DA,GMTSELC=GMTSELC+1
Q
;
; Misc
ENV(X) ; Environment check
D HOME^%ZIS I +($G(DUZ))=0 D BM(" User (DUZ) not defined"),M(" ") Q 0
I '$L($$GET1^DIQ(200,(+($G(DUZ))_","),.01)) D BM(" Invalid User defined (DUZ)"),M(" ") Q 0
Q 1
BM(X) ; Blank Line with Message
Q:$D(GMTSQT) D:$D(XPDNM) BMES^XPDUTL($G(X)) W:'$D(XPDNM) !!,$G(X) Q
M(X) ; Message
Q:$D(GMTSQT) D:$D(XPDNM) MES^XPDUTL($G(X)) W:'$D(XPDNM) !,$G(X) Q
UP(X) ; Uppercase
Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMTSXPD4 7386 printed Dec 13, 2024@02:00:58 Page 2
GMTSXPD4 ; SLC/KER - Health Summary Dist (Re-Build) ; 08/27/2002
+1 ;;2.7;Health Summary;**35,56**;Oct 20, 1995
+2 ;
+3 ; External References
+4 ; DBIA 10013 ^DIK (file #142)
+5 ; DBIA 2052 $$GET1^DID
+6 ; DBIA 10018 ^DIE (file #142)
+7 ; DBIA 10086 HOME^%ZIS
+8 ; DBIA 10060 ^VA(200,
+9 ; DBIA 2056 $$GET1^DIQ (file 200)
+10 ; DBIA 10141 BMES^XPDUTL
+11 ; DBIA 10141 MES^XPDUTL
+12 ;
+13 QUIT
+14 ; Re-Build Ad Hoc Health Summary Type
+15 ;
+16 ; Input Variables INCLUDE
+17 ; 0 exclude DISABLED components
+18 ; 1 include DISABLED components
+19 ;
IN ; Re-Build w/INCLUDE
+1 NEW INCLUDE
SET INCLUDE=1
DO RB
QUIT
EX ; Re-Build w/EXCLUDE
+1 NEW INCLUDE
SET INCLUDE=0
DO RB
QUIT
RB ; Re-Build (main)
+1 NEW GMTSENV
SET GMTSENV=$$ENV
if 'GMTSENV
QUIT
+2 NEW DA,DIC,DIE,DIK,DLAYGO,DR,GMTSC,GMTSDA,GMTSDIAB,GMTSE,GMTSEG,GMTSEL
+3 NEW GMTSELC,GMTSELT,GMTSEQ,GMTSI,GMTSICD,GMTSIFN,GMTSISEQ,GMTSITEM
+4 NEW GMTSJ,GMTSL,GMTSLOC,GMTSNAR,GMTSCPT,GMTSNEW,GMTSNM,GMTSOCC,GMTSOK
+5 NEW GMTSORD,GMTSQ,GMTST1,GMTST2,GMTST3,GMTSTIM,GMTSTYP,X,Y
+6 SET GMTSOK=0
SET GMTSE=59
SET GMTSC=0
DO BM(" Ad Hoc Summary")
SET GMTST1=" Gathering Ad Hoc Summary information"
SET GMTST2=" Purging old Ad Hoc Summary"
SET GMTST3=" Rebuilding Ad Hoc Summary"
+7 DO M($GET(GMTST1))
NEW GMTSNEW,GMTSTYP,DLAYGO
SET DLAYGO=142
+8 SET DIC=142
SET DIC(0)="LXF"
SET X="GMTS HS ADHOC OPTION"
SET Y=$$TYPE^GMTSULT
KILL DIC
+9 IF +Y'>0
DO BM("** GMTS AD HOC OPTION Summary Type is missing **")
QUIT
+10 DO GA
DO RN
if +($GET(GMTSOK))>0
DO BM(" Ad Hoc Health Summary successfully rebuilt")
+11 if +($GET(GMTSOK))'>0
DO BM(" Failed to successfully rebuild the Ad Hoc Health Summary")
+12 QUIT
GA ; Gather Information
+1 NEW GMTSL,GMTSQ,GMTSC,GMTSE
+2 SET GMTSE=59
SET GMTSC=0
SET GMTSL=$LENGTH($GET(GMTST1))
+3 SET (GMTSIFN,GMTSTYP)=+Y
SET GMTSNEW=+$PIECE(Y,"^",3)
+4 if '$DATA(^GMT(142,GMTSIFN,1,0))
SET ^(0)="^142.01IA^0^0"
+5 SET GMTSC=0
SET GMTSNM=""
FOR GMTSC=1:1
SET GMTSNM=$ORDER(^GMT(142.1,"B",GMTSNM))
if GMTSNM']""
QUIT
SET GMTSC=+($GET(GMTSC))+1
+6 SET GMTSC=GMTSC-1
SET GMTSQ=GMTSC\(GMTSE-$LENGTH(GMTST1))
+7 SET GMTSC=0
SET GMTSNM=""
FOR GMTSC=1:1
SET GMTSNM=$ORDER(^GMT(142.1,"B",GMTSNM))
if GMTSNM']""
QUIT
Begin DoDot:1
+8 SET GMTSJ=$ORDER(^(GMTSNM,0))
if GMTSJ'>0
QUIT
DO LA
+9 if $DATA(GMTSQT)
QUIT
if +GMTSQ'>0
QUIT
+10 SET GMTSC=GMTSC+1
if GMTSC#GMTSQ=0
SET GMTSL=GMTSL+1
if GMTSL>GMTSE
QUIT
+11 if GMTSC#GMTSQ=0
WRITE "."
End DoDot:1
+12 IF '$DATA(GMTSQT)
IF GMTSL'>GMTSE
FOR
SET GMTSL=GMTSL+1
if GMTSL>GMTSE
QUIT
WRITE "."
+13 if '$DATA(GMTSQT)
WRITE ?GMTSE," < done >"
+14 SET GMTSI=0
IF 'GMTSNEW
DO PA
+15 QUIT
PA ; Purge Ad Hoc Health Summary
+1 NEW GMTSI,GMTSL,GMTSQ,GMTSC,GMTSE
SET GMTSE=59
SET GMTSL=$LENGTH($GET(GMTST2))
DO M($GET(GMTST2))
+2 SET (GMTSC,GMTSI)=0
FOR
SET GMTSI=$ORDER(^GMT(142,GMTSIFN,1,GMTSI))
if GMTSI'>0
QUIT
SET GMTSC=+($GET(GMTSC))+1
+3 SET GMTSC=GMTSC-1
SET GMTSQ=GMTSC\(GMTSE-$LENGTH(GMTST1))
+4 SET (GMTSC,GMTSI)=0
FOR
SET GMTSI=$ORDER(^GMT(142,GMTSIFN,1,GMTSI))
if GMTSI'>0
QUIT
Begin DoDot:1
+5 NEW DA,DIK
SET U="^"
SET DA(1)=GMTSIFN
SET DA=GMTSI
SET DIK="^GMT(142,"_GMTSIFN_",1,"
DO ^DIK
+6 if $DATA(GMTSQT)
QUIT
if +GMTSQ'>0
QUIT
+7 SET GMTSC=GMTSC+1
if GMTSC#GMTSQ=0
SET GMTSL=GMTSL+1
if GMTSL>GMTSE
QUIT
+8 if GMTSC#GMTSQ=0
WRITE "."
End DoDot:1
+9 IF '$DATA(GMTSQT)
IF GMTSL'>GMTSE
FOR
SET GMTSL=GMTSL+1
if GMTSL>GMTSE
QUIT
WRITE "."
+10 if '$DATA(GMTSQT)
WRITE ?GMTSE," < done >"
+11 QUIT
RN ; Renumber - Resets ^GMT(142,GMTSIFN,1,
+1 NEW DA,DR,DIE,GMTSEQ,GMTSL
+2 NEW GMTSL,GMTSQ,GMTSC,GMTSE
SET GMTSE=59
SET GMTSL=$LENGTH($GET(GMTST3))
DO M($GET(GMTST3))
+3 SET (GMTSEQ,GMTSC)=0
FOR
SET GMTSEQ=$ORDER(GMTSEG(GMTSEQ))
if GMTSEQ'>0
QUIT
SET GMTSC=+($GET(GMTSC))+1
+4 SET GMTSC=GMTSC-1
SET GMTSQ=GMTSC\(GMTSE-$LENGTH(GMTST3))
+5 SET (GMTSEQ,GMTSC)=0
FOR
SET GMTSEQ=$ORDER(GMTSEG(GMTSEQ))
if GMTSEQ'>0
QUIT
Begin DoDot:1
+6 KILL DA
SET DIE="^GMT(142,"_GMTSIFN_",1,"
SET DA(1)=GMTSIFN
DO AC
+7 if $DATA(GMTSQT)
QUIT
if +GMTSQ'>0
QUIT
+8 SET GMTSC=GMTSC+1
if GMTSC#GMTSQ=0
SET GMTSL=GMTSL+1
if GMTSL>GMTSE
QUIT
+9 if GMTSC#GMTSQ=0
WRITE "."
End DoDot:1
+10 IF '$DATA(GMTSQT)
IF GMTSL'>GMTSE
FOR
SET GMTSL=GMTSL+1
if GMTSL>GMTSE
QUIT
WRITE "."
+11 if '$DATA(GMTSQT)
WRITE ?GMTSE," < done >"
SET GMTSOK=1
+12 QUIT
LA ; Load Array GMTSEG(#)
+1 NEW GMTSOCC,GMTSTIM,GMTSORD,GMTSLOC,GMTSICD,GMTSNAR,GMTSCPT
+2 if '$DATA(^GMT(142.1,GMTSJ,0))
QUIT
+3 SET GMTSORD=$ORDER(^GMT(142,"AE",GMTSJ,GMTSTYP,0))
+4 IF GMTSORD>0
Begin DoDot:1
+5 SET GMTSOCC=$SELECT($PIECE(^GMT(142.1,GMTSJ,0),"^",5)="Y":$PIECE($GET(^GMT(142,GMTSTYP,1,GMTSORD,0)),"^",3),1:"")
+6 SET GMTSTIM=$SELECT($PIECE(^GMT(142.1,GMTSJ,0),"^",3)="Y":$PIECE($GET(^GMT(142,GMTSTYP,1,GMTSORD,0)),"^",4),1:"")
+7 SET GMTSLOC=$SELECT($PIECE(^GMT(142.1,GMTSJ,0),"^",10)="Y":$PIECE($GET(^GMT(142,GMTSTYP,1,GMTSORD,0)),"^",6),1:"")
+8 SET GMTSICD=$SELECT($PIECE(^GMT(142.1,GMTSJ,0),"^",11)="Y":$PIECE($GET(^GMT(142,GMTSTYP,1,GMTSORD,0)),"^",7),1:"")
+9 SET GMTSNAR=$SELECT($PIECE(^GMT(142.1,GMTSJ,0),"^",12)="Y":$PIECE($GET(^GMT(142,GMTSTYP,1,GMTSORD,0)),"^",8),1:"")
+10 SET GMTSCPT=$SELECT($PIECE(^GMT(142.1,GMTSJ,0),"^",14)="Y":$PIECE($GET(^GMT(142,GMTSTYP,1,GMTSORD,0)),"^",9),1:"")
End DoDot:1
+11 IF '$TEST
Begin DoDot:1
+12 SET GMTSOCC=$SELECT($PIECE(^GMT(142.1,GMTSJ,0),"^",5)="Y":10,1:"")
+13 SET GMTSTIM=$SELECT($PIECE(^GMT(142.1,GMTSJ,0),"^",3)="Y":"1Y",1:"")
+14 SET GMTSLOC=$SELECT($PIECE(^GMT(142.1,GMTSJ,0),"^",10)="Y":"Y",1:"")
+15 SET GMTSICD=$SELECT($PIECE(^GMT(142.1,GMTSJ,0),"^",11)="Y":"L",1:"")
+16 SET GMTSNAR=$SELECT($PIECE(^GMT(142.1,GMTSJ,0),"^",12)="Y":"Y",1:"")
+17 SET GMTSCPT=$SELECT($PIECE(^GMT(142.1,GMTSJ,0),"^",12)="Y":"Y",1:"")
End DoDot:1
+18 ; Defaults for CPT Modifiers
+19 if $PIECE(^GMT(142.1,GMTSJ,0),"^",14)="Y"&(GMTSCPT="")
SET GMTSCPT="Y"
+20 if $$GET1^DID(142.1,14,,"LABEL")=""
SET GMTSCPT=""
+21 DO SG
+22 QUIT
SG ; Set GMTSEG(#) Component
+1 ; Disabled
+2 NEW GMTSDIAB
SET GMTSDIAB=$SELECT($PIECE(^GMT(142.1,GMTSJ,0),"^",6)="P":1,$PIECE(^(0),"^",6)="T":1,1:0)
IF (INCLUDE=0)
IF (GMTSDIAB=1)
QUIT
+3 ; Include
+4 SET GMTSEG(GMTSC)=(5*GMTSC)_"^"_GMTSJ_"^"_GMTSOCC_"^"_GMTSTIM_"^^"_GMTSLOC_"^"_GMTSICD_"^"_GMTSNAR_"^"_GMTSCPT
IF GMTSORD>0
DO SL
+5 QUIT
SL ; Set GMTSEG(#,#) Selection item
+1 NEW GMTSELT,GMTSITEM
+2 SET GMTSELT=0
FOR
SET GMTSELT=$ORDER(^GMT(142,GMTSTYP,1,+GMTSORD,1,GMTSELT))
if GMTSELT'>0
QUIT
Begin DoDot:1
+3 SET GMTSITEM=^(GMTSELT,0)
SET GMTSEG(GMTSC,GMTSELT)=GMTSITEM
End DoDot:1
+4 QUIT
AC ; Add Components to Ad Hoc Summary
+1 NEW GMTSISEQ,DA,DIE,DR,GMTSELC,GMTSDA,GMTSEL
+2 SET (GMTSISEQ,DA)=GMTSEQ*5
SET DIE="^GMT(142,"_GMTSIFN_",1,"
SET DA(1)=GMTSIFN
+3 SET DR=".01///"_DA
+4 if $LENGTH($PIECE(GMTSEG(GMTSEQ),"^",2))
SET DR=DR_";1///"_$PIECE(GMTSEG(GMTSEQ),"^",2)
+5 if $LENGTH($PIECE(GMTSEG(GMTSEQ),"^",3))
SET DR=DR_";2///"_$PIECE(GMTSEG(GMTSEQ),"^",3)
+6 if $LENGTH($PIECE(GMTSEG(GMTSEQ),"^",4))
SET DR=DR_";3///"_$PIECE(GMTSEG(GMTSEQ),"^",4)
+7 if $LENGTH($PIECE(GMTSEG(GMTSEQ),"^",5))
SET DR=DR_";5///"_$PIECE(GMTSEG(GMTSEQ),"^",5)
+8 if $LENGTH($PIECE(GMTSEG(GMTSEQ),"^",6))
SET DR=DR_";6///"_$PIECE(GMTSEG(GMTSEQ),"^",6)
+9 if $LENGTH($PIECE(GMTSEG(GMTSEQ),"^",7))
SET DR=DR_";7///"_$PIECE(GMTSEG(GMTSEQ),"^",7)
+10 if $LENGTH($PIECE(GMTSEG(GMTSEQ),"^",8))
SET DR=DR_";8///"_$PIECE(GMTSEG(GMTSEQ),"^",8)
+11 if $LENGTH($PIECE($GET(GMTSEG(GMTSEQ)),"^",9))>0&($LENGTH($$GET1^DID(142.1,14,,"LABEL"))>0)
SET DR=DR_";9///"_$PIECE(GMTSEG(GMTSEQ),"^",9)
+12 DO ^DIE
SET (GMTSELC,GMTSEL)=0
FOR
SET GMTSEL=$ORDER(GMTSEG(GMTSEQ,GMTSEL))
if 'GMTSEL
QUIT
DO AS
+13 IF GMTSELC>0
if '$DATA(^GMT(142,GMTSIFN,1,GMTSISEQ,1,0))
SET ^(0)="^142.14V^"_GMTSDA_"^"_GMTSELC
+14 QUIT
AS ; Add Selection Items to Ad Hoc Summary
+1 NEW DIE,DA,DR
+2 if '$DATA(^GMT(142,GMTSIFN,1,GMTSISEQ,1,0))
SET ^(0)="^142.14V^^"
+3 SET DIE="^GMT(142,"_GMTSIFN_",1,"_GMTSISEQ_",1,"
+4 SET DA(2)=GMTSIFN
SET DA(1)=GMTSISEQ
SET DA=GMTSEL
+5 SET DR=".01////"_"^S X=GMTSEG(GMTSEQ,GMTSEL)"
DO ^DIE
+6 SET GMTSDA=DA
SET GMTSELC=GMTSELC+1
+7 QUIT
+8 ;
+9 ; Misc
ENV(X) ; Environment check
+1 DO HOME^%ZIS
IF +($GET(DUZ))=0
DO BM(" User (DUZ) not defined")
DO M(" ")
QUIT 0
+2 IF '$LENGTH($$GET1^DIQ(200,(+($GET(DUZ))_","),.01))
DO BM(" Invalid User defined (DUZ)")
DO M(" ")
QUIT 0
+3 QUIT 1
BM(X) ; Blank Line with Message
+1 if $DATA(GMTSQT)
QUIT
if $DATA(XPDNM)
DO BMES^XPDUTL($GET(X))
if '$DATA(XPDNM)
WRITE !!,$GET(X)
QUIT
M(X) ; Message
+1 if $DATA(GMTSQT)
QUIT
if $DATA(XPDNM)
DO MES^XPDUTL($GET(X))
if '$DATA(XPDNM)
WRITE !,$GET(X)
QUIT
UP(X) ; Uppercase
+1 QUIT $TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
