- 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 Feb 18, 2025@23:23:23 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
