GMTSXAW ; SLC/KER - List Parameters/Allowable ; 02/27/2002
;;2.7;Health Summary;**47,49**;Oct 20, 1995
Q
;
EN ; Main Entry Point for Health Summary
K GMTSALW Q:'$L($$UNM^GMTSXAW3(+($G(DUZ))))
D ALW("ORWRP HEALTH SUMMARY TYPE LIST",.GMTSALW,+($G(DUZ)),"GMTS") Q
EN2(X) ; Entry for User X
K GMTSALW N GMTSUSR S GMTSUSR=+($G(X)) Q:'$L($$UNM^GMTSXAW3(+($G(GMTSUSR))))
D ALW("ORWRP HEALTH SUMMARY TYPE LIST",.GMTSALW,GMTSUSR,"GMTS") Q
DEF(X) ; Default Entities for HS Typye List
;
; Use
; DIV Division If exist
; SYS System Exported Entity
; SRV Service If exist
; OTL OERR Team List If exist
; USR User Exported Entity
; CLS User Class If exist
;
; Exclude
; DEV Device
; PKG Package
; LOC Location
; TEA PCMM Team
; BED Room/Bed
;
N GMTSI,GMTSEP,GMTSES,GMTSEA,GMTSC,GMTSPAR,GMTSMSG,GMTSX,GMTSALW
S (GMTSI,GMTSC)=0,GMTSX="",GMTSPAR=$$HSD^GMTSXAW3 Q:+GMTSPAR=0 ""
D LST^GMTSXAW3(GMTSPAR,.GMTSALW)
F S GMTSI=$O(^TMP("DILIST",$J,"ID",GMTSI)) Q:+GMTSI=0 D
. S GMTSES=+($G(^TMP("DILIST",$J,"ID",GMTSI,.01))) Q:+GMTSES'>0
. S GMTSEP=+($G(^TMP("DILIST",$J,"ID",GMTSI,.02))) Q:+GMTSEP'>0
. S GMTSEA=$$EAB^GMTSXAW3(+($G(GMTSEP)))
. Q:$L(GMTSEA)'=3 S GMTSX(+GMTSES)=GMTSEA
S GMTSI=0 F S GMTSI=$O(GMTSX(GMTSI)) Q:+GMTSI=0 S:$G(GMTSX(GMTSI))?3U X=$G(X)_";"_GMTSX(GMTSI)
S X=$$UP^GMTSXA($$TRIM^GMTSXA(X,";"))
K ^TMP("DILIST",$J)
Q X
;
ALW(GMTSPAR,GMTSALW,GMTSUSR,GMTSPKG) ; Allowable Entities
;
; GMTSPAR Parameter Name Required
; .GMTSALW Output Ary for Allowable Entities Required
; GMTSUSR User (pointer) Required
; GMTSPKG Package Prefix (text) Optional
;
N GMTSPDEF,GMTSI,GMTSEC,GMTSPV,GMTSLL,GMTSUN,GMTSCALL
S GMTSPKG=$G(GMTSPKG),GMTSPAR=$G(GMTSPAR),GMTSUSR=$G(GMTSUSR)
Q:'$L($$UNM^GMTSXAW3(+($G(GMTSUSR))))
S GMTSPDEF=$$PDI^GMTSXAW3(GMTSPAR) Q:+GMTSPDEF=0 D ALWD(GMTSPDEF,.GMTSALW) S GMTSI=""
F S GMTSI=$O(GMTSALW("B",GMTSI)) Q:GMTSI="" D
. S GMTSEC=+($O(GMTSALW("B",GMTSI,0))) Q:GMTSEC=0 D
. . S GMTSLL=GMTSI,GMTSCALL=GMTSLL_"^GMTSXAW2" D GET
Q
CHK(GMTSALW,GMTSUSR,GMTSPKG) ; Check values Only
;
; .GMTSALW Output Array for values Required
; GMTSUSR User (pointer) Required
; GMTSPKG Package Prefix (namespace) Optional
;
N GMTSCHK S GMTSCHK=1 D V2
Q
VAL(GMTSALW,GMTSUSR,GMTSPKG) ; All Values and Pointers
;
; .GMTSALW Output Array for values Required
; GMTSUSR User (pointer) Required
; GMTSPKG Package Prefix (namespace) Optional
;
V2 ; Get Values and Pointers
N GMTSU,GMTSPV S GMTSU=+($G(GMTSUSR)) S:+($G(GMTSUSR))=0 GMTSU=+($G(DUZ))
N GMTSUSR S GMTSUSR=GMTSU Q:'$L($$UNM^GMTSXAW3(+($G(GMTSUSR))))
N GMTST,GMTSI,GMTSEC,GMTSLL,GMTSCALL,GMTSVAL S GMTSPKG=$G(GMTSPKG),GMTSVAL=1
S GMTSEC=0,GMTST="DEV;DIV;SYS;PKG;LOC;SRV;OTL;USR;CLS"
F GMTSI=1:1 Q:'$L($P(GMTST,";",GMTSI)) S GMTSLL=$P(GMTST,";",GMTSI),GMTSCALL=GMTSLL_"^GMTSXAW2" D GET
Q
;
ALWD(X,Y) ; Get Allowed Entities for Parameter
;
; X Parameter (pointer) Required
; .Y Output Array for Allowed Entities Required
;
N GMTSPIEN,GMTSNAM,GMTSMSG,GMTSALW,GMTSLST,GMTSENT,GMTSPRE,GMTSCT,GMTSAL
S GMTSAL="",GMTSCT=0,GMTSPIEN=+($G(X)) Q:X=0 K ^TMP("DILIST",$J)
S GMTSNAM=$$PDN^GMTSXAW3(+GMTSPIEN) Q:'$L(GMTSNAM)
D LST^GMTSXAW3(GMTSPIEN,.GMTSALW)
S GMTSLST=0 F S GMTSLST=$O(^TMP("DILIST",$J,"ID",GMTSLST)) Q:+GMTSLST=0 D
. S GMTSENT=+($G(^TMP("DILIST",$J,"ID",GMTSLST,.02)))
. S GMTSPRE=$$EAB^GMTSXAW3(+($G(GMTSENT))) Q:'$L(GMTSPRE) S GMTSCT=GMTSCT+1
. S Y(GMTSCT)=GMTSPRE_"^"_$$EFN^GMTSXAW3(+($G(GMTSENT)))_"^"_$$ENM^GMTSXAW3(+($G(GMTSENT)))_"^"_$$EMC^GMTSXAW3(+($G(GMTSENT)))
. S Y("B",GMTSPRE,GMTSCT)=$G(Y(GMTSCT)),GMTSAL=GMTSAL_";"_$$UP^GMTSXA(GMTSPRE)
K ^TMP("DILIST",$J) S Y("ALLOWABLE")=$$TRIM^GMTSXA(GMTSAL,";"),Y(0)=GMTSCT
Q
; Parameter Entites
GET ; Get Entities
S GMTSLL=$G(GMTSLL),GMTSCALL=$G(GMTSCALL) Q:'$L($T(@GMTSCALL)) K GMTSPV D @GMTSCALL
N GMTS,GMTSA,GMTSP,GMTSN,GMTSC,GMTSV S GMTS=0
F S GMTS=$O(GMTSPV(GMTS)) Q:+GMTS=0 D
. S GMTSA=$G(GMTSPV(GMTS)),GMTSP=$P(GMTSA,"^",2)
. Q:GMTSP'[";" S GMTSN=$P(GMTSA,"^",3) Q:'$L(GMTSN)
. S GMTSC=+($G(GMTSEC)),GMTSV=+($G(GMTSVAL))+($G(GMTSCHK))
. S GMTSA=$P(GMTSA,"^",1) Q:$L(GMTSA)'=3
. D SET^GMTSXAW3(GMTSA,GMTSP,GMTSN,.GMTSALW,GMTSC,GMTSV)
Q
TST ; Test entry
N GMTSEC,GMTSI,GMTSLL,GMTSCALL,GMTSU,GMTSPV,GMTSPKG,GMTSN,GMTSC,GMTSA,GMTSP,GMTST,GMTSV
S GMTSEC=0,GMTSPKG="GMTS" S:'$L($G(GMTST)) GMTST="DEV;DIV;SYS;PKG;LOC;SRV;OTL;USR;CLS",GMTSPKG="GMTS"
S GMTSU=+($G(GMTSUSR)) S:GMTSU'>0 GMTSU=+($G(DUZ)) Q:GMTSU'>0 N GMTSUSR S GMTSUSR=GMTSU
F GMTSI=1:1 Q:'$L($P(GMTST,";",GMTSI)) D
. S GMTSLL=$P(GMTST,";",GMTSI),GMTSCALL=GMTSLL_"^GMTSXAW2"
. W !!,GMTSLL,?8,$$EMC^GMTSXAW3($$ETI^GMTSXAW3(GMTSLL))
. Q:'$L($T(@GMTSCALL)) K GMTSPV D @GMTSCALL Q:'$D(GMTSPV)
. S GMTSEC=0 S:$L(GMTSLL) GMTSEC=+($O(GMTSALW("B",GMTSLL,0)))
. S GMTSN="GMTSPV(0)",GMTSC="GMTSPV("
. F S GMTSN=$Q(@GMTSN) Q:GMTSN=""!(GMTSN'[GMTSC) W !,GMTSN,"=",@GMTSN
. N GMTS S GMTS=0 F S GMTS=$O(GMTSPV(GMTS)) Q:+GMTS=0 D
. . S GMTSA=$G(GMTSPV(GMTS)),GMTSP=$P(GMTSA,"^",2)
. . Q:GMTSP'[";" S GMTSN=$P(GMTSA,"^",3) Q:'$L(GMTSN)
. . S GMTSC=+($G(GMTSEC)),GMTSV=+($G(GMTSVAL))+($G(GMTSCHK))
. . S GMTSA=$P(GMTSA,"^",1) Q:$L(GMTSA)'=3
. . D SET^GMTSXAW3(GMTSA,GMTSP,GMTSN,.GMTSALW,GMTSC,GMTSV)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMTSXAW 5883 printed Oct 16, 2024@18:01:39 Page 2
GMTSXAW ; SLC/KER - List Parameters/Allowable ; 02/27/2002
+1 ;;2.7;Health Summary;**47,49**;Oct 20, 1995
+2 QUIT
+3 ;
EN ; Main Entry Point for Health Summary
+1 KILL GMTSALW
if '$LENGTH($$UNM^GMTSXAW3(+($GET(DUZ))))
QUIT
+2 DO ALW("ORWRP HEALTH SUMMARY TYPE LIST",.GMTSALW,+($GET(DUZ)),"GMTS")
QUIT
EN2(X) ; Entry for User X
+1 KILL GMTSALW
NEW GMTSUSR
SET GMTSUSR=+($GET(X))
if '$LENGTH($$UNM^GMTSXAW3(+($GET(GMTSUSR))))
QUIT
+2 DO ALW("ORWRP HEALTH SUMMARY TYPE LIST",.GMTSALW,GMTSUSR,"GMTS")
QUIT
DEF(X) ; Default Entities for HS Typye List
+1 ;
+2 ; Use
+3 ; DIV Division If exist
+4 ; SYS System Exported Entity
+5 ; SRV Service If exist
+6 ; OTL OERR Team List If exist
+7 ; USR User Exported Entity
+8 ; CLS User Class If exist
+9 ;
+10 ; Exclude
+11 ; DEV Device
+12 ; PKG Package
+13 ; LOC Location
+14 ; TEA PCMM Team
+15 ; BED Room/Bed
+16 ;
+17 NEW GMTSI,GMTSEP,GMTSES,GMTSEA,GMTSC,GMTSPAR,GMTSMSG,GMTSX,GMTSALW
+18 SET (GMTSI,GMTSC)=0
SET GMTSX=""
SET GMTSPAR=$$HSD^GMTSXAW3
if +GMTSPAR=0
QUIT ""
+19 DO LST^GMTSXAW3(GMTSPAR,.GMTSALW)
+20 FOR
SET GMTSI=$ORDER(^TMP("DILIST",$JOB,"ID",GMTSI))
if +GMTSI=0
QUIT
Begin DoDot:1
+21 SET GMTSES=+($GET(^TMP("DILIST",$JOB,"ID",GMTSI,.01)))
if +GMTSES'>0
QUIT
+22 SET GMTSEP=+($GET(^TMP("DILIST",$JOB,"ID",GMTSI,.02)))
if +GMTSEP'>0
QUIT
+23 SET GMTSEA=$$EAB^GMTSXAW3(+($GET(GMTSEP)))
+24 if $LENGTH(GMTSEA)'=3
QUIT
SET GMTSX(+GMTSES)=GMTSEA
End DoDot:1
+25 SET GMTSI=0
FOR
SET GMTSI=$ORDER(GMTSX(GMTSI))
if +GMTSI=0
QUIT
if $GET(GMTSX(GMTSI))?3U
SET X=$GET(X)_";"_GMTSX(GMTSI)
+26 SET X=$$UP^GMTSXA($$TRIM^GMTSXA(X,";"))
+27 KILL ^TMP("DILIST",$JOB)
+28 QUIT X
+29 ;
ALW(GMTSPAR,GMTSALW,GMTSUSR,GMTSPKG) ; Allowable Entities
+1 ;
+2 ; GMTSPAR Parameter Name Required
+3 ; .GMTSALW Output Ary for Allowable Entities Required
+4 ; GMTSUSR User (pointer) Required
+5 ; GMTSPKG Package Prefix (text) Optional
+6 ;
+7 NEW GMTSPDEF,GMTSI,GMTSEC,GMTSPV,GMTSLL,GMTSUN,GMTSCALL
+8 SET GMTSPKG=$GET(GMTSPKG)
SET GMTSPAR=$GET(GMTSPAR)
SET GMTSUSR=$GET(GMTSUSR)
+9 if '$LENGTH($$UNM^GMTSXAW3(+($GET(GMTSUSR))))
QUIT
+10 SET GMTSPDEF=$$PDI^GMTSXAW3(GMTSPAR)
if +GMTSPDEF=0
QUIT
DO ALWD(GMTSPDEF,.GMTSALW)
SET GMTSI=""
+11 FOR
SET GMTSI=$ORDER(GMTSALW("B",GMTSI))
if GMTSI=""
QUIT
Begin DoDot:1
+12 SET GMTSEC=+($ORDER(GMTSALW("B",GMTSI,0)))
if GMTSEC=0
QUIT
Begin DoDot:2
+13 SET GMTSLL=GMTSI
SET GMTSCALL=GMTSLL_"^GMTSXAW2"
DO GET
End DoDot:2
End DoDot:1
+14 QUIT
CHK(GMTSALW,GMTSUSR,GMTSPKG) ; Check values Only
+1 ;
+2 ; .GMTSALW Output Array for values Required
+3 ; GMTSUSR User (pointer) Required
+4 ; GMTSPKG Package Prefix (namespace) Optional
+5 ;
+6 NEW GMTSCHK
SET GMTSCHK=1
DO V2
+7 QUIT
VAL(GMTSALW,GMTSUSR,GMTSPKG) ; All Values and Pointers
+1 ;
+2 ; .GMTSALW Output Array for values Required
+3 ; GMTSUSR User (pointer) Required
+4 ; GMTSPKG Package Prefix (namespace) Optional
+5 ;
V2 ; Get Values and Pointers
+1 NEW GMTSU,GMTSPV
SET GMTSU=+($GET(GMTSUSR))
if +($GET(GMTSUSR))=0
SET GMTSU=+($GET(DUZ))
+2 NEW GMTSUSR
SET GMTSUSR=GMTSU
if '$LENGTH($$UNM^GMTSXAW3(+($GET(GMTSUSR))))
QUIT
+3 NEW GMTST,GMTSI,GMTSEC,GMTSLL,GMTSCALL,GMTSVAL
SET GMTSPKG=$GET(GMTSPKG)
SET GMTSVAL=1
+4 SET GMTSEC=0
SET GMTST="DEV;DIV;SYS;PKG;LOC;SRV;OTL;USR;CLS"
+5 FOR GMTSI=1:1
if '$LENGTH($PIECE(GMTST,";",GMTSI))
QUIT
SET GMTSLL=$PIECE(GMTST,";",GMTSI)
SET GMTSCALL=GMTSLL_"^GMTSXAW2"
DO GET
+6 QUIT
+7 ;
ALWD(X,Y) ; Get Allowed Entities for Parameter
+1 ;
+2 ; X Parameter (pointer) Required
+3 ; .Y Output Array for Allowed Entities Required
+4 ;
+5 NEW GMTSPIEN,GMTSNAM,GMTSMSG,GMTSALW,GMTSLST,GMTSENT,GMTSPRE,GMTSCT,GMTSAL
+6 SET GMTSAL=""
SET GMTSCT=0
SET GMTSPIEN=+($GET(X))
if X=0
QUIT
KILL ^TMP("DILIST",$JOB)
+7 SET GMTSNAM=$$PDN^GMTSXAW3(+GMTSPIEN)
if '$LENGTH(GMTSNAM)
QUIT
+8 DO LST^GMTSXAW3(GMTSPIEN,.GMTSALW)
+9 SET GMTSLST=0
FOR
SET GMTSLST=$ORDER(^TMP("DILIST",$JOB,"ID",GMTSLST))
if +GMTSLST=0
QUIT
Begin DoDot:1
+10 SET GMTSENT=+($GET(^TMP("DILIST",$JOB,"ID",GMTSLST,.02)))
+11 SET GMTSPRE=$$EAB^GMTSXAW3(+($GET(GMTSENT)))
if '$LENGTH(GMTSPRE)
QUIT
SET GMTSCT=GMTSCT+1
+12 SET Y(GMTSCT)=GMTSPRE_"^"_$$EFN^GMTSXAW3(+($GET(GMTSENT)))_"^"_$$ENM^GMTSXAW3(+($GET(GMTSENT)))_"^"_$$EMC^GMTSXAW3(+($GET(GMTSENT)))
+13 SET Y("B",GMTSPRE,GMTSCT)=$GET(Y(GMTSCT))
SET GMTSAL=GMTSAL_";"_$$UP^GMTSXA(GMTSPRE)
End DoDot:1
+14 KILL ^TMP("DILIST",$JOB)
SET Y("ALLOWABLE")=$$TRIM^GMTSXA(GMTSAL,";")
SET Y(0)=GMTSCT
+15 QUIT
+16 ; Parameter Entites
GET ; Get Entities
+1 SET GMTSLL=$GET(GMTSLL)
SET GMTSCALL=$GET(GMTSCALL)
if '$LENGTH($TEXT(@GMTSCALL))
QUIT
KILL GMTSPV
DO @GMTSCALL
+2 NEW GMTS,GMTSA,GMTSP,GMTSN,GMTSC,GMTSV
SET GMTS=0
+3 FOR
SET GMTS=$ORDER(GMTSPV(GMTS))
if +GMTS=0
QUIT
Begin DoDot:1
+4 SET GMTSA=$GET(GMTSPV(GMTS))
SET GMTSP=$PIECE(GMTSA,"^",2)
+5 if GMTSP'[";"
QUIT
SET GMTSN=$PIECE(GMTSA,"^",3)
if '$LENGTH(GMTSN)
QUIT
+6 SET GMTSC=+($GET(GMTSEC))
SET GMTSV=+($GET(GMTSVAL))+($GET(GMTSCHK))
+7 SET GMTSA=$PIECE(GMTSA,"^",1)
if $LENGTH(GMTSA)'=3
QUIT
+8 DO SET^GMTSXAW3(GMTSA,GMTSP,GMTSN,.GMTSALW,GMTSC,GMTSV)
End DoDot:1
+9 QUIT
TST ; Test entry
+1 NEW GMTSEC,GMTSI,GMTSLL,GMTSCALL,GMTSU,GMTSPV,GMTSPKG,GMTSN,GMTSC,GMTSA,GMTSP,GMTST,GMTSV
+2 SET GMTSEC=0
SET GMTSPKG="GMTS"
if '$LENGTH($GET(GMTST))
SET GMTST="DEV;DIV;SYS;PKG;LOC;SRV;OTL;USR;CLS"
SET GMTSPKG="GMTS"
+3 SET GMTSU=+($GET(GMTSUSR))
if GMTSU'>0
SET GMTSU=+($GET(DUZ))
if GMTSU'>0
QUIT
NEW GMTSUSR
SET GMTSUSR=GMTSU
+4 FOR GMTSI=1:1
if '$LENGTH($PIECE(GMTST,";",GMTSI))
QUIT
Begin DoDot:1
+5 SET GMTSLL=$PIECE(GMTST,";",GMTSI)
SET GMTSCALL=GMTSLL_"^GMTSXAW2"
+6 WRITE !!,GMTSLL,?8,$$EMC^GMTSXAW3($$ETI^GMTSXAW3(GMTSLL))
+7 if '$LENGTH($TEXT(@GMTSCALL))
QUIT
KILL GMTSPV
DO @GMTSCALL
if '$DATA(GMTSPV)
QUIT
+8 SET GMTSEC=0
if $LENGTH(GMTSLL)
SET GMTSEC=+($ORDER(GMTSALW("B",GMTSLL,0)))
+9 SET GMTSN="GMTSPV(0)"
SET GMTSC="GMTSPV("
+10 FOR
SET GMTSN=$QUERY(@GMTSN)
if GMTSN=""!(GMTSN'[GMTSC)
QUIT
WRITE !,GMTSN,"=",@GMTSN
+11 NEW GMTS
SET GMTS=0
FOR
SET GMTS=$ORDER(GMTSPV(GMTS))
if +GMTS=0
QUIT
Begin DoDot:2
+12 SET GMTSA=$GET(GMTSPV(GMTS))
SET GMTSP=$PIECE(GMTSA,"^",2)
+13 if GMTSP'[";"
QUIT
SET GMTSN=$PIECE(GMTSA,"^",3)
if '$LENGTH(GMTSN)
QUIT
+14 SET GMTSC=+($GET(GMTSEC))
SET GMTSV=+($GET(GMTSVAL))+($GET(GMTSCHK))
+15 SET GMTSA=$PIECE(GMTSA,"^",1)
if $LENGTH(GMTSA)'=3
QUIT
+16 DO SET^GMTSXAW3(GMTSA,GMTSP,GMTSN,.GMTSALW,GMTSC,GMTSV)
End DoDot:2
End DoDot:1
+17 QUIT
