GMTSADH2 ; SLC/JER,KER - Ad Hoc Summary Driver ; 02/27/2002
;;2.7;Health Summary;**12,37,49,63,105**;Oct 20, 1995;Build 5
;
; External Reference
; DBIA 67 ^LAB(60,
; DBIA 2160 ^XUTL("OR"
; DBIA 10006 ^DIC
; DBIA 3137 EN^ORUS
; DBIA 67 ^LAB(60,
; DBIA 502 ^RAMIS(71,
; DBIA 2815 ^ICPT(
; DBIA 3450 ^GMRD(120.51,
; DBIA 10060 ^VA(200,
; DBIA 3148 ^PXD(811.9,
; DBIA 3451 ^TIU(8925.1,
; DBIA 1268 ^AUTTHF(
;
CMPLIM ; Get Limits and Selection Items
N GMTSFUNC
I $P(CREC,U,5)="Y" D GETOCC^GMTSADH4 I $D(DIROUT)!($D(DUOUT)) Q
I $P(CREC,U,3)="Y" D GETIME^GMTSADH4 I $D(DIROUT)!($D(DUOUT)) Q
I $P(CREC,U,10)="Y" D GETHOSP^GMTSADH4 I $D(DIROUT)!($D(DUOUT)) Q
I $P(CREC,U,11)="Y" D GETICD^GMTSADH4 I $D(DIROUT)!($D(DUOUT)) Q
I $P(CREC,U,12)="Y" D GETPROV^GMTSADH4 I $D(DIROUT)!($D(DUOUT)) Q
I $P(CREC,U,14)="Y" D GETCPTM^GMTSADH4 I $D(DIROUT)!($D(DUOUT)) Q
D GETNAME^GMTSADH4 I $D(DIROUT)!$D(DUOUT) Q
N SEL I $D(^GMT(142.1,$P(GMTSEG(SBS),U,2),1,1,0)) S SEL=$P(^(0),U,1) I SEL D SELECT
Q
SELECT ; Get Selection Items
N GMTSF,GMTSJ,GETSLQIT,GMI,DIC,X,Y,TEMP,SELCNT
S GMTSJ=$O(GMTSEG(SBS,0)),GMTSF=1
I GMTSJ W !,"Default selection items are " D SHOWDEF
S SELCNT=$P(^GMT(142.1,$P(GMTSEG(SBS),U,2),1,1,0),U,2)
W ! W:GMTSJ "Push Return at the first prompt to select default items.",!
W "Select new "_$$FNAM^GMTSU(+SEL)_" items one at a time in the sequence",!,"you want them displayed. "
W "You may select " I SELCNT="" W "any number of items.",!
E W "up to ",SELCNT," items.",!
F GMI=1:1 D GETSEL Q:$D(DIROUT)!(Y=-1)!$S(+SELCNT:(GMI'<+SELCNT),1:0)
I +SELCNT,(GMI'<+SELCNT) W !?2,$C(7),"MAXIMUM # OF ITEMS SELECTED.",!
Q
GETSEL ; Updates GMTSEG array with Selections
;
; Using read for special processing when entering a "?".
;
; Get items from Selection Files #60, 71, 81, 120.51,
; 200, 811.9, 8925.1 and 9999999.6,
;
I SEL=8925.1 W !,"Select TITLE: "
E W !,"Select "_$$FNAM^GMTSU(+SEL)_" Selection Item: "
R X:DTIME
I X="^^" S Y=0,DIROUT=1 Q
I X="^" S Y=-1,(GETSLQIT,ASKCPQIT)="" Q
I X["?" W:$O(GMTSEG(SBS,0)) !!,"Current Selection items are " D SHOWDEF
S DIC(0)="EMQ",DIC=$$FLOC^GMTSU(+SEL)
I SEL=60 S DIC("S")="I $P(^(0),U,4)=""CH"",""BO""[$P(^(0),U,3)"
I SEL=9999999.64 D
. I $P($G(^GMT(142.1,+$P($G(GMTSEG(SBS)),U,2),0)),U,4)="GECH" D
. .S DIC("S")="I (($P(^(0),U,10)=""C"")&(+$P(^(0),U,11)'=1))&($P(^(0),"" "",1)=""GEC"")"
. E D
..S DIC("S")="I +$P(^(0),U,11)'=1"
..I SEL=9999999.64 S DIC("W")="W ?47,$S($P(^(0),U,10)=""F"":""FACTOR"",$P(^(0),U,10)=""C"":""CATEGORY"")"
;I SEL=9999999.64 S DIC("S")="I +$P(^(0),U,11)'=1"
;I SEL=9999999.64 S DIC("W")="W ?47,$S($P(^(0),U,10)=""F"":""FACTOR"",$P(^(0),U,10)=""C"":""CATEGORY"")"
I SEL=811.9 S DIC("S")="I +$P(^(0),U,6)'=1"
I SEL=8925.1 S DIC("S")="I $P(^TIU(8925.1,+Y,0),U,4)=""DOC"",+$$ISA^TIULX(+Y,3)"
D ^DIC
I $D(DTOUT) S DIROUT=1
I $D(DIROUT) Q
I $D(DUOUT) S (GETSLQIT,ASKCPQIT)="" Q
I X["?" S Y="",GMI=GMI-1 Q
I X]"",Y=-1 S Y=0,GMI=GMI-1 Q ;Continue selecting items when incorrect item entered
Q:Y=-1
I GMTSF&(X'="") K GMTSEG(SBS,SEL) S GMTSF=0,GMTSEG(SBS,SEL,0)=DIC
I DIC="^LAB(60,",'$L($P(^LAB(60,+Y,0),U,5)) D RESOLVE(+Y,.GMTSEG,.GMI) Q
S GMTSEG(SBS,SEL,GMI)=+Y
Q
SHOWDEF ; Writes out loaded (default) selection items
N GMTSN,GMTSWHL
I $G(GMTSJ)']"" S GMTSJ=$O(GMTSEG(SBS,0)) I GMTSJ']"" W !!,"No SELECTION ITEMS chosen.",! Q
S GMTSN=0 F GMTSWHL=1:1 S GMTSN=$O(GMTSEG(SBS,+GMTSJ,GMTSN)) Q:GMTSN="" W:GMTSWHL>1 ! W ?30,$P(@(GMTSEG(SBS,GMTSJ,0)_GMTSEG(SBS,GMTSJ,GMTSN)_",0)"),U)
Q
RESOLVE(GMREF,GMTSEG,GMI) ; Call ORUS to resolve compound items
N SELCT,GMJ,GMHEAD,X,Y
K ^XUTL("OR",$J,"ORU"),^("ORV"),^("ORW")
; This subroutine will increment the variable GMI
; if any item are picked. Need to decrement GMI
; by one (1) so it works right
S GMI=GMI-1
; Don't exceed allowed # of selection
I +$G(SELCNT) S SELCT=SELCNT-GMI
S GMHEAD="-- "_$P($G(^LAB(60,+GMREF,.1)),U)_" --"
S ^XUTL("OR",$J,"GMTS",0)="LAB TEST^1^^0" D COMPILE(+GMREF)
I $P(^XUTL("OR",$J,"GMTS",0),U,4)'>0 D Q
. K ^XUTL("OR",$J,"GMTS") W $C(7)," INVALID TEST...Please choose another."
S ORUS="^XUTL(""OR"","_$J_",""GMTS"",",ORUS(0)="40MN"_$S(+$G(SELCT):U_$S($P(^XUTL("OR",$J,"GMTS",0),U,4)'<SELCT:SELCT,1:$P(^XUTL("OR",$J,"GMTS",0),U,4)),1:""),ORUS("T")="D HEADER^GMTSADH2"
S ORUS("A")="Select"_$S(+$P(ORUS(0),U,2):" 1 - "_+$P(ORUS(0),U,2),1:"")_" LAB TEST(s): "
S ORUS("B")=$S(+$P(ORUS(0),U,2):"1-"_+$P(ORUS(0),U,2),1:"ALL")
D EN^ORUS K ^XUTL("OR",$J,"GMTS"),^("ORU"),^("ORV"),^("ORW")
Q:+Y'>0 S GMJ=0 F S GMJ=$O(Y(GMJ)) Q:GMJ'>0 D
. S GMI=GMI+1,GMTSEG(SBS,SEL,GMI)=+Y(GMJ)
Q
COMPILE(GMTEST) ; Compile menu for ORUS call
N GMC,GMI,GMJ,GMROOT
S GMI=0 F S GMI=$O(^LAB(60,GMTEST,2,GMI)) Q:GMI'>0 D
. S GMJ=+$G(^LAB(60,GMTEST,2,+GMI,0))
. S GMROOT=$G(^LAB(60,+GMJ,0))
. I $L($P(GMROOT,U,5)),("BO"[$P(GMROOT,U,3)) D
. . S GMC=+$P($G(^XUTL("OR",$J,"GMTS",0)),U,4)+1
. . S ^XUTL("OR",$J,"GMTS",GMJ,0)=$P(GMROOT,U),$P(^XUTL("OR",$J,"GMTS",0),U,4)=GMC
. E D
. . D COMPILE(+$G(^LAB(60,GMTEST,2,GMI,0)))
Q
W !!?15,"Select the tests which you wish to include, in the",!?19,"sequence in which you wish them to appear."
W !!?((80-$L(GMHEAD))\2),GMHEAD,!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMTSADH2 5406 printed Oct 16, 2024@17:57:46 Page 2
GMTSADH2 ; SLC/JER,KER - Ad Hoc Summary Driver ; 02/27/2002
+1 ;;2.7;Health Summary;**12,37,49,63,105**;Oct 20, 1995;Build 5
+2 ;
+3 ; External Reference
+4 ; DBIA 67 ^LAB(60,
+5 ; DBIA 2160 ^XUTL("OR"
+6 ; DBIA 10006 ^DIC
+7 ; DBIA 3137 EN^ORUS
+8 ; DBIA 67 ^LAB(60,
+9 ; DBIA 502 ^RAMIS(71,
+10 ; DBIA 2815 ^ICPT(
+11 ; DBIA 3450 ^GMRD(120.51,
+12 ; DBIA 10060 ^VA(200,
+13 ; DBIA 3148 ^PXD(811.9,
+14 ; DBIA 3451 ^TIU(8925.1,
+15 ; DBIA 1268 ^AUTTHF(
+16 ;
CMPLIM ; Get Limits and Selection Items
+1 NEW GMTSFUNC
+2 IF $PIECE(CREC,U,5)="Y"
DO GETOCC^GMTSADH4
IF $DATA(DIROUT)!($DATA(DUOUT))
QUIT
+3 IF $PIECE(CREC,U,3)="Y"
DO GETIME^GMTSADH4
IF $DATA(DIROUT)!($DATA(DUOUT))
QUIT
+4 IF $PIECE(CREC,U,10)="Y"
DO GETHOSP^GMTSADH4
IF $DATA(DIROUT)!($DATA(DUOUT))
QUIT
+5 IF $PIECE(CREC,U,11)="Y"
DO GETICD^GMTSADH4
IF $DATA(DIROUT)!($DATA(DUOUT))
QUIT
+6 IF $PIECE(CREC,U,12)="Y"
DO GETPROV^GMTSADH4
IF $DATA(DIROUT)!($DATA(DUOUT))
QUIT
+7 IF $PIECE(CREC,U,14)="Y"
DO GETCPTM^GMTSADH4
IF $DATA(DIROUT)!($DATA(DUOUT))
QUIT
+8 DO GETNAME^GMTSADH4
IF $DATA(DIROUT)!$DATA(DUOUT)
QUIT
+9 NEW SEL
IF $DATA(^GMT(142.1,$PIECE(GMTSEG(SBS),U,2),1,1,0))
SET SEL=$PIECE(^(0),U,1)
IF SEL
DO SELECT
+10 QUIT
SELECT ; Get Selection Items
+1 NEW GMTSF,GMTSJ,GETSLQIT,GMI,DIC,X,Y,TEMP,SELCNT
+2 SET GMTSJ=$ORDER(GMTSEG(SBS,0))
SET GMTSF=1
+3 IF GMTSJ
WRITE !,"Default selection items are "
DO SHOWDEF
+4 SET SELCNT=$PIECE(^GMT(142.1,$PIECE(GMTSEG(SBS),U,2),1,1,0),U,2)
+5 WRITE !
if GMTSJ
WRITE "Push Return at the first prompt to select default items.",!
+6 WRITE "Select new "_$$FNAM^GMTSU(+SEL)_" items one at a time in the sequence",!,"you want them displayed. "
+7 WRITE "You may select "
IF SELCNT=""
WRITE "any number of items.",!
+8 IF '$TEST
WRITE "up to ",SELCNT," items.",!
+9 FOR GMI=1:1
DO GETSEL
if $DATA(DIROUT)!(Y=-1)!$SELECT(+SELCNT
QUIT
+10 IF +SELCNT
IF (GMI'<+SELCNT)
WRITE !?2,$CHAR(7),"MAXIMUM # OF ITEMS SELECTED.",!
+11 QUIT
GETSEL ; Updates GMTSEG array with Selections
+1 ;
+2 ; Using read for special processing when entering a "?".
+3 ;
+4 ; Get items from Selection Files #60, 71, 81, 120.51,
+5 ; 200, 811.9, 8925.1 and 9999999.6,
+6 ;
+7 IF SEL=8925.1
WRITE !,"Select TITLE: "
+8 IF '$TEST
WRITE !,"Select "_$$FNAM^GMTSU(+SEL)_" Selection Item: "
+9 READ X:DTIME
+10 IF X="^^"
SET Y=0
SET DIROUT=1
QUIT
+11 IF X="^"
SET Y=-1
SET (GETSLQIT,ASKCPQIT)=""
QUIT
+12 IF X["?"
if $ORDER(GMTSEG(SBS,0))
WRITE !!,"Current Selection items are "
DO SHOWDEF
+13 SET DIC(0)="EMQ"
SET DIC=$$FLOC^GMTSU(+SEL)
+14 IF SEL=60
SET DIC("S")="I $P(^(0),U,4)=""CH"",""BO""[$P(^(0),U,3)"
+15 IF SEL=9999999.64
Begin DoDot:1
+16 IF $PIECE($GET(^GMT(142.1,+$PIECE($GET(GMTSEG(SBS)),U,2),0)),U,4)="GECH"
Begin DoDot:2
+17 SET DIC("S")="I (($P(^(0),U,10)=""C"")&(+$P(^(0),U,11)'=1))&($P(^(0),"" "",1)=""GEC"")"
End DoDot:2
+18 IF '$TEST
Begin DoDot:2
+19 SET DIC("S")="I +$P(^(0),U,11)'=1"
+20 IF SEL=9999999.64
SET DIC("W")="W ?47,$S($P(^(0),U,10)=""F"":""FACTOR"",$P(^(0),U,10)=""C"":""CATEGORY"")"
End DoDot:2
End DoDot:1
+21 ;I SEL=9999999.64 S DIC("S")="I +$P(^(0),U,11)'=1"
+22 ;I SEL=9999999.64 S DIC("W")="W ?47,$S($P(^(0),U,10)=""F"":""FACTOR"",$P(^(0),U,10)=""C"":""CATEGORY"")"
+23 IF SEL=811.9
SET DIC("S")="I +$P(^(0),U,6)'=1"
+24 IF SEL=8925.1
SET DIC("S")="I $P(^TIU(8925.1,+Y,0),U,4)=""DOC"",+$$ISA^TIULX(+Y,3)"
+25 DO ^DIC
+26 IF $DATA(DTOUT)
SET DIROUT=1
+27 IF $DATA(DIROUT)
QUIT
+28 IF $DATA(DUOUT)
SET (GETSLQIT,ASKCPQIT)=""
QUIT
+29 IF X["?"
SET Y=""
SET GMI=GMI-1
QUIT
+30 ;Continue selecting items when incorrect item entered
IF X]""
IF Y=-1
SET Y=0
SET GMI=GMI-1
QUIT
+31 if Y=-1
QUIT
+32 IF GMTSF&(X'="")
KILL GMTSEG(SBS,SEL)
SET GMTSF=0
SET GMTSEG(SBS,SEL,0)=DIC
+33 IF DIC="^LAB(60,"
IF '$LENGTH($PIECE(^LAB(60,+Y,0),U,5))
DO RESOLVE(+Y,.GMTSEG,.GMI)
QUIT
+34 SET GMTSEG(SBS,SEL,GMI)=+Y
+35 QUIT
SHOWDEF ; Writes out loaded (default) selection items
+1 NEW GMTSN,GMTSWHL
+2 IF $GET(GMTSJ)']""
SET GMTSJ=$ORDER(GMTSEG(SBS,0))
IF GMTSJ']""
WRITE !!,"No SELECTION ITEMS chosen.",!
QUIT
+3 SET GMTSN=0
FOR GMTSWHL=1:1
SET GMTSN=$ORDER(GMTSEG(SBS,+GMTSJ,GMTSN))
if GMTSN=""
QUIT
if GMTSWHL>1
WRITE !
WRITE ?30,$PIECE(@(GMTSEG(SBS,GMTSJ,0)_GMTSEG(SBS,GMTSJ,GMTSN)_",0)"),U)
+4 QUIT
RESOLVE(GMREF,GMTSEG,GMI) ; Call ORUS to resolve compound items
+1 NEW SELCT,GMJ,GMHEAD,X,Y
+2 KILL ^XUTL("OR",$JOB,"ORU"),^("ORV"),^("ORW")
+3 ; This subroutine will increment the variable GMI
+4 ; if any item are picked. Need to decrement GMI
+5 ; by one (1) so it works right
+6 SET GMI=GMI-1
+7 ; Don't exceed allowed # of selection
+8 IF +$GET(SELCNT)
SET SELCT=SELCNT-GMI
+9 SET GMHEAD="-- "_$PIECE($GET(^LAB(60,+GMREF,.1)),U)_" --"
+10 SET ^XUTL("OR",$JOB,"GMTS",0)="LAB TEST^1^^0"
DO COMPILE(+GMREF)
+11 IF $PIECE(^XUTL("OR",$JOB,"GMTS",0),U,4)'>0
Begin DoDot:1
+12 KILL ^XUTL("OR",$JOB,"GMTS")
WRITE $CHAR(7)," INVALID TEST...Please choose another."
End DoDot:1
QUIT
+13 SET ORUS="^XUTL(""OR"","_$JOB_",""GMTS"","
SET ORUS(0)="40MN"_$SELECT(+$GET(SELCT):U_$SELECT($PIECE(^XUTL("OR",$JOB,"GMTS",0),U,4)'<SELCT:SELCT,1:$PIECE(^XUTL("OR",$JOB,"GMTS",0),U,4)),1:"")
SET ORUS("T")="D HEADER^GMTSADH2"
+14 SET ORUS("A")="Select"_$SELECT(+$PIECE(ORUS(0),U,2):" 1 - "_+$PIECE(ORUS(0),U,2),1:"")_" LAB TEST(s): "
+15 SET ORUS("B")=$SELECT(+$PIECE(ORUS(0),U,2):"1-"_+$PIECE(ORUS(0),U,2),1:"ALL")
+16 DO EN^ORUS
KILL ^XUTL("OR",$JOB,"GMTS"),^("ORU"),^("ORV"),^("ORW")
+17 if +Y'>0
QUIT
SET GMJ=0
FOR
SET GMJ=$ORDER(Y(GMJ))
if GMJ'>0
QUIT
Begin DoDot:1
+18 SET GMI=GMI+1
SET GMTSEG(SBS,SEL,GMI)=+Y(GMJ)
End DoDot:1
+19 QUIT
COMPILE(GMTEST) ; Compile menu for ORUS call
+1 NEW GMC,GMI,GMJ,GMROOT
+2 SET GMI=0
FOR
SET GMI=$ORDER(^LAB(60,GMTEST,2,GMI))
if GMI'>0
QUIT
Begin DoDot:1
+3 SET GMJ=+$GET(^LAB(60,GMTEST,2,+GMI,0))
+4 SET GMROOT=$GET(^LAB(60,+GMJ,0))
+5 IF $LENGTH($PIECE(GMROOT,U,5))
IF ("BO"[$PIECE(GMROOT,U,3))
Begin DoDot:2
+6 SET GMC=+$PIECE($GET(^XUTL("OR",$JOB,"GMTS",0)),U,4)+1
+7 SET ^XUTL("OR",$JOB,"GMTS",GMJ,0)=$PIECE(GMROOT,U)
SET $PIECE(^XUTL("OR",$JOB,"GMTS",0),U,4)=GMC
End DoDot:2
+8 IF '$TEST
Begin DoDot:2
+9 DO COMPILE(+$GET(^LAB(60,GMTEST,2,GMI,0)))
End DoDot:2
End DoDot:1
+10 QUIT
+1 WRITE !!?15,"Select the tests which you wish to include, in the",!?19,"sequence in which you wish them to appear."
+2 WRITE !!?((80-$LENGTH(GMHEAD))\2),GMHEAD,!
+3 QUIT
