GMTSULT ; SLC/KER - HS Type Lookup ; 01/06/2003
;;2.7;Health Summary;**30,35,29,47,58**;Oct 20, 1995
;
; External References
; DBIA 10060 ^VA(200
; DBIA 2056 $$GET1^DIQ (file 200)
; DBIA 2055 RECALL^DILFD
; DBIA 10103 $$NOW^XLFDT
; DBIA 10011 ^DIWP
; DBIA 10029 ^DIWW
; DBIA 10026 ^DIR
; DBIA 10016 ^DIM
; DBIA 10076 ^XUSEC(
; DBIA 1131 ^XMB("NETNAME")
; DBIA 2198 $$BROKER^XWBLIB
; DBIA 10006 ^DIC (file #142)
; DBIA 10096 ^%ZOSF("TEST")
;
N DIC,DTOUT,DUOUT,DIRUT D DICHK S DIC(0)="AEMQZ" S Y=$$TYPE^GMTSULT Q
EN ; Lookup (general)
Q:$G(DIC(0))["I"
K DTOUT,DUOUT N GMTSDICW,GMTSDICS,GMTSDIC,GMTSLGO,GMTSDIC0,GMTSDICB,GMTSDEF,GMTSWY,GMTSDISV,GMTSDICA,GMTSLERR,GMTSE,GMTSQ,GMTSX,DIR,DIRUT,DIROUT,GMTS
S GMTSE=$$ECHO D LD S U="^"
S (GMTSDEF,GMTSQ)=0,GMTSX=$G(X) S:$L(GMTSDIC0)&(GMTSDIC0'["A") GMTSQ=1 K Y
; Get X
; Ask the entry DIC(0)["A" (INPUT^GMTSULT5)
S:GMTSDIC0'["A"&($L(GMTSX)) X=GMTSX
K GMTSLERR S:GMTSDIC0["A"!('$L(GMTSX)) X=$$INPUT^GMTSULT5
I $D(DTOUT)!($D(DUOUT)) S Y=-1 S:$D(DTOUT) DTOUT=1 S:$D(DUOUT) DUOUT=1 Q
; Is X an IEN From Spacebar-Return
I +($$XIEN(X))>0 D Q
. K Y S Y=+($$XIEN(X))
. D Y^GMTSULT6(+Y),RD,CLR
. I ($G(GMTSDIC0)["Q"!($G(DIC(0))["Q")),+($G(Y))<0 W " ??"
; No Input or Error X="" or X["^" or '$D(X)
I $D(DTOUT)!($D(DUOUT))!($D(DIRUT))!($D(DIROUT))!($G(X)="")!($G(X)["^") D Q
. K Y W !!,?5 W:'$L($G(GMTSLERR)) "No Health Summary Type selected"
. W:$L($G(GMTSLERR)) GMTSLERR W ! S Y=-1 D RD,CLR
; Exact Match Required DIC(0)["X"
I GMTSDIC0["X",$L(X) D Q
. K Y S Y=-1,GMTSX=$$EM^GMTSULT2(X) D:+GMTSX>0 Y^GMTSULT6(+GMTSX) D RD,CLR
; Select
; Get Selection List
D LIST^GMTSULT2(X)
; Select from multiple entries
D:+($G(^TMP("GMTSULT",$J,0)))>1 MULTI^GMTSULT6
; Select from one entry
D:+($G(^TMP("GMTSULT",$J,0)))=1 ONE^GMTSULT6
S:'$D(Y)!(+($G(Y))'>0) Y=-1
;
; DLAYGO allowed
; Add entry
I $L(X),Y=-1,$G(GMTSDIC0)["L",+($G(GMTSLGO))=142 D
. Q:$L(X)<3!($L(X)>30) K Y(0) N DLAYGO,GMTSOD0,GMTSOX S GMTSOD0=DIC(0),GMTSOX=X
. N X,DA,DIC,DIK S DIC(0)="LM",(DIK,DIC)="^GMT(142,",DLAYGO=142,X=GMTSOX
. L +^GMT(142):2 W:'$T !," Can not add Health Summary Type, the file is in ",!," use by another user. Please try again later."
. D:$T ADD L -^GMT(142) S (GMTSDIC0,DIC(0))=GMTSOD0
D RD,CLR
Q
ADD ; Add Health Summary Type
N GMTSOK,GMTSU,GMTSD,GMTSM S GMTSM=$$MSG
S GMTSU=$$GET1^DIQ(200,+($G(DUZ)),.01) I '$L(GMTSU) D S Y=-1 Q
. W !!," Undefined/Invalid User",!
S GMTSU=+($$GET1^DIQ(200,+($G(DUZ)),9.2,"I")),GMTSD=$$NOW^XLFDT
I GMTSU>0&(GMTSU<GMTSD) D S Y=-1 Q
. W !!," Terminated Users may not add a Health Summary",!
S GMTSOK=+($$ASKA(X)) Q:'GMTSOK
S DA=$$DA I DA'>0!($D(^GMT(142,DA))) S Y=-1 Q
S $P(^GMT(142,DA,0),"^",1)=X,$P(^GMT(142,DA,0),"^",3)=+($G(DUZ))
D SI I '$D(^GMT(142,"B",$E(X,1,30),DA)) D KI K ^GMT(142,DA) S Y=-1 Q
S Y=DA_"^"_X_"^1"
Q
;
DA(X) ; Get IEN
S X=$O(^GMT(142,"4999999"),-1) F Q:'$D(^GMT(142,X)) S X=X+1
Q:X<5000000 X Q:X>5000999 X
S X=$O(^GMT(142,"!"),-1) F Q:'$D(^GMT(142,X)) S X=X+1
S:X>4999999&(X<6000000) X=6000000 Q X
ET(T) ; Error Text
I $D(DIEV0) D Q:+($G(DIQUIET))>0
. N I,E,A S I=+($G(DIERR)) S:I=0 I=1 S A=$G(GMTSM) S:A="" A="GMTSE" S E=$O(@(A_"(""GMTSERR"","_I_","" "")"),-1)+1,@(A_"(""GMTSERR"","_I_","_+E_")")=$G(T),@(A_"(""GMTSENV"")")=1
Q:$D(GMTSETQ) N %,X,Y,Z,I,DIW,DIWF,DIWL,DIWR,DIWT,DN S X=T,DIWL=6,DIWR=78,DIWF="W" D ^DIWP D:$D(^UTILITY($J)) ^DIWW W ?5 Q
BL ; Blank Line
Q:+($G(DIQUIET))>0 Q:$D(GMTSETQ) W !,?5 Q
MSG() ; Message
Q:$L($G(DIMSG)) $G(DIMSG) Q:$L($G(DIMSGA)) $G(DIMSGA) Q:$L($G(DIOUTAR)) $G(DIOUTAR) Q:$L($G(DIEFOUT)) $G(DIEFOUT) Q:$L($G(GMTSMS)) $G(GMTSMS)
Q "TMP"
ASKA(X) ; Ask if adding
N GMTSN,GMTSN,GMTSX S GMTSN=$G(X) Q:'$L(X) 0 Q:+($$DUP^GMTSULT7(X))>0 0
N DIR,DTOUT,DIROUT,DIRUT,DUOUT S GMTSX=+($$N)+1,GMTSX=$S(GMTSX=0:"",GMTSX=1:(GMTSX_"st"),GMTSX=2:(GMTSX_"nd"),GMTSX=3:(GMTSX_"rd"),1:(GMTSX_"th"))
S DIR(0)="YAO",DIR("A",1)="Are you adding '"_GMTSN_"' as ",DIR("A")=" a new HEALTH SUMMARY TYPE"_$S($L(GMTSX):(" (the "_GMTSX_")"),1:"")_"? ",DIR("B")="No"
W ! D ^DIR S:$D(DTOUT)!($D(DUOUT))!($D(DIRUT))!($D(DIROUT)) X="^" S:X["^" X="^" Q:X="^" 0
S X=+($G(Y)) S:+X'>0 X=0 Q X
N(X) ; Number of Types
N I S (I,X)=0 F S I=$O(^GMT(142,I)) Q:+I=0 S X=X+1
Q X
SI ; Set Indexes
D MS N GMTS,GMTSX,GMTSO,GMTSC S GMTS=+($G(DA)),GMTSO=$G(X) Q:GMTS'>0 Q:'$D(^GMT(142,GMTS,0)) Q:'$L(X) N X,DA
S DA=GMTS,GMTSX=0 F S GMTSX=$O(^TMP($J,142,.01,1,GMTSX)) Q:+GMTSX=0 D
. S X=$G(^TMP($J,142,.01,1,GMTSX,1)) D ^DIM Q:'$D(X) S GMTSC=X,X=GMTSO,DA=GMTS X GMTSC
D MK Q
KI ; Kill Indexes
D MS N GMTS,GMTSX,GMTSO,GMTSC S GMTS=+($G(DA)),GMTSO=$G(X) N X,DA
S DA=GMTS,GMTSX=0 F S GMTSX=$O(^TMP($J,142,.01,1,GMTSX)) Q:+GMTSX=0 D
. S X=$G(^TMP($J,142,.01,1,GMTSX,2)) D ^DIM Q:'$D(X)
. S GMTSC=X,X=GMTSO W !,GMTSC,?60,X,?70,DA
D MK Q
MS ; Merge Set
M ^TMP($J,142,.01,1)=@("^DD("_142_",.01,1)") Q
MK ; Merge Kill
K ^TMP($J,142,.01,1) Q
TYPE(GMTSI) ; Get Health Summary Type
; Needs DIC(0)
K Y S:$L($G(X)) X=$G(X)
D EN^GMTSULT S GMTSI=-1 S:+($G(Y))>0&($D(^GMT(142,+($G(Y)),0))) GMTSI=$G(Y) Q GMTSI
XIEN(X) ; Is X in a Y or `IEN format Quit +IEN
N GMTSX,GMTSL,GMTSI,GMTSN,GMTSY,GMTSOK
S GMTSX=$G(X),GMTSL=$E(GMTSX,1),GMTSI=$E(GMTSX,2,$L(GMTSX))
S GMTSOK=$$DICS^GMTSULT2($G(GMTSDICS),$P($G(^GMT(142,+GMTSI,0)),"^",1),+GMTSI) Q:'GMTSOK -1
I GMTSL="`",+GMTSI>0,+GMTSI=GMTSI,$D(^GMT(142,+GMTSI,0)),$L($P($G(^GMT(142,+GMTSI,0)),"^",1)) S X=GMTSI Q X
S GMTSI=$S($D(^GMT(142,+GMTSX,0)):+X,1:-1)
S GMTSN=$P($G(^GMT(142,+GMTSX,0)),"^",1)
I GMTSI=+GMTSX&(GMTSN=$P(GMTSX,"^",2)) S X=GMTSI Q X
Q 0
LD ; Load DIC Variables
D DICHK S (DIC,GMTSDIC)="^GMT(142,",GMTSDIC0="AEM" S:$L($G(DLAYGO)) GMTSLGO=$G(DLAYGO) S GMTSDICA="Select HEALTH SUMMARY TYPE: " K Y
S:$L($G(DIC("W"))) GMTSDICW=DIC("W") S:$L($G(DIC("S"))) GMTSDICS=DIC("S") S:$L($G(DIC("A"))) GMTSDICA=DIC("A") S:$L($G(DIC("B"))) GMTSDICB=DIC("B") S:$L($G(DIC(0))) GMTSDIC0=DIC(0)
Q
;
; Lookup Screens - DIC("S")="I +$$..
EOK(X) ; Edit OK
N OK,GMTS S X=+($G(X)),OK=1 S:'$D(^GMT(142,+X,0)) OK=0 S:$P($G(^GMT(142,+X,"VA")),U)=2 OK=0 S X=OK Q X
EST(X) ; Edit Health Summary Type (other than Adhoc)
N GMTSI,GMTSO,GMTS S X=+($G(X))
Q:'$L($P($G(^VA(200,+($G(DUZ)),0)),U)) 0 Q:+($G(DUZ(2)))=0 0
S GMTSI=$P($G(^GMT(142,+X,0)),U) Q:GMTSI="GMTS HS ADHOC OPTION"!(GMTSI="GMTS HS REMOTE ADHOC OPTION") 0
S GMTSI=+($P($G(^GMT(142,+X,"VA")),U)),GMTSO=$G(^XMB("NETNAME")) Q:GMTSI=2&'(GMTSO["ISC-SLC"&(+($G(DUZ(2)))=5000)) 0 Q:GMTSI=2&(GMTSO["ISC-SLC"&(+($G(DUZ(2)))=5000)) 1
S GMTSI=+($P($G(^GMT(142,+X,0)),U,3)) Q:GMTSI>0&(GMTSI=+($G(DUZ))) 1
S GMTSI=$P($G(^GMT(142,+X,0)),U,2),GMTSO=0 S:$L(GMTSI) GMTSO=$S(((+($G(DUZ))>0)&('$D(^XUSEC(GMTSI,+($G(DUZ)))))):1,1:0) Q:GMTSO=1 0
S GMTSI=+($P($G(^GMT(142,+X,0)),U,3)),GMTSO=$D(^GMT(142,+X,2,"B",+($G(DUZ)))) Q:GMTSI>0&(+($G(DUZ))>0)&(GMTSI'=+($G(DUZ)))&(+GMTSO>0) 1
S GMTSI=+($P($G(^GMT(142,+X,0)),U,3)) Q:GMTSI>0&(GMTSI'=+($G(DUZ))) 0
S GMTSI=$P($G(^GMT(142,+X,0)),U,2),GMTSO=0 S:$L(GMTSI) GMTSO=$S(((+($G(DUZ))>0)&($D(^XUSEC(GMTSI,+($G(DUZ)))))):1,1:0) Q:GMTSO=1 1
Q 1
HST(X) ; Health Summary Type
N GMTS S X=+($G(X)),GMTS=1 S:$P($G(^GMT(142,+X,0)),U)="GMTS HS ADHOC OPTION" GMTS=0 S:$P($G(^GMT(142,+X,0)),U)="GMTS HS REMOTE ADHOC OPTION" GMTS=0 S:+($G(^GMT(142,+X,"VA")))>0 GMTS=0
S X=GMTS Q X
DHST(X) ; Delete Health Summary Type
N GMTS S X=+($G(X)),GMTS=1
S:$P($G(^GMT(142,+X,0)),U)="GMTS HS ADHOC OPTION" GMTS=0 S:$P($G(^GMT(142,+X,0)),U)="GMTS HS REMOTE ADHOC OPTION" GMTS=0
S:+($G(^GMT(142,+X,"VA")))>0 GMTS=0 S:$D(^GMT(142.5,"AC",+X)) GMTS=0
S X=GMTS Q X
AHST(X) ; Add Health Summary Type
N GMTS S X=+($G(X)),GMTS=1 S:$P($G(^GMT(142,+X,0)),U)="GMTS HS ADHOC OPTION" GMTS=0 S:$P($G(^GMT(142,+X,0)),U)="GMTS HS REMOTE ADHOC OPTION" GMTS=0
S:((+X>4999999)&(+X<6000000)) GMTS=0 S:+($G(^GMT(142,+X,"VA")))>0 GMTS=0
S X=GMTS Q X
ADH(X) ; Adhoc
N GMTS S X=+($G(X)),GMTS=1 S:$P($G(^GMT(142,+X,0)),U)'="GMTS HS ADHOC OPTION" GMTS=0 S X=GMTS Q X
REM(X) ; Remote Adhoc
N GMTS S X=+($G(X)),GMTS=1 S:$P($G(^GMT(142,+X,0)),U)'="GMTS HS REMOTE ADHOC OPTION" GMTS=0 S X=GMTS Q X
Q
;
DICHK ; Check DIC variables
K DIC("DR"),DIC("P"),DIC("V"),DINUM,DTOUT,DUOUT
S:'$L($G(DIC(0))) DIC(0)="AEMZB" S:'$L($G(DIC)) DIC="^GMT(142,"
I +($G(GMTSE))=0 F Q:DIC(0)'["E" S DIC(0)=$P(DIC(0),"E",1)_$P(DIC(0),"E",2)
S:'$L($G(DIC("A"))) DIC("A")="Select HEALTH SUMMARY TYPE: "
Q
RD ; Restore DIC Variables
S:$L($G(GMTSDIC)) DIC=GMTSDIC S:$L($G(GMTSDICS)) DIC("S")=GMTSDICS
S:$L($G(GMTSDICW)) DIC("W")=GMTSDICW S:$L($G(GMTSDICA)) DIC("A")=GMTSDICA
S:$L($G(GMTSDICB)) DIC("B")=GMTSDICB S:$L($G(GMTSDIC0)) DIC(0)=GMTSDIC0
I $L($G(X)),X["`" D
. N GMTSI,GMTSL S GMTSL=$E(X,1),GMTSI=$E(X,2,$L(X))
. I GMTSL="`",+GMTSI>0,$D(^GMT(142,+GMTSI,0)),$L($P($G(^GMT(142,+GMTSI,0)),"^",1)) S X=$P($G(^GMT(142,+GMTSI,0)),"^",1)
K GMTSDICS,GMTSDIC,GMTSDIC0,GMTSDICB,GMTS,GMTSDISV,GMTSDICA Q
ECHO(X) ; Echo Results (writes/reads)
S X=$$ROK("XWBLIB") Q:'X 1 S X=$$BROKER^XWBLIB Q:X 0 Q 1
SDISV(Y) ; Set DISV (IEN)
Q:+($G(DUZ))=0!(+($G(Y))=0)
D RECALL^DILFD(142,+($G(Y))_",",+($G(DUZ))) Q
RDISV(X) ; Read DISV
Q:+($G(DUZ))=0 ""
N DIC,Y S DIC=142,DIC(0)="Z",X=" " D ^DIC S X=$S(+Y>0:Y,1:"") Q X
ROK(X) ; Routine OK
S X=$G(X) Q:'$L(X) 0 Q:$L(X)>8 0 X ^%ZOSF("TEST") Q:$T 1 Q 0
CLR ; Kill ^TMP("GMTS*
K ^TMP("GMTSULT",$J),^TMP("GMTSULT2",$J) Q
CLEAN ; Kill ^TMP("GMTSULT2")
K ^TMP("GMTSULT2",$J) Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMTSULT 9755 printed Oct 16, 2024@18:01:15 Page 2
GMTSULT ; SLC/KER - HS Type Lookup ; 01/06/2003
+1 ;;2.7;Health Summary;**30,35,29,47,58**;Oct 20, 1995
+2 ;
+3 ; External References
+4 ; DBIA 10060 ^VA(200
+5 ; DBIA 2056 $$GET1^DIQ (file 200)
+6 ; DBIA 2055 RECALL^DILFD
+7 ; DBIA 10103 $$NOW^XLFDT
+8 ; DBIA 10011 ^DIWP
+9 ; DBIA 10029 ^DIWW
+10 ; DBIA 10026 ^DIR
+11 ; DBIA 10016 ^DIM
+12 ; DBIA 10076 ^XUSEC(
+13 ; DBIA 1131 ^XMB("NETNAME")
+14 ; DBIA 2198 $$BROKER^XWBLIB
+15 ; DBIA 10006 ^DIC (file #142)
+16 ; DBIA 10096 ^%ZOSF("TEST")
+17 ;
+18 NEW DIC,DTOUT,DUOUT,DIRUT
DO DICHK
SET DIC(0)="AEMQZ"
SET Y=$$TYPE^GMTSULT
QUIT
EN ; Lookup (general)
+1 if $GET(DIC(0))["I"
QUIT
+2 KILL DTOUT,DUOUT
NEW GMTSDICW,GMTSDICS,GMTSDIC,GMTSLGO,GMTSDIC0,GMTSDICB,GMTSDEF,GMTSWY,GMTSDISV,GMTSDICA,GMTSLERR,GMTSE,GMTSQ,GMTSX,DIR,DIRUT,DIROUT,GMTS
+3 SET GMTSE=$$ECHO
DO LD
SET U="^"
+4 SET (GMTSDEF,GMTSQ)=0
SET GMTSX=$GET(X)
if $LENGTH(GMTSDIC0)&(GMTSDIC0'["A")
SET GMTSQ=1
KILL Y
+5 ; Get X
+6 ; Ask the entry DIC(0)["A" (INPUT^GMTSULT5)
+7 if GMTSDIC0'["A"&($LENGTH(GMTSX))
SET X=GMTSX
+8 KILL GMTSLERR
if GMTSDIC0["A"!('$LENGTH(GMTSX))
SET X=$$INPUT^GMTSULT5
+9 IF $DATA(DTOUT)!($DATA(DUOUT))
SET Y=-1
if $DATA(DTOUT)
SET DTOUT=1
if $DATA(DUOUT)
SET DUOUT=1
QUIT
+10 ; Is X an IEN From Spacebar-Return
+11 IF +($$XIEN(X))>0
Begin DoDot:1
+12 KILL Y
SET Y=+($$XIEN(X))
+13 DO Y^GMTSULT6(+Y)
DO RD
DO CLR
+14 IF ($GET(GMTSDIC0)["Q"!($GET(DIC(0))["Q"))
IF +($GET(Y))<0
WRITE " ??"
End DoDot:1
QUIT
+15 ; No Input or Error X="" or X["^" or '$D(X)
+16 IF $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIRUT))!($DATA(DIROUT))!($GET(X)="")!($GET(X)["^")
Begin DoDot:1
+17 KILL Y
WRITE !!,?5
if '$LENGTH($GET(GMTSLERR))
WRITE "No Health Summary Type selected"
+18 if $LENGTH($GET(GMTSLERR))
WRITE GMTSLERR
WRITE !
SET Y=-1
DO RD
DO CLR
End DoDot:1
QUIT
+19 ; Exact Match Required DIC(0)["X"
+20 IF GMTSDIC0["X"
IF $LENGTH(X)
Begin DoDot:1
+21 KILL Y
SET Y=-1
SET GMTSX=$$EM^GMTSULT2(X)
if +GMTSX>0
DO Y^GMTSULT6(+GMTSX)
DO RD
DO CLR
End DoDot:1
QUIT
+22 ; Select
+23 ; Get Selection List
+24 DO LIST^GMTSULT2(X)
+25 ; Select from multiple entries
+26 if +($GET(^TMP("GMTSULT",$JOB,0)))>1
DO MULTI^GMTSULT6
+27 ; Select from one entry
+28 if +($GET(^TMP("GMTSULT",$JOB,0)))=1
DO ONE^GMTSULT6
+29 if '$DATA(Y)!(+($GET(Y))'>0)
SET Y=-1
+30 ;
+31 ; DLAYGO allowed
+32 ; Add entry
+33 IF $LENGTH(X)
IF Y=-1
IF $GET(GMTSDIC0)["L"
IF +($GET(GMTSLGO))=142
Begin DoDot:1
+34 if $LENGTH(X)<3!($LENGTH(X)>30)
QUIT
KILL Y(0)
NEW DLAYGO,GMTSOD0,GMTSOX
SET GMTSOD0=DIC(0)
SET GMTSOX=X
+35 NEW X,DA,DIC,DIK
SET DIC(0)="LM"
SET (DIK,DIC)="^GMT(142,"
SET DLAYGO=142
SET X=GMTSOX
+36 LOCK +^GMT(142):2
if '$TEST
WRITE !," Can not add Health Summary Type, the file is in ",!," use by another user. Please try again later."
+37 if $TEST
DO ADD
LOCK -^GMT(142)
SET (GMTSDIC0,DIC(0))=GMTSOD0
End DoDot:1
+38 DO RD
DO CLR
+39 QUIT
ADD ; Add Health Summary Type
+1 NEW GMTSOK,GMTSU,GMTSD,GMTSM
SET GMTSM=$$MSG
+2 SET GMTSU=$$GET1^DIQ(200,+($GET(DUZ)),.01)
IF '$LENGTH(GMTSU)
Begin DoDot:1
+3 WRITE !!," Undefined/Invalid User",!
End DoDot:1
SET Y=-1
QUIT
+4 SET GMTSU=+($$GET1^DIQ(200,+($GET(DUZ)),9.2,"I"))
SET GMTSD=$$NOW^XLFDT
+5 IF GMTSU>0&(GMTSU<GMTSD)
Begin DoDot:1
+6 WRITE !!," Terminated Users may not add a Health Summary",!
End DoDot:1
SET Y=-1
QUIT
+7 SET GMTSOK=+($$ASKA(X))
if 'GMTSOK
QUIT
+8 SET DA=$$DA
IF DA'>0!($DATA(^GMT(142,DA)))
SET Y=-1
QUIT
+9 SET $PIECE(^GMT(142,DA,0),"^",1)=X
SET $PIECE(^GMT(142,DA,0),"^",3)=+($GET(DUZ))
+10 DO SI
IF '$DATA(^GMT(142,"B",$EXTRACT(X,1,30),DA))
DO KI
KILL ^GMT(142,DA)
SET Y=-1
QUIT
+11 SET Y=DA_"^"_X_"^1"
+12 QUIT
+13 ;
DA(X) ; Get IEN
+1 SET X=$ORDER(^GMT(142,"4999999"),-1)
FOR
if '$DATA(^GMT(142,X))
QUIT
SET X=X+1
+2 if X<5000000
QUIT X
if X>5000999
QUIT X
+3 SET X=$ORDER(^GMT(142,"!"),-1)
FOR
if '$DATA(^GMT(142,X))
QUIT
SET X=X+1
+4 if X>4999999&(X<6000000)
SET X=6000000
QUIT X
ET(T) ; Error Text
+1 IF $DATA(DIEV0)
Begin DoDot:1
+2 NEW I,E,A
SET I=+($GET(DIERR))
if I=0
SET I=1
SET A=$GET(GMTSM)
if A=""
SET A="GMTSE"
SET E=$ORDER(@(A_"(""GMTSERR"","_I_","" "")"),-1)+1
SET @(A_"(""GMTSERR"","_I_","_+E_")")=$GET(T)
SET @(A_"(""GMTSENV"")")=1
End DoDot:1
if +($GET(DIQUIET))>0
QUIT
+3 if $DATA(GMTSETQ)
QUIT
NEW %,X,Y,Z,I,DIW,DIWF,DIWL,DIWR,DIWT,DN
SET X=T
SET DIWL=6
SET DIWR=78
SET DIWF="W"
DO ^DIWP
if $DATA(^UTILITY($JOB))
DO ^DIWW
WRITE ?5
QUIT
BL ; Blank Line
+1 if +($GET(DIQUIET))>0
QUIT
if $DATA(GMTSETQ)
QUIT
WRITE !,?5
QUIT
MSG() ; Message
+1 if $LENGTH($GET(DIMSG))
QUIT $GET(DIMSG)
if $LENGTH($GET(DIMSGA))
QUIT $GET(DIMSGA)
if $LENGTH($GET(DIOUTAR))
QUIT $GET(DIOUTAR)
if $LENGTH($GET(DIEFOUT))
QUIT $GET(DIEFOUT)
if $LENGTH($GET(GMTSMS))
QUIT $GET(GMTSMS)
+2 QUIT "TMP"
ASKA(X) ; Ask if adding
+1 NEW GMTSN,GMTSN,GMTSX
SET GMTSN=$GET(X)
if '$LENGTH(X)
QUIT 0
if +($$DUP^GMTSULT7(X))>0
QUIT 0
+2 NEW DIR,DTOUT,DIROUT,DIRUT,DUOUT
SET GMTSX=+($$N)+1
SET GMTSX=$SELECT(GMTSX=0:"",GMTSX=1:(GMTSX_"st"),GMTSX=2:(GMTSX_"nd"),GMTSX=3:(GMTSX_"rd"),1:(GMTSX_"th"))
+3 SET DIR(0)="YAO"
SET DIR("A",1)="Are you adding '"_GMTSN_"' as "
SET DIR("A")=" a new HEALTH SUMMARY TYPE"_$SELECT($LENGTH(GMTSX):(" (the "_GMTSX_")"),1:"")_"? "
SET DIR("B")="No"
+4 WRITE !
DO ^DIR
if $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIRUT))!($DATA(DIROUT))
SET X="^"
if X["^"
SET X="^"
if X="^"
QUIT 0
+5 SET X=+($GET(Y))
if +X'>0
SET X=0
QUIT X
N(X) ; Number of Types
+1 NEW I
SET (I,X)=0
FOR
SET I=$ORDER(^GMT(142,I))
if +I=0
QUIT
SET X=X+1
+2 QUIT X
SI ; Set Indexes
+1 DO MS
NEW GMTS,GMTSX,GMTSO,GMTSC
SET GMTS=+($GET(DA))
SET GMTSO=$GET(X)
if GMTS'>0
QUIT
if '$DATA(^GMT(142,GMTS,0))
QUIT
if '$LENGTH(X)
QUIT
NEW X,DA
+2 SET DA=GMTS
SET GMTSX=0
FOR
SET GMTSX=$ORDER(^TMP($JOB,142,.01,1,GMTSX))
if +GMTSX=0
QUIT
Begin DoDot:1
+3 SET X=$GET(^TMP($JOB,142,.01,1,GMTSX,1))
DO ^DIM
if '$DATA(X)
QUIT
SET GMTSC=X
SET X=GMTSO
SET DA=GMTS
XECUTE GMTSC
End DoDot:1
+4 DO MK
QUIT
KI ; Kill Indexes
+1 DO MS
NEW GMTS,GMTSX,GMTSO,GMTSC
SET GMTS=+($GET(DA))
SET GMTSO=$GET(X)
NEW X,DA
+2 SET DA=GMTS
SET GMTSX=0
FOR
SET GMTSX=$ORDER(^TMP($JOB,142,.01,1,GMTSX))
if +GMTSX=0
QUIT
Begin DoDot:1
+3 SET X=$GET(^TMP($JOB,142,.01,1,GMTSX,2))
DO ^DIM
if '$DATA(X)
QUIT
+4 SET GMTSC=X
SET X=GMTSO
WRITE !,GMTSC,?60,X,?70,DA
End DoDot:1
+5 DO MK
QUIT
MS ; Merge Set
+1 MERGE ^TMP($JOB,142,.01,1)=@("^DD("_142_",.01,1)")
QUIT
MK ; Merge Kill
+1 KILL ^TMP($JOB,142,.01,1)
QUIT
TYPE(GMTSI) ; Get Health Summary Type
+1 ; Needs DIC(0)
+2 KILL Y
if $LENGTH($GET(X))
SET X=$GET(X)
+3 DO EN^GMTSULT
SET GMTSI=-1
if +($GET(Y))>0&($DATA(^GMT(142,+($GET(Y)),0)))
SET GMTSI=$GET(Y)
QUIT GMTSI
XIEN(X) ; Is X in a Y or `IEN format Quit +IEN
+1 NEW GMTSX,GMTSL,GMTSI,GMTSN,GMTSY,GMTSOK
+2 SET GMTSX=$GET(X)
SET GMTSL=$EXTRACT(GMTSX,1)
SET GMTSI=$EXTRACT(GMTSX,2,$LENGTH(GMTSX))
+3 SET GMTSOK=$$DICS^GMTSULT2($GET(GMTSDICS),$PIECE($GET(^GMT(142,+GMTSI,0)),"^",1),+GMTSI)
if 'GMTSOK
QUIT -1
+4 IF GMTSL="`"
IF +GMTSI>0
IF +GMTSI=GMTSI
IF $DATA(^GMT(142,+GMTSI,0))
IF $LENGTH($PIECE($GET(^GMT(142,+GMTSI,0)),"^",1))
SET X=GMTSI
QUIT X
+5 SET GMTSI=$SELECT($DATA(^GMT(142,+GMTSX,0)):+X,1:-1)
+6 SET GMTSN=$PIECE($GET(^GMT(142,+GMTSX,0)),"^",1)
+7 IF GMTSI=+GMTSX&(GMTSN=$PIECE(GMTSX,"^",2))
SET X=GMTSI
QUIT X
+8 QUIT 0
LD ; Load DIC Variables
+1 DO DICHK
SET (DIC,GMTSDIC)="^GMT(142,"
SET GMTSDIC0="AEM"
if $LENGTH($GET(DLAYGO))
SET GMTSLGO=$GET(DLAYGO)
SET GMTSDICA="Select HEALTH SUMMARY TYPE: "
KILL Y
+2 if $LENGTH($GET(DIC("W")))
SET GMTSDICW=DIC("W")
if $LENGTH($GET(DIC("S")))
SET GMTSDICS=DIC("S")
if $LENGTH($GET(DIC("A")))
SET GMTSDICA=DIC("A")
if $LENGTH($GET(DIC("B")))
SET GMTSDICB=DIC("B")
if $LENGTH($GET(DIC(0)))
SET GMTSDIC0=DIC(0)
+3 QUIT
+4 ;
+5 ; Lookup Screens - DIC("S")="I +$$..
EOK(X) ; Edit OK
+1 NEW OK,GMTS
SET X=+($GET(X))
SET OK=1
if '$DATA(^GMT(142,+X,0))
SET OK=0
if $PIECE($GET(^GMT(142,+X,"VA")),U)=2
SET OK=0
SET X=OK
QUIT X
EST(X) ; Edit Health Summary Type (other than Adhoc)
+1 NEW GMTSI,GMTSO,GMTS
SET X=+($GET(X))
+2 if '$LENGTH($PIECE($GET(^VA(200,+($GET(DUZ)),0)),U))
QUIT 0
if +($GET(DUZ(2)))=0
QUIT 0
+3 SET GMTSI=$PIECE($GET(^GMT(142,+X,0)),U)
if GMTSI="GMTS HS ADHOC OPTION"!(GMTSI="GMTS HS REMOTE ADHOC OPTION")
QUIT 0
+4 SET GMTSI=+($PIECE($GET(^GMT(142,+X,"VA")),U))
SET GMTSO=$GET(^XMB("NETNAME"))
if GMTSI=2&'(GMTSO["ISC-SLC"&(+($GET(DUZ(2)))=5000))
QUIT 0
if GMTSI=2&(GMTSO["ISC-SLC"&(+($GET(DUZ(2)))=5000))
QUIT 1
+5 SET GMTSI=+($PIECE($GET(^GMT(142,+X,0)),U,3))
if GMTSI>0&(GMTSI=+($GET(DUZ)))
QUIT 1
+6 SET GMTSI=$PIECE($GET(^GMT(142,+X,0)),U,2)
SET GMTSO=0
if $LENGTH(GMTSI)
SET GMTSO=$SELECT(((+($GET(DUZ))>0)&('$DATA(^XUSEC(GMTSI,+($GET(DUZ)))))):1,1:0)
if GMTSO=1
QUIT 0
+7 SET GMTSI=+($PIECE($GET(^GMT(142,+X,0)),U,3))
SET GMTSO=$DATA(^GMT(142,+X,2,"B",+($GET(DUZ))))
if GMTSI>0&(+($GET(DUZ))>0)&(GMTSI'=+($GET(DUZ)))&(+GMTSO>0)
QUIT 1
+8 SET GMTSI=+($PIECE($GET(^GMT(142,+X,0)),U,3))
if GMTSI>0&(GMTSI'=+($GET(DUZ)))
QUIT 0
+9 SET GMTSI=$PIECE($GET(^GMT(142,+X,0)),U,2)
SET GMTSO=0
if $LENGTH(GMTSI)
SET GMTSO=$SELECT(((+($GET(DUZ))>0)&($DATA(^XUSEC(GMTSI,+($GET(DUZ)))))):1,1:0)
if GMTSO=1
QUIT 1
+10 QUIT 1
HST(X) ; Health Summary Type
+1 NEW GMTS
SET X=+($GET(X))
SET GMTS=1
if $PIECE($GET(^GMT(142,+X,0)),U)="GMTS HS ADHOC OPTION"
SET GMTS=0
if $PIECE($GET(^GMT(142,+X,0)),U)="GMTS HS REMOTE ADHOC OPTION"
SET GMTS=0
if +($GET(^GMT(142,+X,"VA")))>0
SET GMTS=0
+2 SET X=GMTS
QUIT X
DHST(X) ; Delete Health Summary Type
+1 NEW GMTS
SET X=+($GET(X))
SET GMTS=1
+2 if $PIECE($GET(^GMT(142,+X,0)),U)="GMTS HS ADHOC OPTION"
SET GMTS=0
if $PIECE($GET(^GMT(142,+X,0)),U)="GMTS HS REMOTE ADHOC OPTION"
SET GMTS=0
+3 if +($GET(^GMT(142,+X,"VA")))>0
SET GMTS=0
if $DATA(^GMT(142.5,"AC",+X))
SET GMTS=0
+4 SET X=GMTS
QUIT X
AHST(X) ; Add Health Summary Type
+1 NEW GMTS
SET X=+($GET(X))
SET GMTS=1
if $PIECE($GET(^GMT(142,+X,0)),U)="GMTS HS ADHOC OPTION"
SET GMTS=0
if $PIECE($GET(^GMT(142,+X,0)),U)="GMTS HS REMOTE ADHOC OPTION"
SET GMTS=0
+2 if ((+X>4999999)&(+X<6000000))
SET GMTS=0
if +($GET(^GMT(142,+X,"VA")))>0
SET GMTS=0
+3 SET X=GMTS
QUIT X
ADH(X) ; Adhoc
+1 NEW GMTS
SET X=+($GET(X))
SET GMTS=1
if $PIECE($GET(^GMT(142,+X,0)),U)'="GMTS HS ADHOC OPTION"
SET GMTS=0
SET X=GMTS
QUIT X
REM(X) ; Remote Adhoc
+1 NEW GMTS
SET X=+($GET(X))
SET GMTS=1
if $PIECE($GET(^GMT(142,+X,0)),U)'="GMTS HS REMOTE ADHOC OPTION"
SET GMTS=0
SET X=GMTS
QUIT X
+2 QUIT
+3 ;
DICHK ; Check DIC variables
+1 KILL DIC("DR"),DIC("P"),DIC("V"),DINUM,DTOUT,DUOUT
+2 if '$LENGTH($GET(DIC(0)))
SET DIC(0)="AEMZB"
if '$LENGTH($GET(DIC))
SET DIC="^GMT(142,"
+3 IF +($GET(GMTSE))=0
FOR
if DIC(0)'["E"
QUIT
SET DIC(0)=$PIECE(DIC(0),"E",1)_$PIECE(DIC(0),"E",2)
+4 if '$LENGTH($GET(DIC("A")))
SET DIC("A")="Select HEALTH SUMMARY TYPE: "
+5 QUIT
RD ; Restore DIC Variables
+1 if $LENGTH($GET(GMTSDIC))
SET DIC=GMTSDIC
if $LENGTH($GET(GMTSDICS))
SET DIC("S")=GMTSDICS
+2 if $LENGTH($GET(GMTSDICW))
SET DIC("W")=GMTSDICW
if $LENGTH($GET(GMTSDICA))
SET DIC("A")=GMTSDICA
+3 if $LENGTH($GET(GMTSDICB))
SET DIC("B")=GMTSDICB
if $LENGTH($GET(GMTSDIC0))
SET DIC(0)=GMTSDIC0
+4 IF $LENGTH($GET(X))
IF X["`"
Begin DoDot:1
+5 NEW GMTSI,GMTSL
SET GMTSL=$EXTRACT(X,1)
SET GMTSI=$EXTRACT(X,2,$LENGTH(X))
+6 IF GMTSL="`"
IF +GMTSI>0
IF $DATA(^GMT(142,+GMTSI,0))
IF $LENGTH($PIECE($GET(^GMT(142,+GMTSI,0)),"^",1))
SET X=$PIECE($GET(^GMT(142,+GMTSI,0)),"^",1)
End DoDot:1
+7 KILL GMTSDICS,GMTSDIC,GMTSDIC0,GMTSDICB,GMTS,GMTSDISV,GMTSDICA
QUIT
ECHO(X) ; Echo Results (writes/reads)
+1 SET X=$$ROK("XWBLIB")
if 'X
QUIT 1
SET X=$$BROKER^XWBLIB
if X
QUIT 0
QUIT 1
SDISV(Y) ; Set DISV (IEN)
+1 if +($GET(DUZ))=0!(+($GET(Y))=0)
QUIT
+2 DO RECALL^DILFD(142,+($GET(Y))_",",+($GET(DUZ)))
QUIT
RDISV(X) ; Read DISV
+1 if +($GET(DUZ))=0
QUIT ""
+2 NEW DIC,Y
SET DIC=142
SET DIC(0)="Z"
SET X=" "
DO ^DIC
SET X=$SELECT(+Y>0:Y,1:"")
QUIT X
ROK(X) ; Routine OK
+1 SET X=$GET(X)
if '$LENGTH(X)
QUIT 0
if $LENGTH(X)>8
QUIT 0
XECUTE ^%ZOSF("TEST")
if $TEST
QUIT 1
QUIT 0
CLR ; Kill ^TMP("GMTS*
+1 KILL ^TMP("GMTSULT",$JOB),^TMP("GMTSULT2",$JOB)
QUIT
CLEAN ; Kill ^TMP("GMTSULT2")
+1 KILL ^TMP("GMTSULT2",$JOB)
QUIT
