- GMTSOBL ; SLC/KER - HS Object - Lookup ; 06/24/2009
- ;;2.7;Health Summary;**58,89**;Oct 20, 1995;Build 61
- ;
- ; External References
- ; DBIA 10006 ^DIC (file #142.5)
- ; DBIA 10018 ^DIE (file #142 and 142.5)
- ; DBIA 10013 ^DIK (file #142 and 142.5)
- ; DBIA 10026 ^DIR
- ; DBIA 10010 EN1^DIP
- ; DBIA 10076 ^XUSEC(
- ; DBIA 10076 ^XUSEC("GMTSMGR")
- ; DBIA 10112 $$SITE^VASITE
- ; DBIA 10103 $$NOW^XLFDT
- ;
- Q
- OBJ(X) ; Lookup HS Object
- Q:+($G(DUZ))'>0 -1 N DIR,DIC,DTOUT,DUOUT,DIROUT,DLAYGO,DA,D,D0,D1,DI,DQ,Y S U="^"
- S DIC="^GMT(142.5,",DIC(0)="AEMQ",DIC("A")=" Select HEALTH SUMMARY OBJECT: " K DLAYGO D ^DIC
- S:+($$ABT)>0 Y=-1 S X=+($G(Y))
- Q X
- HSO(X) ; Lookup HS Object (by Known Name)
- I +($G(DUZ))'>0 S GMTSQ=1 Q -1
- N GMTSOWN,GMTSDICS,GMTSNAM,GMTSIEN,GMTSNEW
- N DIR,DIC,DTOUT,DUOUT,DIROUT,DLAYGO,DINUM,DA,D,D0,D1,DI,DQ,Y,GMTSL,GMTSH,GMTSS,GMTSTA S U="^"
- S GMTSNAM=$G(X),GMTSNEW=0,GMTSOWN="",GMTSQ=0 I '$L(GMTSNAM) S GMTSQ=1 Q -1
- S X=GMTSNAM I '$L(X) S X=-1,GMTSQ=1 Q X
- S DIC="^GMT(142.5,",DIC(0)="XML",DLAYGO=142.5 S:$L($G(GMTSDICS)) DIC("S")=$G(GMTSDICS)
- S GMTSTA=+($P($$SITE^VASITE,"^",3)) I +GMTSTA'>0 S X=-1,GMTSQ=1 Q X
- S GMTSS=+($G(GMTSTA)) S:$D(GMTSDEV) GMTSS=5000 S GMTSL=GMTSS_"0000"
- S GMTSH=GMTSS_"9999" S GMTSH=($O(^GMT(142.5,+GMTSH),-1)+1)
- S:+GMTSH<+GMTSL GMTSH=+GMTSS_"0001" S:+GMTSH>0 DINUM=+GMTSH
- D ^DIC I +($$ABT)>0 S GMTSQ=1,X=-1 Q X
- S GMTSNEW=+($P(Y,"^",3))
- I +Y'>0 S X=-1 Q X
- S X=+($G(Y))_"^"_$P($G(^GMT(142.5,+($G(Y)),0)),"^",1) S:+GMTSNEW>0 $P(X,"^",3)=+GMTSNEW
- W:GMTSNEW>0 !,"Creating Health Summary Object '",GMTSNAM,"'"
- S:+GMTSNEW>0 X=$$EE(Y) I +($G(GMTSQ))>1 S X=-1 Q
- S:+X'>0 X=-1 I +($G(GMTSQ))=0 D
- . D:+GMTSNEW>0&(+X>0) NEW^GMTSOBL2(+X)
- . D:+GMTSNEW'>0&(+X>0) MOD^GMTSOBL2(+X)
- Q X
- LK(X) ; Lookup HS Object (Learn as you go)
- Q:+($G(DUZ))'>0 -1 N GMTSDICS,GMTSB S GMTSDICS=$G(DIC("S")) K DIC("S") S GMTSDICS=$$DIM^GMTSOBL2(GMTSDICS),GMTSB=$P($$B^GMTSOBL2,"^",2)
- N DIR,DIC,DTOUT,DUOUT,DIROUT,DLAYGO,DA,D,D0,D1,DI,DQ,GMTSNAM,GMTSTA
- N GMTS,GMTSTD,GMTSOBJ,GMTSOBN,GMTSDT,GMTSNEW,GMTSDEF,GMTSDA,Y,X1 S U="^"
- S GMTSNEW=0,GMTSTA=+($P($$SITE^VASITE,"^",3)) Q:+GMTSTA=0 -1
- S DIR(0)="FAO^1:30^S:X="" "" (X,X1)=$G(GMTSB) K:$L(X)<3&(X'="" "") X"
- S DIR("A")=" Select HEALTH SUMMARY OBJECT: ",(DIR("?"),DIR("??"))="^D NAH^GMTSOBL2"
- D ^DIR Q:'$L(Y)!(Y["^") -1 S GMTSNAM=Y
- S DIC="^GMT(142.5,",DIC(0)="EM" S:$L($G(GMTSDICS)) DIC("S")=$G(GMTSDICS)
- W ! D ^DIC
- I +($$ABT)>0 S GMTSQ=1,Y=-1,X=-1 Q X
- I +Y'>0 D Q:+Y'>0 -1
- . N X,DIC,DINUM,GMTSL,GMTSH,GMTSS S GMTSS=+($G(GMTSTA)) S:$D(GMTSDEV) GMTSS=5000
- . S X=$G(GMTSNAM) Q:'$L(X) S GMTSL=GMTSS_"0000"
- . S GMTSH=GMTSS_"9999",GMTSH=($O(^GMT(142.5,+GMTSH),-1)+1)
- . S:+GMTSH<+GMTSL GMTSH=+GMTSS_"0001" S:+GMTSH>0 DINUM=+GMTSH
- . S DIC="^GMT(142.5,",DIC(0)="EML",DLAYGO=142.5
- . S:$L($G(GMTSDICS)) DIC("S")=$G(GMTSDICS) D ^DIC
- . S GMTSNEW=+($P(Y,"^",3))
- . I +($$ABT)>0 S GMTSQ=1
- I +($G(GMTSQ))>0 S Y=-1,X=-1 Q X
- S X=+($G(Y))_"^"_$P($G(^GMT(142.5,+($G(Y)),0)),"^",1)
- S:+GMTSNEW>0 $P(X,"^",3)=+GMTSNEW S X=$$EE(Y) S:+X'>0 X=-1 I +X'>0 S GMTSQ=1,Y=-1,X=-1 Q X
- I +($G(GMTSQ))=0 D:+GMTSNEW>0&(+X>0) NEW^GMTSOBL2(+X) D:+GMTSNEW'>0&(+X>0) MOD^GMTSOBL2(+X)
- Q X
- EE(X) ; Enter/Edit
- N GMTSOBJ,DA,GMTSY,GMTSNAM,GMTSTYP,GMTSDICS,GMTSDICA,GMTSDICB,Y S Y=$G(X) S (GMTSOBJ,DA,X)=+($G(Y)),GMTSY=$G(Y)
- S GMTSTYP=$P($G(^GMT(142.5,+DA,0)),"^",3),GMTSTYP=$P($G(^GMT(142,+GMTSTYP,0)),"^",1)
- S GMTSNEW=$S(+($P($G(Y),U,3))>0:1,1:0) I GMTSNEW>0 D
- . S $P(^GMT(142.5,+DA,0),"^",20)=$S($D(GMTSDEV):1,1:0)
- S GMTSDT=$$NOW^XLFDT,GMTSOBN=$P($G(^GMT(142.5,+X,0)),U,1)
- I $D(GMTSOWN) D I X'>0 S GMTSQ=1 Q X
- . N GMTSCRE S GMTSCRE=$P($G(^GMT(142.5,+X,0)),"^",17) Q:+GMTSCRE'>0
- . I GMTSNEW'>0,GMTSCRE'=DUZ,'$D(^XUSEC("GMTSMGR",DUZ)) W !!," Sorry, you can not edit someone else's object." S X=-1
- I GMTSNEW>0,+DA>0,$D(^GMT(142.5,+DA,0)) D
- . S $P(^GMT(142.5,+DA,0),U,17)=+($G(DUZ)),$P(^GMT(142.5,+DA,0),U,18)=+GMTSDT
- I +X>0 D Q:$G(X)=-1!($G(DA)=-1)!($G(Y)=-1) -1
- . N DIR,DIC,DTOUT,DUOUT,DIROUT,DLAYGO,X,Y,GMTSDEF,GMTSD,GMTSDA
- . S GMTSDA=+DA,GMTSD=""
- . ; Type
- . S GMTSDEF=$P($G(^GMT(142.5,+DA,0)),U,3),GMTSD=$P($G(^GMT(142,+GMTSDEF,0)),"^",1)
- . S:$L(GMTSD) DIC("B")=GMTSDEF S DIC("A")=" Select HEALTH SUMMARY TYPE: "
- . S:$D(GMTSDEV) DIC("S")="I +($G(^GMT(142,+Y,""VA"")))>0"
- . D K S GMTS=$$TY(GMTSDEF)
- . I +($$ABT)>0 D Q
- . . W !,"<<<<<< ABORT >>>>>>"
- . . S GMTSQ=1,X=-1 I +($G(GMTSNEW))>0 S DIK="^GMT(142.5,",DA=GMTSDA D ^DIK
- . I $G(X)="@" S GMTSQ=1 S:$L(GMTSDEF) GMTS=GMTSD_"^"_GMTSDEF D NT^GMTSOBL2(GMTSY) Q
- . I +GMTS'>0,+DA>0,GMTSNEW>0 S GMTSQ=1 D NT^GMTSOBL2(GMTSY) Q
- . I +GMTS>0,+DA>0 D Q:$G(X)=-1!($G(DA)=-1)!($G(Y)=-1) Q:+($G(GMTSQ))>0
- . . N GMTSED,DIE,DR,GMTSI,GMTST,GMTSV,GMTSDT S GMTSDT=$$NOW^XLFDT
- . . S GMTSV=+($G(GMTS)),DIE="^GMT(142.5,",DR=".03////^S X=$G(GMTSV)"
- . . S GMTSED=0 F GMTSI=1:1:3 Q:GMTSI>3 L +^GMT(142.5):0 H:'$T 1 I $T D
- . . . D ^DIE S GMTSED=1 S $P(^GMT(142.5,+DA,0),U,19)=$$NOW^XLFDT,GMTSI=4
- . . I 'GMTSED S GMTSQ=1 K GMTSOBJ W !," Record Locked by another user" Q
- . . L -^GMT(142.5) S GMTST=+($P($G(^GMT(142.5,+DA,0)),U,3))
- . . I +GMTST'>0,+DA>0 D NT^GMTSOBL2(GMTSY) Q
- S X=+($G(DA))_"^"_$P($G(^GMT(142.5,+($G(DA)),0)),"^",1)
- S:+GMTSNEW>0 X=X_"^"_+GMTSNEW
- S X=$$VER^GMTSOBL2(X)
- Q X
- TYPE(GMTS) ; Lookup HS Type
- F S GMTS=$$TYPE^GMTSOBT Q:+GMTS>0!(X="@")!(X["^")!(X="")
- S:X["^" X="^" S:X["^"!(X="@")!(X="") GMTS=-1
- Q GMTS
- TY(GMTS) ; Lookup HS Type (Learn as you go)
- N ADEL,B,BY,CHANGE,CNT,DA,DHD,DIC,DIE,DIK,DIR,DLAYGO,DR
- N EXISTS,FLDS,FR,GMTSEG,GMTSIEN,GMTSDEF,GMTSIFN,GMTSMGR,GNTSN
- N GMTSNEW,GMTSQIT,GMTSUM,L,LCNT,LI,NXTCMP,SELCNT,SOACTION,TO,TWEENER
- N TYPE,Y S EXISTS=0,(GMTSDEF,X)=$G(GMTS),GMTSQIT=0
- W:'$D(GMTSDICA) ! S U="^",DIC="^GMT(142,",DIC(0)="AEMQL"
- S DIC("A")=" Select Health Summary Type: "
- S:$L($G(GMTSDICA)) DIC("A")=$G(GMTSDICA)
- S GMTSDEF=$S(+GMTSDEF>0:$P($G(^GMT(142,+GMTSDEF,0)),"^",1),1:"")
- S:$L($G(GMTSDEF)) DIC("B")=$G(GMTSDEF)
- S DIC("S")="I +($$AHST^GMTSULT(+($G(Y))))"
- S DLAYGO=142,Y=$$TYPE^GMTSULT K DIC I +Y'>0 S X="@" Q -1
- S (GMTSIFN,DA)=+Y,GMTSUM=$P(Y,U,2),GMTSNEW=+$P(Y,U,3)
- S GMTSMGR=$S($D(^XUSEC("GMTSMGR",DUZ)):1,1:0)
- I 'GMTSNEW S X=$S(+Y>0:+Y,1:"@"),GMTS=+Y Q GMTS
- S DIE="^GMT(142,",(GMTSIFN,DA)=+Y,DR="[GMTS EDIT HLTH SUM TYPE]" D ^DIE
- I '$D(^GMT(142,+GMTSIFN,0))!($D(Y))!$D(DUOUT)!$D(DIROUT)!$D(DTOUT) D Q -1
- . S GMTSQIT=1 D CD S:'$D(^GMT(142,+GMTSIFN,0)) X="@"
- D SELCMP^GMTSRM5 I GMTSQIT D DEL(GMTSIFN) Q -1
- D LIST:EXISTS,EXISTS,CD S X=$S($D(^GMT(142,+($G(GMTSIFN)),0)):+GMTSIFN,1:-1)
- K:+X>0 DTOUT,DUOUT,DIRUT,DIROUT S:+X>0 GMTSQ=0
- Q X
- CD ; Check for Possible Deletion (New Type without Component)
- Q:+($G(GMTSIFN))'>0 Q:'$D(^GMT(142,+($G(GMTSIFN)),0))
- D:GMTSMGR!(GMTSNEW)!($P(^GMT(142,+GMTSIFN,0),U,3)'=$G(DUZ)) ADEL(+($G(GMTSIFN)))
- Q
- EXISTS ; Edit an existing health summary type
- N CNT,NXTCMP,GMTSQIT S GMTSQIT=0 Q:$D(DUOUT) S NXTCMP=0,NXTCMP(0)=0
- F CNT=$$GETCNT(GMTSIFN):0 D NXTCMP^GMTSRM1 D LIST:GMTSQIT Q:GMTSQIT!($D(DUOUT)) K GMTSQIT,GMTSNEW,TWEENER,SOACTION
- I NXTCMP>0 W !,"Please hold on while I resequence the summary order" D COPY^GMTSRN,RNMBR^GMTSRN:CHANGE
- Q
- LIST ; Lists existing summary parameters
- N B,DIC,DIR,IOP,Y,FR,TO,BY,DHD,FLDS,L I GMTSQIT'=2 Q:($D(DUOUT)!(GMTSQIT=1))
- I GMTSQIT=2,(NXTCMP=0) S GMTSQIT=0 Q
- I 'GMTSNEW W ! S DIC=142,DIR(0)="Y",DIR("A")="Do you wish to review the Summary Type structure before continuing",DIR("B")="NO" D ^DIR K DIR I 'Y S:GMTSQIT=2 DUOUT="" S:GMTSQIT=2 GMTSQIT="D" S:$D(DUOUT) GMTSQIT=1 Q
- I $D(GMTSQIT),GMTSQIT=2 S GMTSQIT=0
- S IOP="HOME",DIC=142,(FR,TO)=GMTSUM,BY=".01",DHD="[GMTS TYPE INQ HEADER]-[GMTS TYPE INQ FOOTER]",FLDS="[GMTS TYPE INQ]",L=0 D EN1^DIP
- Q
- GETCNT(GMTSIFN) ; Determine default summary order for new component
- N LI,LCNT S LI=0,LCNT=5 F S LI=$O(^GMT(142,+GMTSIFN,1,LI)) Q:+LI'>0 S LCNT=$P(LI,".")+5
- Q LCNT
- ADEL(X) ; Ask to Delete Type
- 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 Type
- 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) " < Health Summary Type deleted >" W:'$D(ADEL) !,?2,GMTSN," < deleted >"
- Q
- K ; Kill Common Variables
- K DTOUT,DUOUT,DIRUT,DIROUT
- Q
- ABT(X) ; Abort
- Q:$D(DTOUT)!($D(DUOUT))!($D(DIRUT))!($D(DIROUT)) 1
- Q 0
- ST ; Show Type
- N GMTSN,GMTSC S GMTSN="^GMT(142,"_+($G(GMTSIFN))_")",GMTSC="^GMT(142,"_+($G(GMTSIFN))_","
- W ! F S GMTSN=$Q(@GMTSN) Q:GMTSN=""!(GMTSN'[GMTSC) W !,GMTSN,"=",@GMTSN
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMTSOBL 9076 printed Feb 18, 2025@23:24:45 Page 2
- GMTSOBL ; SLC/KER - HS Object - Lookup ; 06/24/2009
- +1 ;;2.7;Health Summary;**58,89**;Oct 20, 1995;Build 61
- +2 ;
- +3 ; External References
- +4 ; DBIA 10006 ^DIC (file #142.5)
- +5 ; DBIA 10018 ^DIE (file #142 and 142.5)
- +6 ; DBIA 10013 ^DIK (file #142 and 142.5)
- +7 ; DBIA 10026 ^DIR
- +8 ; DBIA 10010 EN1^DIP
- +9 ; DBIA 10076 ^XUSEC(
- +10 ; DBIA 10076 ^XUSEC("GMTSMGR")
- +11 ; DBIA 10112 $$SITE^VASITE
- +12 ; DBIA 10103 $$NOW^XLFDT
- +13 ;
- +14 QUIT
- OBJ(X) ; Lookup HS Object
- +1 if +($GET(DUZ))'>0
- QUIT -1
- NEW DIR,DIC,DTOUT,DUOUT,DIROUT,DLAYGO,DA,D,D0,D1,DI,DQ,Y
- SET U="^"
- +2 SET DIC="^GMT(142.5,"
- SET DIC(0)="AEMQ"
- SET DIC("A")=" Select HEALTH SUMMARY OBJECT: "
- KILL DLAYGO
- DO ^DIC
- +3 if +($$ABT)>0
- SET Y=-1
- SET X=+($GET(Y))
- +4 QUIT X
- HSO(X) ; Lookup HS Object (by Known Name)
- +1 IF +($GET(DUZ))'>0
- SET GMTSQ=1
- QUIT -1
- +2 NEW GMTSOWN,GMTSDICS,GMTSNAM,GMTSIEN,GMTSNEW
- +3 NEW DIR,DIC,DTOUT,DUOUT,DIROUT,DLAYGO,DINUM,DA,D,D0,D1,DI,DQ,Y,GMTSL,GMTSH,GMTSS,GMTSTA
- SET U="^"
- +4 SET GMTSNAM=$GET(X)
- SET GMTSNEW=0
- SET GMTSOWN=""
- SET GMTSQ=0
- IF '$LENGTH(GMTSNAM)
- SET GMTSQ=1
- QUIT -1
- +5 SET X=GMTSNAM
- IF '$LENGTH(X)
- SET X=-1
- SET GMTSQ=1
- QUIT X
- +6 SET DIC="^GMT(142.5,"
- SET DIC(0)="XML"
- SET DLAYGO=142.5
- if $LENGTH($GET(GMTSDICS))
- SET DIC("S")=$GET(GMTSDICS)
- +7 SET GMTSTA=+($PIECE($$SITE^VASITE,"^",3))
- IF +GMTSTA'>0
- SET X=-1
- SET GMTSQ=1
- QUIT X
- +8 SET GMTSS=+($GET(GMTSTA))
- if $DATA(GMTSDEV)
- SET GMTSS=5000
- SET GMTSL=GMTSS_"0000"
- +9 SET GMTSH=GMTSS_"9999"
- SET GMTSH=($ORDER(^GMT(142.5,+GMTSH),-1)+1)
- +10 if +GMTSH<+GMTSL
- SET GMTSH=+GMTSS_"0001"
- if +GMTSH>0
- SET DINUM=+GMTSH
- +11 DO ^DIC
- IF +($$ABT)>0
- SET GMTSQ=1
- SET X=-1
- QUIT X
- +12 SET GMTSNEW=+($PIECE(Y,"^",3))
- +13 IF +Y'>0
- SET X=-1
- QUIT X
- +14 SET X=+($GET(Y))_"^"_$PIECE($GET(^GMT(142.5,+($GET(Y)),0)),"^",1)
- if +GMTSNEW>0
- SET $PIECE(X,"^",3)=+GMTSNEW
- +15 if GMTSNEW>0
- WRITE !,"Creating Health Summary Object '",GMTSNAM,"'"
- +16 if +GMTSNEW>0
- SET X=$$EE(Y)
- IF +($GET(GMTSQ))>1
- SET X=-1
- QUIT
- +17 if +X'>0
- SET X=-1
- IF +($GET(GMTSQ))=0
- Begin DoDot:1
- +18 if +GMTSNEW>0&(+X>0)
- DO NEW^GMTSOBL2(+X)
- +19 if +GMTSNEW'>0&(+X>0)
- DO MOD^GMTSOBL2(+X)
- End DoDot:1
- +20 QUIT X
- LK(X) ; Lookup HS Object (Learn as you go)
- +1 if +($GET(DUZ))'>0
- QUIT -1
- NEW GMTSDICS,GMTSB
- SET GMTSDICS=$GET(DIC("S"))
- KILL DIC("S")
- SET GMTSDICS=$$DIM^GMTSOBL2(GMTSDICS)
- SET GMTSB=$PIECE($$B^GMTSOBL2,"^",2)
- +2 NEW DIR,DIC,DTOUT,DUOUT,DIROUT,DLAYGO,DA,D,D0,D1,DI,DQ,GMTSNAM,GMTSTA
- +3 NEW GMTS,GMTSTD,GMTSOBJ,GMTSOBN,GMTSDT,GMTSNEW,GMTSDEF,GMTSDA,Y,X1
- SET U="^"
- +4 SET GMTSNEW=0
- SET GMTSTA=+($PIECE($$SITE^VASITE,"^",3))
- if +GMTSTA=0
- QUIT -1
- +5 SET DIR(0)="FAO^1:30^S:X="" "" (X,X1)=$G(GMTSB) K:$L(X)<3&(X'="" "") X"
- +6 SET DIR("A")=" Select HEALTH SUMMARY OBJECT: "
- SET (DIR("?"),DIR("??"))="^D NAH^GMTSOBL2"
- +7 DO ^DIR
- if '$LENGTH(Y)!(Y["^")
- QUIT -1
- SET GMTSNAM=Y
- +8 SET DIC="^GMT(142.5,"
- SET DIC(0)="EM"
- if $LENGTH($GET(GMTSDICS))
- SET DIC("S")=$GET(GMTSDICS)
- +9 WRITE !
- DO ^DIC
- +10 IF +($$ABT)>0
- SET GMTSQ=1
- SET Y=-1
- SET X=-1
- QUIT X
- +11 IF +Y'>0
- Begin DoDot:1
- +12 NEW X,DIC,DINUM,GMTSL,GMTSH,GMTSS
- SET GMTSS=+($GET(GMTSTA))
- if $DATA(GMTSDEV)
- SET GMTSS=5000
- +13 SET X=$GET(GMTSNAM)
- if '$LENGTH(X)
- QUIT
- SET GMTSL=GMTSS_"0000"
- +14 SET GMTSH=GMTSS_"9999"
- SET GMTSH=($ORDER(^GMT(142.5,+GMTSH),-1)+1)
- +15 if +GMTSH<+GMTSL
- SET GMTSH=+GMTSS_"0001"
- if +GMTSH>0
- SET DINUM=+GMTSH
- +16 SET DIC="^GMT(142.5,"
- SET DIC(0)="EML"
- SET DLAYGO=142.5
- +17 if $LENGTH($GET(GMTSDICS))
- SET DIC("S")=$GET(GMTSDICS)
- DO ^DIC
- +18 SET GMTSNEW=+($PIECE(Y,"^",3))
- +19 IF +($$ABT)>0
- SET GMTSQ=1
- End DoDot:1
- if +Y'>0
- QUIT -1
- +20 IF +($GET(GMTSQ))>0
- SET Y=-1
- SET X=-1
- QUIT X
- +21 SET X=+($GET(Y))_"^"_$PIECE($GET(^GMT(142.5,+($GET(Y)),0)),"^",1)
- +22 if +GMTSNEW>0
- SET $PIECE(X,"^",3)=+GMTSNEW
- SET X=$$EE(Y)
- if +X'>0
- SET X=-1
- IF +X'>0
- SET GMTSQ=1
- SET Y=-1
- SET X=-1
- QUIT X
- +23 IF +($GET(GMTSQ))=0
- if +GMTSNEW>0&(+X>0)
- DO NEW^GMTSOBL2(+X)
- if +GMTSNEW'>0&(+X>0)
- DO MOD^GMTSOBL2(+X)
- +24 QUIT X
- EE(X) ; Enter/Edit
- +1 NEW GMTSOBJ,DA,GMTSY,GMTSNAM,GMTSTYP,GMTSDICS,GMTSDICA,GMTSDICB,Y
- SET Y=$GET(X)
- SET (GMTSOBJ,DA,X)=+($GET(Y))
- SET GMTSY=$GET(Y)
- +2 SET GMTSTYP=$PIECE($GET(^GMT(142.5,+DA,0)),"^",3)
- SET GMTSTYP=$PIECE($GET(^GMT(142,+GMTSTYP,0)),"^",1)
- +3 SET GMTSNEW=$SELECT(+($PIECE($GET(Y),U,3))>0:1,1:0)
- IF GMTSNEW>0
- Begin DoDot:1
- +4 SET $PIECE(^GMT(142.5,+DA,0),"^",20)=$SELECT($DATA(GMTSDEV):1,1:0)
- End DoDot:1
- +5 SET GMTSDT=$$NOW^XLFDT
- SET GMTSOBN=$PIECE($GET(^GMT(142.5,+X,0)),U,1)
- +6 IF $DATA(GMTSOWN)
- Begin DoDot:1
- +7 NEW GMTSCRE
- SET GMTSCRE=$PIECE($GET(^GMT(142.5,+X,0)),"^",17)
- if +GMTSCRE'>0
- QUIT
- +8 IF GMTSNEW'>0
- IF GMTSCRE'=DUZ
- IF '$DATA(^XUSEC("GMTSMGR",DUZ))
- WRITE !!," Sorry, you can not edit someone else's object."
- SET X=-1
- End DoDot:1
- IF X'>0
- SET GMTSQ=1
- QUIT X
- +9 IF GMTSNEW>0
- IF +DA>0
- IF $DATA(^GMT(142.5,+DA,0))
- Begin DoDot:1
- +10 SET $PIECE(^GMT(142.5,+DA,0),U,17)=+($GET(DUZ))
- SET $PIECE(^GMT(142.5,+DA,0),U,18)=+GMTSDT
- End DoDot:1
- +11 IF +X>0
- Begin DoDot:1
- +12 NEW DIR,DIC,DTOUT,DUOUT,DIROUT,DLAYGO,X,Y,GMTSDEF,GMTSD,GMTSDA
- +13 SET GMTSDA=+DA
- SET GMTSD=""
- +14 ; Type
- +15 SET GMTSDEF=$PIECE($GET(^GMT(142.5,+DA,0)),U,3)
- SET GMTSD=$PIECE($GET(^GMT(142,+GMTSDEF,0)),"^",1)
- +16 if $LENGTH(GMTSD)
- SET DIC("B")=GMTSDEF
- SET DIC("A")=" Select HEALTH SUMMARY TYPE: "
- +17 if $DATA(GMTSDEV)
- SET DIC("S")="I +($G(^GMT(142,+Y,""VA"")))>0"
- +18 DO K
- SET GMTS=$$TY(GMTSDEF)
- +19 IF +($$ABT)>0
- Begin DoDot:2
- +20 WRITE !,"<<<<<< ABORT >>>>>>"
- +21 SET GMTSQ=1
- SET X=-1
- IF +($GET(GMTSNEW))>0
- SET DIK="^GMT(142.5,"
- SET DA=GMTSDA
- DO ^DIK
- End DoDot:2
- QUIT
- +22 IF $GET(X)="@"
- SET GMTSQ=1
- if $LENGTH(GMTSDEF)
- SET GMTS=GMTSD_"^"_GMTSDEF
- DO NT^GMTSOBL2(GMTSY)
- QUIT
- +23 IF +GMTS'>0
- IF +DA>0
- IF GMTSNEW>0
- SET GMTSQ=1
- DO NT^GMTSOBL2(GMTSY)
- QUIT
- +24 IF +GMTS>0
- IF +DA>0
- Begin DoDot:2
- +25 NEW GMTSED,DIE,DR,GMTSI,GMTST,GMTSV,GMTSDT
- SET GMTSDT=$$NOW^XLFDT
- +26 SET GMTSV=+($GET(GMTS))
- SET DIE="^GMT(142.5,"
- SET DR=".03////^S X=$G(GMTSV)"
- +27 SET GMTSED=0
- FOR GMTSI=1:1:3
- if GMTSI>3
- QUIT
- LOCK +^GMT(142.5):0
- if '$TEST
- HANG 1
- IF $TEST
- Begin DoDot:3
- +28 DO ^DIE
- SET GMTSED=1
- SET $PIECE(^GMT(142.5,+DA,0),U,19)=$$NOW^XLFDT
- SET GMTSI=4
- End DoDot:3
- +29 IF 'GMTSED
- SET GMTSQ=1
- KILL GMTSOBJ
- WRITE !," Record Locked by another user"
- QUIT
- +30 LOCK -^GMT(142.5)
- SET GMTST=+($PIECE($GET(^GMT(142.5,+DA,0)),U,3))
- +31 IF +GMTST'>0
- IF +DA>0
- DO NT^GMTSOBL2(GMTSY)
- QUIT
- End DoDot:2
- if $GET(X)=-1!($GET(DA)=-1)!($GET(Y)=-1)
- QUIT
- if +($GET(GMTSQ))>0
- QUIT
- End DoDot:1
- if $GET(X)=-1!($GET(DA)=-1)!($GET(Y)=-1)
- QUIT -1
- +32 SET X=+($GET(DA))_"^"_$PIECE($GET(^GMT(142.5,+($GET(DA)),0)),"^",1)
- +33 if +GMTSNEW>0
- SET X=X_"^"_+GMTSNEW
- +34 SET X=$$VER^GMTSOBL2(X)
- +35 QUIT X
- TYPE(GMTS) ; Lookup HS Type
- +1 FOR
- SET GMTS=$$TYPE^GMTSOBT
- if +GMTS>0!(X="@")!(X["^")!(X="")
- QUIT
- +2 if X["^"
- SET X="^"
- if X["^"!(X="@")!(X="")
- SET GMTS=-1
- +3 QUIT GMTS
- TY(GMTS) ; Lookup HS Type (Learn as you go)
- +1 NEW ADEL,B,BY,CHANGE,CNT,DA,DHD,DIC,DIE,DIK,DIR,DLAYGO,DR
- +2 NEW EXISTS,FLDS,FR,GMTSEG,GMTSIEN,GMTSDEF,GMTSIFN,GMTSMGR,GNTSN
- +3 NEW GMTSNEW,GMTSQIT,GMTSUM,L,LCNT,LI,NXTCMP,SELCNT,SOACTION,TO,TWEENER
- +4 NEW TYPE,Y
- SET EXISTS=0
- SET (GMTSDEF,X)=$GET(GMTS)
- SET GMTSQIT=0
- +5 if '$DATA(GMTSDICA)
- WRITE !
- SET U="^"
- SET DIC="^GMT(142,"
- SET DIC(0)="AEMQL"
- +6 SET DIC("A")=" Select Health Summary Type: "
- +7 if $LENGTH($GET(GMTSDICA))
- SET DIC("A")=$GET(GMTSDICA)
- +8 SET GMTSDEF=$SELECT(+GMTSDEF>0:$PIECE($GET(^GMT(142,+GMTSDEF,0)),"^",1),1:"")
- +9 if $LENGTH($GET(GMTSDEF))
- SET DIC("B")=$GET(GMTSDEF)
- +10 SET DIC("S")="I +($$AHST^GMTSULT(+($G(Y))))"
- +11 SET DLAYGO=142
- SET Y=$$TYPE^GMTSULT
- KILL DIC
- IF +Y'>0
- SET X="@"
- QUIT -1
- +12 SET (GMTSIFN,DA)=+Y
- SET GMTSUM=$PIECE(Y,U,2)
- SET GMTSNEW=+$PIECE(Y,U,3)
- +13 SET GMTSMGR=$SELECT($DATA(^XUSEC("GMTSMGR",DUZ)):1,1:0)
- +14 IF 'GMTSNEW
- SET X=$SELECT(+Y>0:+Y,1:"@")
- SET GMTS=+Y
- QUIT GMTS
- +15 SET DIE="^GMT(142,"
- SET (GMTSIFN,DA)=+Y
- SET DR="[GMTS EDIT HLTH SUM TYPE]"
- DO ^DIE
- +16 IF '$DATA(^GMT(142,+GMTSIFN,0))!($DATA(Y))!$DATA(DUOUT)!$DATA(DIROUT)!$DATA(DTOUT)
- Begin DoDot:1
- +17 SET GMTSQIT=1
- DO CD
- if '$DATA(^GMT(142,+GMTSIFN,0))
- SET X="@"
- End DoDot:1
- QUIT -1
- +18 DO SELCMP^GMTSRM5
- IF GMTSQIT
- DO DEL(GMTSIFN)
- QUIT -1
- +19 if EXISTS
- DO LIST
- DO EXISTS
- DO CD
- SET X=$SELECT($DATA(^GMT(142,+($GET(GMTSIFN)),0)):+GMTSIFN,1:-1)
- +20 if +X>0
- KILL DTOUT,DUOUT,DIRUT,DIROUT
- if +X>0
- SET GMTSQ=0
- +21 QUIT X
- CD ; Check for Possible Deletion (New Type without Component)
- +1 if +($GET(GMTSIFN))'>0
- QUIT
- if '$DATA(^GMT(142,+($GET(GMTSIFN)),0))
- QUIT
- +2 if GMTSMGR!(GMTSNEW)!($PIECE(^GMT(142,+GMTSIFN,0),U,3)'=$GET(DUZ))
- DO ADEL(+($GET(GMTSIFN)))
- +3 QUIT
- EXISTS ; Edit an existing health summary type
- +1 NEW CNT,NXTCMP,GMTSQIT
- SET GMTSQIT=0
- if $DATA(DUOUT)
- QUIT
- SET NXTCMP=0
- SET NXTCMP(0)=0
- +2 FOR CNT=$$GETCNT(GMTSIFN):0
- DO NXTCMP^GMTSRM1
- if GMTSQIT
- DO LIST
- if GMTSQIT!($DATA(DUOUT))
- QUIT
- KILL GMTSQIT,GMTSNEW,TWEENER,SOACTION
- +3 IF NXTCMP>0
- WRITE !,"Please hold on while I resequence the summary order"
- DO COPY^GMTSRN
- if CHANGE
- DO RNMBR^GMTSRN
- +4 QUIT
- LIST ; Lists existing summary parameters
- +1 NEW B,DIC,DIR,IOP,Y,FR,TO,BY,DHD,FLDS,L
- IF GMTSQIT'=2
- if ($DATA(DUOUT)!(GMTSQIT=1))
- QUIT
- +2 IF GMTSQIT=2
- IF (NXTCMP=0)
- SET GMTSQIT=0
- QUIT
- +3 IF 'GMTSNEW
- WRITE !
- SET DIC=142
- SET DIR(0)="Y"
- SET DIR("A")="Do you wish to review the Summary Type structure before continuing"
- SET DIR("B")="NO"
- DO ^DIR
- KILL DIR
- IF 'Y
- if GMTSQIT=2
- SET DUOUT=""
- if GMTSQIT=2
- SET GMTSQIT="D"
- if $DATA(DUOUT)
- SET GMTSQIT=1
- QUIT
- +4 IF $DATA(GMTSQIT)
- IF GMTSQIT=2
- SET GMTSQIT=0
- +5 SET IOP="HOME"
- SET DIC=142
- SET (FR,TO)=GMTSUM
- SET BY=".01"
- SET DHD="[GMTS TYPE INQ HEADER]-[GMTS TYPE INQ FOOTER]"
- SET FLDS="[GMTS TYPE INQ]"
- SET L=0
- DO EN1^DIP
- +6 QUIT
- GETCNT(GMTSIFN) ; Determine default summary order for new component
- +1 NEW LI,LCNT
- SET LI=0
- SET LCNT=5
- FOR
- SET LI=$ORDER(^GMT(142,+GMTSIFN,1,LI))
- if +LI'>0
- QUIT
- SET LCNT=$PIECE(LI,".")+5
- +2 QUIT LCNT
- ADEL(X) ; Ask to Delete Type
- +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 Type
- +1 NEW DIK,DA,GMTSN
- SET DA=+($GET(X))
- if DA=0
- QUIT
- if '$DATA(^GMT(142,DA,0))
- QUIT
- +2 SET DIK="^GMT(142,"
- SET GMTSN=$PIECE($GET(^GMT(142,DA,0)),"^",1)
- if '$LENGTH(GMTSN)
- QUIT
- DO ^DIK
- +3 IF '$DATA(^GMT(142,DA,0))
- if $DATA(ADEL)
- WRITE " < Health Summary Type deleted >"
- if '$DATA(ADEL)
- WRITE !,?2,GMTSN," < deleted >"
- +4 QUIT
- K ; Kill Common Variables
- +1 KILL DTOUT,DUOUT,DIRUT,DIROUT
- +2 QUIT
- ABT(X) ; Abort
- +1 if $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIRUT))!($DATA(DIROUT))
- QUIT 1
- +2 QUIT 0
- ST ; Show Type
- +1 NEW GMTSN,GMTSC
- SET GMTSN="^GMT(142,"_+($GET(GMTSIFN))_")"
- SET GMTSC="^GMT(142,"_+($GET(GMTSIFN))_","
- +2 WRITE !
- FOR
- SET GMTSN=$QUERY(@GMTSN)
- if GMTSN=""!(GMTSN'[GMTSC)
- QUIT
- WRITE !,GMTSN,"=",@GMTSN
- +3 QUIT