GMTSADH5 ; SLC/DCM,KER - Health Summary Ad Hoc RPC's ;Nov 26, 2018@22:22
;;2.7;Health Summary;**36,35,37,49,63,110,116,125**;Oct 20, 1995;Build 15
;
; External References
; DBIA 1268 ^AUTTHF(
; DBIA 1268 ^AUTTHF("B"
; DBIA 67 ^LAB(60
; DBIA 3148 ^PXD(811.9
; DBIA 3059 ^TIU(8925.1
; DBIA 10006 ^DIC
; DBIA 2052 $$GET1^DID
; DBIA 3058 $$ISA^TIULX
; DBIA 6345 SEL^YTQGMTS
; DBIA 4543 SSET^PSN50P65
; DBIA 4662 SSET^PSS50P7
;
COMP(Y) ; Get ADHOC sub components (FILE 142.1)
;
; Y(i)=(1)I;IFN^(2)Component Name [Abb]^(3)Occ Limit^
; (4)Time Limit^(5)Header Name^(6)Hosp Loc Disp^
; (7)ICD Text Disp^(8)Prov Narr Disp^
; (9)CPT Modifier Disp^(10)Summary Order
;
N GMTSI,GMTSII,GMTSIFN,GMTSC,X,X1
S Y(1)=$O(^GMT(142,"B","GMTS HS ADHOC OPTION",0))
I 'Y(1) S Y(1)=-1 Q ; Error, no ADHOC type defined
S (GMTSC,GMTSI)=0,GMTSII=Y(1)
F S GMTSI=$O(^GMT(142,GMTSII,1,GMTSI)) Q:'GMTSI S X=^(GMTSI,0) D
. S GMTSIFN=$P(X,"^",2),X1=$G(^GMT(142.1,+GMTSIFN,0))
. Q:'$L(X1) Q:$P(X1,"^",6)="P" S GMTSC=GMTSC+1
. S Y(GMTSC)=GMTSI_";"_GMTSIFN
. S Y(GMTSC)=Y(GMTSC)_"^"_$P(X1,"^")_" ["_$P(X1,"^",4)_"]"
. S Y(GMTSC)=Y(GMTSC)_"^"_$S($P(X1,"^",5)="Y":$P(X,"^",3),1:"")
. S Y(GMTSC)=Y(GMTSC)_"^"_$S($P(X1,"^",3)="Y":$P(X,"^",4),1:"")
. S Y(GMTSC)=Y(GMTSC)_"^"_$S($L($P(X1,"^",9)):$P(X1,"^",9),1:$P(X,"^",5))
. S Y(GMTSC)=Y(GMTSC)_"^"_$S($P(X1,"^",10)="Y":$P(X,"^",6),1:"")
. S Y(GMTSC)=Y(GMTSC)_"^"_$S($P(X1,"^",11)="Y":$P(X,"^",7),1:"")
. S Y(GMTSC)=Y(GMTSC)_"^"_$S($P(X1,"^",12)="Y":$P(X,"^",8),1:"")
. S Y(GMTSC)=Y(GMTSC)_"^"_$P(X,"^")
Q
;
COMPSUB(Y,GMTSUB) ; Get subcomponents from a predefined ADHOC component
; GMTSUB=desired Adhoc subcomponent
; Y(i)=ifn of pointed to file entry^name
Q:'$G(GMTSUB)
N GMTSI,GMTSII,GMTSIFN,GMTSC,X,X1
S X=$O(^GMT(142,"B","GMTS HS ADHOC OPTION",0))
I 'X Q ; Error, no ADHOC type defined
S (GMTSC,GMTSI)=0,GMTSII=X
F S GMTSI=$O(^GMT(142,GMTSII,1,GMTSUB,1,GMTSI)) Q:'GMTSI S X=^(GMTSI,0) D
. S GMTSIFN=+X,X1=$P(X,";",2)
. I '$D(@("^"_X1_+X_",0)")) Q
. S X=@("^"_X1_+X_",0)"),GMTSC=GMTSC+1,Y(GMTSC)=GMTSIFN_"^"_$P(X,"^")
Q
;
FILES(Y,GMTSCP) ; Get Files to select from for a component
Q:'$G(GMTSCP) Q:'$D(^GMT(142.1,GMTSCP,1))
N GMTSGEC,GMTSI,GMTSC,X
S (GMTSGEC,GMTSI,GMTSC)=0
I $P($G(^GMT(142.1,GMTSCP,0)),U,4)="GECH" S GMTSGEC=1
F S GMTSI=$O(^GMT(142.1,GMTSCP,1,GMTSI)) Q:'GMTSI D
.S X=^(GMTSI,0),GMTSC=GMTSC+1 S:GMTSGEC=1 X=X_"G" ;naked reference refers to ^GMT(142.1,GMTSCP,1,GMTSI from previous line
.S Y(GMTSC)=GMTSI_"^"_$$FNAM^GMTSU(+X)_"^"_X
Q
;
FILESEL(GMTSRT,GMTSFI,GMTSFM,DIR) ; Get file entries
Q:'$G(GMTSFI)
K ^TMP("ORDATA",$J)
N GMTSI,GMTSJ,GMTSC,X,GMTSGL,GMTSGLB,GMTSCNT,HFC
S GMTSI=$G(GMTSFM),GMTSCNT=44,GMTSC=0,GMTSRT=$NA(^TMP("ORDATA",$J,1))
S:'$D(DIR) DIR=1
I GMTSFI=60 D Q
. F Q:GMTSC'<GMTSCNT S GMTSI=$O(^LAB(60,"B",GMTSI),DIR) Q:GMTSI="" S GMTSJ=0 F S GMTSJ=$O(^LAB(60,"B",GMTSI,GMTSJ)) Q:'GMTSJ D
. . I $D(^LAB(60,GMTSJ,0)) S X=^(0) I $P(X,"^",4)="CH","BO"[$P(X,"^",3) S GMTSC=GMTSC+1,^TMP("ORDATA",$J,1,GMTSC)=GMTSJ_"^"_GMTSI
I GMTSFI="9999999.64G" D Q
. F Q:GMTSC'<GMTSCNT S GMTSI=$O(^AUTTHF("B",GMTSI),DIR) Q:GMTSI="" S GMTSJ=0 F S GMTSJ=$O(^AUTTHF("B",GMTSI,GMTSJ)) Q:'GMTSJ I $D(^AUTTHF(GMTSJ,0)) S X=^(0) D
..;naked references below refers to ^AUTTHF(GMTSJ,0
..I (($P(^(0),U,10)="C")&(+$P(^(0),U,11)'=1))&($P(^(0)," ",1)="GEC") D
...S GMTSC=GMTSC+1
...S HFC=$S($P($G(X),U,10)="F":"Factor",$P($G(X),U,10)="C":"Category")
...S ^TMP("ORDATA",$J,1,GMTSC)=GMTSJ_U_GMTSI_" ("_HFC_")"
I GMTSFI=9999999.64 D Q
. F Q:GMTSC'<GMTSCNT S GMTSI=$O(^AUTTHF("B",GMTSI),DIR) Q:GMTSI="" S GMTSJ=0 F S GMTSJ=$O(^AUTTHF("B",GMTSI,GMTSJ)) Q:'GMTSJ I $D(^AUTTHF(GMTSJ,0)) S X=^(0) D
..I +$P(X,U,11)'=1 D
...S GMTSC=GMTSC+1
...S HFC=$S($P($G(X),U,10)="F":"Factor",$P($G(X),U,10)="C":"Category")
...S ^TMP("ORDATA",$J,1,GMTSC)=GMTSJ_U_GMTSI_" ("_HFC_")"
I GMTSFI=811.9 D Q
. F Q:GMTSC'<GMTSCNT S GMTSI=$O(^PXD(811.9,"B",GMTSI),DIR) Q:GMTSI="" S GMTSJ=0 F S GMTSJ=$O(^PXD(811.9,"B",GMTSI,GMTSJ)) Q:'GMTSJ I $D(^PXD(811.9,GMTSJ,0)) S X=^(0) D
. . I $P(X,"^",6)'=1 S GMTSC=GMTSC+1,^TMP("ORDATA",$J,1,GMTSC)=GMTSJ_"^"_GMTSI
I GMTSFI=8925.1 D Q
. F Q:GMTSC'<GMTSCNT S GMTSI=$O(^TIU(8925.1,"B",GMTSI),DIR) Q:GMTSI="" S GMTSJ=0 F S GMTSJ=$O(^TIU(8925.1,"B",GMTSI,GMTSJ)) Q:'GMTSJ I $D(^TIU(8925.1,GMTSJ,0)) S X=^(0) D
. . I $P(X,"^",4)="DOC",$$ISA^TIULX(GMTSJ,3) S GMTSC=GMTSC+1,^TMP("ORDATA",$J,1,GMTSC)=GMTSJ_"^"_GMTSI
; KDM 1/28/2014 GMTS*2.7*110
; Added code for the 81 file (CPT code) to list in logical sort order using the "BA" indexed file
I GMTSFI=81 D Q
. S GMTSGL=$$FCLR^GMTSU(+GMTSFI) I $L(GMTSGL) S GMTSGLB=$$FLOC^GMTSU(+GMTSFI)_"""BA"")" D
.. F Q:GMTSC'<GMTSCNT S GMTSI=$O(@GMTSGLB@(GMTSI),DIR) Q:GMTSI="" S GMTSJ=0 F S GMTSJ=$O(@GMTSGLB@(GMTSI,GMTSJ)) Q:'GMTSJ I $D(@GMTSGL@(GMTSJ,0)) S X=^(0) D
... S GMTSC=GMTSC+1,^TMP("ORDATA",$J,1,GMTSC)=GMTSJ_"^"_GMTSI
; use Mental Health API to return active, scoreable instruments
I GMTSFI=601.71 D Q
. N GMTSDIR S GMTSDIR=DIR
. D SEL^YTQGMTS(GMTSRT,GMTSI,GMTSCNT,GMTSDIR)
I GMTSFI=50.7 D Q
. D SSET^PSS50P7(GMTSC,GMTSCNT,GMTSI,DIR,"ORDATA")
I GMTSFI=50.605 D Q
. D SSET^PSN50P65(GMTSC,GMTSCNT,GMTSI,DIR,"ORDATA")
S GMTSGL=$$FCLR^GMTSU(+GMTSFI) I $L(GMTSGL) S GMTSGLB=$$FLOC^GMTSU(+GMTSFI)_"""B"")" D
. F Q:GMTSC'<GMTSCNT S GMTSI=$O(@GMTSGLB@(GMTSI),DIR) Q:GMTSI="" S GMTSJ=0 F S GMTSJ=$O(@GMTSGLB@(GMTSI,GMTSJ)) Q:'GMTSJ I $D(@GMTSGL@(GMTSJ,0)) S X=^(0) D
. . S GMTSC=GMTSC+1,^TMP("ORDATA",$J,1,GMTSC)=GMTSJ_"^"_GMTSI
Q
;
REPORT(GMTSEG,GMTSEGC,GMTSEGI,GMTSCPS,DFN) ; Build Report
; Uses array of Components passed in GMTSCPS()
; GMTSCPS(i)=array of subcomponents chosen,
; value is pointer at ^GMT(142,DA(1),1,DA)
Q:'$G(DFN)
N GMTSCNT,DIC,DIZ,DIW,DIWI,DIWT,DIWTC,X,GMTSI,GMTSJ,GMTSK,GMTSTYP,GMTSTITL
S X="GMTS HS ADHOC",DIC=142,DIZ(0)="ZF"
D ^DIC Q:'Y
S GMTSTYP=+Y,GMTSTITL="AD HOC",(GMTSJ,GMTSI)=0,GMTSEGC=$O(GMTSCPS(99999999),-1)
F S GMTSI=$O(GMTSCPS(GMTSI)) Q:'GMTSI D
. N GMTSREC,GMTSS2,GMTSSJ,GMTSEL
. S GMTSREC=^GMT(142,GMTSTYP,1,+GMTSCPS(GMTSI),0),GMTSJ=GMTSJ+1
. S GMTSEG(GMTSJ)=GMTSREC,GMTSEGI($P(GMTSREC,U,2))=GMTSJ,GMTSS2=0,GMTSSJ=GMTSJ
. S $P(GMTSEG(GMTSJ),"^",3)=$P(GMTSCPS(GMTSI),"^",2)
. S $P(GMTSEG(GMTSJ),"^",4)=$P(GMTSCPS(GMTSI),"^",3)
. I $L($P(GMTSCPS(GMTSI),"^",4)) S $P(GMTSEG(GMTSJ),"^",5)=$P(GMTSCPS(GMTSI),"^",4)
. I $L($P(GMTSCPS(GMTSI),"^",5)) S $P(GMTSEG(GMTSJ),"^",6)=$P(GMTSCPS(GMTSI),"^",5)
. S $P(GMTSEG(GMTSJ),"^",7)=$P(GMTSCPS(GMTSI),"^",6)
. I $L($P(GMTSCPS(GMTSI),"^",7)) S $P(GMTSEG(GMTSJ),"^",8)=$P(GMTSCPS(GMTSI),"^",7)
. S (GMTSCNT,GMTSK)=0
. F S GMTSK=$O(GMTSCPS(GMTSK)) Q:'GMTSK D
. .I $P($G(GMTSCPS(GMTSK)),U,9)="9999999.64G" S $P(GMTSCPS(GMTSK),U,9)="9999999.64"
. .I +GMTSCPS(GMTSI)=+GMTSCPS(GMTSK),$P(GMTSCPS(GMTSK),"^",9),$P(GMTSCPS(GMTSK),"^",10) D
. . . S GMTSCNT=GMTSCNT+1
. . . S:'$D(GMTSEG(GMTSJ,$P(GMTSCPS(GMTSK),"^",9),0)) GMTSEG(GMTSJ,$P(GMTSCPS(GMTSK),"^",9),0)=$$GET1^DID($P(GMTSCPS(GMTSK),"^",9),,,"GLOBAL NAME")
. . . S GMTSEG(GMTSJ,$P(GMTSCPS(GMTSK),"^",9),GMTSCNT)=$P(GMTSCPS(GMTSK),"^",10)
. . . K GMTSCPS(GMTSK)
Q
;
SUBITEM(Y,GMTSTEST) ; Get Subitems for a Test Panel
Q:'$G(GMTSTEST) N GMTSCNT S GMTSCNT=0
I '$L($P(^LAB(60,GMTSTEST,0),"^",5)),$O(^LAB(60,GMTSTEST,2,0)) D COMPILE(GMTSTEST,GMTSCNT)
Q
;
COMPILE(GMTSTEST,GMTSCNT) ; Expand lab panels
N GMTSI,GMTSJ,GMTSRT S GMTSI=0
F S GMTSI=$O(^LAB(60,GMTSTEST,2,GMTSI)) Q:GMTSI'>0 D
. S GMTSJ=+$G(^LAB(60,GMTSTEST,2,+GMTSI,0))
. S GMTSRT=$G(^LAB(60,+GMTSJ,0))
. I $L($P(GMTSRT,U,5)),("BO"[$P(GMTSRT,U,3)) D
. . S GMTSCNT=GMTSCNT+1
. . S Y(GMTSCNT)=+GMTSJ_"^"_GMTSRT
. E D
. . D COMPILE(+$G(^LAB(60,GMTSTEST,2,GMTSI,0)),GMTSCNT)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMTSADH5 7944 printed Dec 13, 2024@01:57:01 Page 2
GMTSADH5 ; SLC/DCM,KER - Health Summary Ad Hoc RPC's ;Nov 26, 2018@22:22
+1 ;;2.7;Health Summary;**36,35,37,49,63,110,116,125**;Oct 20, 1995;Build 15
+2 ;
+3 ; External References
+4 ; DBIA 1268 ^AUTTHF(
+5 ; DBIA 1268 ^AUTTHF("B"
+6 ; DBIA 67 ^LAB(60
+7 ; DBIA 3148 ^PXD(811.9
+8 ; DBIA 3059 ^TIU(8925.1
+9 ; DBIA 10006 ^DIC
+10 ; DBIA 2052 $$GET1^DID
+11 ; DBIA 3058 $$ISA^TIULX
+12 ; DBIA 6345 SEL^YTQGMTS
+13 ; DBIA 4543 SSET^PSN50P65
+14 ; DBIA 4662 SSET^PSS50P7
+15 ;
COMP(Y) ; Get ADHOC sub components (FILE 142.1)
+1 ;
+2 ; Y(i)=(1)I;IFN^(2)Component Name [Abb]^(3)Occ Limit^
+3 ; (4)Time Limit^(5)Header Name^(6)Hosp Loc Disp^
+4 ; (7)ICD Text Disp^(8)Prov Narr Disp^
+5 ; (9)CPT Modifier Disp^(10)Summary Order
+6 ;
+7 NEW GMTSI,GMTSII,GMTSIFN,GMTSC,X,X1
+8 SET Y(1)=$ORDER(^GMT(142,"B","GMTS HS ADHOC OPTION",0))
+9 ; Error, no ADHOC type defined
IF 'Y(1)
SET Y(1)=-1
QUIT
+10 SET (GMTSC,GMTSI)=0
SET GMTSII=Y(1)
+11 FOR
SET GMTSI=$ORDER(^GMT(142,GMTSII,1,GMTSI))
if 'GMTSI
QUIT
SET X=^(GMTSI,0)
Begin DoDot:1
+12 SET GMTSIFN=$PIECE(X,"^",2)
SET X1=$GET(^GMT(142.1,+GMTSIFN,0))
+13 if '$LENGTH(X1)
QUIT
if $PIECE(X1,"^",6)="P"
QUIT
SET GMTSC=GMTSC+1
+14 SET Y(GMTSC)=GMTSI_";"_GMTSIFN
+15 SET Y(GMTSC)=Y(GMTSC)_"^"_$PIECE(X1,"^")_" ["_$PIECE(X1,"^",4)_"]"
+16 SET Y(GMTSC)=Y(GMTSC)_"^"_$SELECT($PIECE(X1,"^",5)="Y":$PIECE(X,"^",3),1:"")
+17 SET Y(GMTSC)=Y(GMTSC)_"^"_$SELECT($PIECE(X1,"^",3)="Y":$PIECE(X,"^",4),1:"")
+18 SET Y(GMTSC)=Y(GMTSC)_"^"_$SELECT($LENGTH($PIECE(X1,"^",9)):$PIECE(X1,"^",9),1:$PIECE(X,"^",5))
+19 SET Y(GMTSC)=Y(GMTSC)_"^"_$SELECT($PIECE(X1,"^",10)="Y":$PIECE(X,"^",6),1:"")
+20 SET Y(GMTSC)=Y(GMTSC)_"^"_$SELECT($PIECE(X1,"^",11)="Y":$PIECE(X,"^",7),1:"")
+21 SET Y(GMTSC)=Y(GMTSC)_"^"_$SELECT($PIECE(X1,"^",12)="Y":$PIECE(X,"^",8),1:"")
+22 SET Y(GMTSC)=Y(GMTSC)_"^"_$PIECE(X,"^")
End DoDot:1
+23 QUIT
+24 ;
COMPSUB(Y,GMTSUB) ; Get subcomponents from a predefined ADHOC component
+1 ; GMTSUB=desired Adhoc subcomponent
+2 ; Y(i)=ifn of pointed to file entry^name
+3 if '$GET(GMTSUB)
QUIT
+4 NEW GMTSI,GMTSII,GMTSIFN,GMTSC,X,X1
+5 SET X=$ORDER(^GMT(142,"B","GMTS HS ADHOC OPTION",0))
+6 ; Error, no ADHOC type defined
IF 'X
QUIT
+7 SET (GMTSC,GMTSI)=0
SET GMTSII=X
+8 FOR
SET GMTSI=$ORDER(^GMT(142,GMTSII,1,GMTSUB,1,GMTSI))
if 'GMTSI
QUIT
SET X=^(GMTSI,0)
Begin DoDot:1
+9 SET GMTSIFN=+X
SET X1=$PIECE(X,";",2)
+10 IF '$DATA(@("^"_X1_+X_",0)"))
QUIT
+11 SET X=@("^"_X1_+X_",0)")
SET GMTSC=GMTSC+1
SET Y(GMTSC)=GMTSIFN_"^"_$PIECE(X,"^")
End DoDot:1
+12 QUIT
+13 ;
FILES(Y,GMTSCP) ; Get Files to select from for a component
+1 if '$GET(GMTSCP)
QUIT
if '$DATA(^GMT(142.1,GMTSCP,1))
QUIT
+2 NEW GMTSGEC,GMTSI,GMTSC,X
+3 SET (GMTSGEC,GMTSI,GMTSC)=0
+4 IF $PIECE($GET(^GMT(142.1,GMTSCP,0)),U,4)="GECH"
SET GMTSGEC=1
+5 FOR
SET GMTSI=$ORDER(^GMT(142.1,GMTSCP,1,GMTSI))
if 'GMTSI
QUIT
Begin DoDot:1
+6 ;naked reference refers to ^GMT(142.1,GMTSCP,1,GMTSI from previous line
SET X=^(GMTSI,0)
SET GMTSC=GMTSC+1
if GMTSGEC=1
SET X=X_"G"
+7 SET Y(GMTSC)=GMTSI_"^"_$$FNAM^GMTSU(+X)_"^"_X
End DoDot:1
+8 QUIT
+9 ;
FILESEL(GMTSRT,GMTSFI,GMTSFM,DIR) ; Get file entries
+1 if '$GET(GMTSFI)
QUIT
+2 KILL ^TMP("ORDATA",$JOB)
+3 NEW GMTSI,GMTSJ,GMTSC,X,GMTSGL,GMTSGLB,GMTSCNT,HFC
+4 SET GMTSI=$GET(GMTSFM)
SET GMTSCNT=44
SET GMTSC=0
SET GMTSRT=$NAME(^TMP("ORDATA",$JOB,1))
+5 if '$DATA(DIR)
SET DIR=1
+6 IF GMTSFI=60
Begin DoDot:1
+7 FOR
if GMTSC'<GMTSCNT
QUIT
SET GMTSI=$ORDER(^LAB(60,"B",GMTSI),DIR)
if GMTSI=""
QUIT
SET GMTSJ=0
FOR
SET GMTSJ=$ORDER(^LAB(60,"B",GMTSI,GMTSJ))
if 'GMTSJ
QUIT
Begin DoDot:2
+8 IF $DATA(^LAB(60,GMTSJ,0))
SET X=^(0)
IF $PIECE(X,"^",4)="CH"
IF "BO"[$PIECE(X,"^",3)
SET GMTSC=GMTSC+1
SET ^TMP("ORDATA",$JOB,1,GMTSC)=GMTSJ_"^"_GMTSI
End DoDot:2
End DoDot:1
QUIT
+9 IF GMTSFI="9999999.64G"
Begin DoDot:1
+10 FOR
if GMTSC'<GMTSCNT
QUIT
SET GMTSI=$ORDER(^AUTTHF("B",GMTSI),DIR)
if GMTSI=""
QUIT
SET GMTSJ=0
FOR
SET GMTSJ=$ORDER(^AUTTHF("B",GMTSI,GMTSJ))
if 'GMTSJ
QUIT
IF $DATA(^AUTTHF(GMTSJ,0))
SET X=^(0)
Begin DoDot:2
+11 ;naked references below refers to ^AUTTHF(GMTSJ,0
+12 IF (($PIECE(^(0),U,10)="C")&(+$PIECE(^(0),U,11)'=1))&($PIECE(^(0)," ",1)="GEC")
Begin DoDot:3
+13 SET GMTSC=GMTSC+1
+14 SET HFC=$SELECT($PIECE($GET(X),U,10)="F":"Factor",$PIECE($GET(X),U,10)="C":"Category")
+15 SET ^TMP("ORDATA",$JOB,1,GMTSC)=GMTSJ_U_GMTSI_" ("_HFC_")"
End DoDot:3
End DoDot:2
End DoDot:1
QUIT
+16 IF GMTSFI=9999999.64
Begin DoDot:1
+17 FOR
if GMTSC'<GMTSCNT
QUIT
SET GMTSI=$ORDER(^AUTTHF("B",GMTSI),DIR)
if GMTSI=""
QUIT
SET GMTSJ=0
FOR
SET GMTSJ=$ORDER(^AUTTHF("B",GMTSI,GMTSJ))
if 'GMTSJ
QUIT
IF $DATA(^AUTTHF(GMTSJ,0))
SET X=^(0)
Begin DoDot:2
+18 IF +$PIECE(X,U,11)'=1
Begin DoDot:3
+19 SET GMTSC=GMTSC+1
+20 SET HFC=$SELECT($PIECE($GET(X),U,10)="F":"Factor",$PIECE($GET(X),U,10)="C":"Category")
+21 SET ^TMP("ORDATA",$JOB,1,GMTSC)=GMTSJ_U_GMTSI_" ("_HFC_")"
End DoDot:3
End DoDot:2
End DoDot:1
QUIT
+22 IF GMTSFI=811.9
Begin DoDot:1
+23 FOR
if GMTSC'<GMTSCNT
QUIT
SET GMTSI=$ORDER(^PXD(811.9,"B",GMTSI),DIR)
if GMTSI=""
QUIT
SET GMTSJ=0
FOR
SET GMTSJ=$ORDER(^PXD(811.9,"B",GMTSI,GMTSJ))
if 'GMTSJ
QUIT
IF $DATA(^PXD(811.9,GMTSJ,0))
SET X=^(0)
Begin DoDot:2
+24 IF $PIECE(X,"^",6)'=1
SET GMTSC=GMTSC+1
SET ^TMP("ORDATA",$JOB,1,GMTSC)=GMTSJ_"^"_GMTSI
End DoDot:2
End DoDot:1
QUIT
+25 IF GMTSFI=8925.1
Begin DoDot:1
+26 FOR
if GMTSC'<GMTSCNT
QUIT
SET GMTSI=$ORDER(^TIU(8925.1,"B",GMTSI),DIR)
if GMTSI=""
QUIT
SET GMTSJ=0
FOR
SET GMTSJ=$ORDER(^TIU(8925.1,"B",GMTSI,GMTSJ))
if 'GMTSJ
QUIT
IF $DATA(^TIU(8925.1,GMTSJ,0))
SET X=^(0)
Begin DoDot:2
+27 IF $PIECE(X,"^",4)="DOC"
IF $$ISA^TIULX(GMTSJ,3)
SET GMTSC=GMTSC+1
SET ^TMP("ORDATA",$JOB,1,GMTSC)=GMTSJ_"^"_GMTSI
End DoDot:2
End DoDot:1
QUIT
+28 ; KDM 1/28/2014 GMTS*2.7*110
+29 ; Added code for the 81 file (CPT code) to list in logical sort order using the "BA" indexed file
+30 IF GMTSFI=81
Begin DoDot:1
+31 SET GMTSGL=$$FCLR^GMTSU(+GMTSFI)
IF $LENGTH(GMTSGL)
SET GMTSGLB=$$FLOC^GMTSU(+GMTSFI)_"""BA"")"
Begin DoDot:2
+32 FOR
if GMTSC'<GMTSCNT
QUIT
SET GMTSI=$ORDER(@GMTSGLB@(GMTSI),DIR)
if GMTSI=""
QUIT
SET GMTSJ=0
FOR
SET GMTSJ=$ORDER(@GMTSGLB@(GMTSI,GMTSJ))
if 'GMTSJ
QUIT
IF $DATA(@GMTSGL@(GMTSJ,0))
SET X=^(0)
Begin DoDot:3
+33 SET GMTSC=GMTSC+1
SET ^TMP("ORDATA",$JOB,1,GMTSC)=GMTSJ_"^"_GMTSI
End DoDot:3
End DoDot:2
End DoDot:1
QUIT
+34 ; use Mental Health API to return active, scoreable instruments
+35 IF GMTSFI=601.71
Begin DoDot:1
+36 NEW GMTSDIR
SET GMTSDIR=DIR
+37 DO SEL^YTQGMTS(GMTSRT,GMTSI,GMTSCNT,GMTSDIR)
End DoDot:1
QUIT
+38 IF GMTSFI=50.7
Begin DoDot:1
+39 DO SSET^PSS50P7(GMTSC,GMTSCNT,GMTSI,DIR,"ORDATA")
End DoDot:1
QUIT
+40 IF GMTSFI=50.605
Begin DoDot:1
+41 DO SSET^PSN50P65(GMTSC,GMTSCNT,GMTSI,DIR,"ORDATA")
End DoDot:1
QUIT
+42 SET GMTSGL=$$FCLR^GMTSU(+GMTSFI)
IF $LENGTH(GMTSGL)
SET GMTSGLB=$$FLOC^GMTSU(+GMTSFI)_"""B"")"
Begin DoDot:1
+43 FOR
if GMTSC'<GMTSCNT
QUIT
SET GMTSI=$ORDER(@GMTSGLB@(GMTSI),DIR)
if GMTSI=""
QUIT
SET GMTSJ=0
FOR
SET GMTSJ=$ORDER(@GMTSGLB@(GMTSI,GMTSJ))
if 'GMTSJ
QUIT
IF $DATA(@GMTSGL@(GMTSJ,0))
SET X=^(0)
Begin DoDot:2
+44 SET GMTSC=GMTSC+1
SET ^TMP("ORDATA",$JOB,1,GMTSC)=GMTSJ_"^"_GMTSI
End DoDot:2
End DoDot:1
+45 QUIT
+46 ;
REPORT(GMTSEG,GMTSEGC,GMTSEGI,GMTSCPS,DFN) ; Build Report
+1 ; Uses array of Components passed in GMTSCPS()
+2 ; GMTSCPS(i)=array of subcomponents chosen,
+3 ; value is pointer at ^GMT(142,DA(1),1,DA)
+4 if '$GET(DFN)
QUIT
+5 NEW GMTSCNT,DIC,DIZ,DIW,DIWI,DIWT,DIWTC,X,GMTSI,GMTSJ,GMTSK,GMTSTYP,GMTSTITL
+6 SET X="GMTS HS ADHOC"
SET DIC=142
SET DIZ(0)="ZF"
+7 DO ^DIC
if 'Y
QUIT
+8 SET GMTSTYP=+Y
SET GMTSTITL="AD HOC"
SET (GMTSJ,GMTSI)=0
SET GMTSEGC=$ORDER(GMTSCPS(99999999),-1)
+9 FOR
SET GMTSI=$ORDER(GMTSCPS(GMTSI))
if 'GMTSI
QUIT
Begin DoDot:1
+10 NEW GMTSREC,GMTSS2,GMTSSJ,GMTSEL
+11 SET GMTSREC=^GMT(142,GMTSTYP,1,+GMTSCPS(GMTSI),0)
SET GMTSJ=GMTSJ+1
+12 SET GMTSEG(GMTSJ)=GMTSREC
SET GMTSEGI($PIECE(GMTSREC,U,2))=GMTSJ
SET GMTSS2=0
SET GMTSSJ=GMTSJ
+13 SET $PIECE(GMTSEG(GMTSJ),"^",3)=$PIECE(GMTSCPS(GMTSI),"^",2)
+14 SET $PIECE(GMTSEG(GMTSJ),"^",4)=$PIECE(GMTSCPS(GMTSI),"^",3)
+15 IF $LENGTH($PIECE(GMTSCPS(GMTSI),"^",4))
SET $PIECE(GMTSEG(GMTSJ),"^",5)=$PIECE(GMTSCPS(GMTSI),"^",4)
+16 IF $LENGTH($PIECE(GMTSCPS(GMTSI),"^",5))
SET $PIECE(GMTSEG(GMTSJ),"^",6)=$PIECE(GMTSCPS(GMTSI),"^",5)
+17 SET $PIECE(GMTSEG(GMTSJ),"^",7)=$PIECE(GMTSCPS(GMTSI),"^",6)
+18 IF $LENGTH($PIECE(GMTSCPS(GMTSI),"^",7))
SET $PIECE(GMTSEG(GMTSJ),"^",8)=$PIECE(GMTSCPS(GMTSI),"^",7)
+19 SET (GMTSCNT,GMTSK)=0
+20 FOR
SET GMTSK=$ORDER(GMTSCPS(GMTSK))
if 'GMTSK
QUIT
Begin DoDot:2
+21 IF $PIECE($GET(GMTSCPS(GMTSK)),U,9)="9999999.64G"
SET $PIECE(GMTSCPS(GMTSK),U,9)="9999999.64"
+22 IF +GMTSCPS(GMTSI)=+GMTSCPS(GMTSK)
IF $PIECE(GMTSCPS(GMTSK),"^",9)
IF $PIECE(GMTSCPS(GMTSK),"^",10)
Begin DoDot:3
+23 SET GMTSCNT=GMTSCNT+1
+24 if '$DATA(GMTSEG(GMTSJ,$PIECE(GMTSCPS(GMTSK),"^",9),0))
SET GMTSEG(GMTSJ,$PIECE(GMTSCPS(GMTSK),"^",9),0)=$$GET1^DID($PIECE(GMTSCPS(GMTSK),"^",9),,,"GLOBAL NAME")
+25 SET GMTSEG(GMTSJ,$PIECE(GMTSCPS(GMTSK),"^",9),GMTSCNT)=$PIECE(GMTSCPS(GMTSK),"^",10)
+26 KILL GMTSCPS(GMTSK)
End DoDot:3
End DoDot:2
End DoDot:1
+27 QUIT
+28 ;
SUBITEM(Y,GMTSTEST) ; Get Subitems for a Test Panel
+1 if '$GET(GMTSTEST)
QUIT
NEW GMTSCNT
SET GMTSCNT=0
+2 IF '$LENGTH($PIECE(^LAB(60,GMTSTEST,0),"^",5))
IF $ORDER(^LAB(60,GMTSTEST,2,0))
DO COMPILE(GMTSTEST,GMTSCNT)
+3 QUIT
+4 ;
COMPILE(GMTSTEST,GMTSCNT) ; Expand lab panels
+1 NEW GMTSI,GMTSJ,GMTSRT
SET GMTSI=0
+2 FOR
SET GMTSI=$ORDER(^LAB(60,GMTSTEST,2,GMTSI))
if GMTSI'>0
QUIT
Begin DoDot:1
+3 SET GMTSJ=+$GET(^LAB(60,GMTSTEST,2,+GMTSI,0))
+4 SET GMTSRT=$GET(^LAB(60,+GMTSJ,0))
+5 IF $LENGTH($PIECE(GMTSRT,U,5))
IF ("BO"[$PIECE(GMTSRT,U,3))
Begin DoDot:2
+6 SET GMTSCNT=GMTSCNT+1
+7 SET Y(GMTSCNT)=+GMTSJ_"^"_GMTSRT
End DoDot:2
+8 IF '$TEST
Begin DoDot:2
+9 DO COMPILE(+$GET(^LAB(60,GMTSTEST,2,GMTSI,0)),GMTSCNT)
End DoDot:2
End DoDot:1
+10 QUIT
