Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: GMTSADH2

GMTSADH2.m

Go to the documentation of this file. 
  1. 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
  1.  ;                
  1.  ; External Reference
  1.  ;   DBIA    67  ^LAB(60,
  1.  ;   DBIA  2160  ^XUTL("OR"
  1.  ;   DBIA 10006  ^DIC
  1.  ;   DBIA  3137  EN^ORUS
  1.  ;   DBIA    67  ^LAB(60,
  1.  ;   DBIA   502  ^RAMIS(71,
  1.  ;   DBIA  2815  ^ICPT(
  1.  ;   DBIA  3450  ^GMRD(120.51,
  1.  ;   DBIA 10060  ^VA(200,
  1.  ;   DBIA  3148  ^PXD(811.9,
  1.  ;   DBIA  3451  ^TIU(8925.1,
  1.  ;   DBIA  1268  ^AUTTHF(
  1.  ;                
  1. CMPLIM ; Get Limits and Selection Items
  1.  N GMTSFUNC
  1.  I $P(CREC,U,5)="Y" D GETOCC^GMTSADH4 I $D(DIROUT)!($D(DUOUT)) Q
  1.  I $P(CREC,U,3)="Y" D GETIME^GMTSADH4 I $D(DIROUT)!($D(DUOUT)) Q
  1.  I $P(CREC,U,10)="Y" D GETHOSP^GMTSADH4 I $D(DIROUT)!($D(DUOUT)) Q
  1.  I $P(CREC,U,11)="Y" D GETICD^GMTSADH4 I $D(DIROUT)!($D(DUOUT)) Q
  1.  I $P(CREC,U,12)="Y" D GETPROV^GMTSADH4 I $D(DIROUT)!($D(DUOUT)) Q
  1.  I $P(CREC,U,14)="Y" D GETCPTM^GMTSADH4 I $D(DIROUT)!($D(DUOUT)) Q
  1.  D GETNAME^GMTSADH4 I $D(DIROUT)!$D(DUOUT) Q
  1.  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
  1.  Q
  1. SELECT ; Get Selection Items
  1.  N GMTSF,GMTSJ,GETSLQIT,GMI,DIC,X,Y,TEMP,SELCNT
  1.  S GMTSJ=$O(GMTSEG(SBS,0)),GMTSF=1
  1.  I GMTSJ W !,"Default selection items are   " D SHOWDEF
  1.  S SELCNT=$P(^GMT(142.1,$P(GMTSEG(SBS),U,2),1,1,0),U,2)
  1.  W ! W:GMTSJ "Push Return at the first prompt to select default items.",!
  1.  W "Select new "_$$FNAM^GMTSU(+SEL)_" items one at a time in the sequence",!,"you want them displayed. "
  1.  W "You may select " I SELCNT="" W "any number of items.",!
  1.  E  W "up to ",SELCNT," items.",!
  1.  F GMI=1:1 D GETSEL Q:$D(DIROUT)!(Y=-1)!$S(+SELCNT:(GMI'<+SELCNT),1:0)
  1.  I +SELCNT,(GMI'<+SELCNT) W !?2,$C(7),"MAXIMUM # OF ITEMS SELECTED.",!
  1.  Q
  1. GETSEL ; Updates GMTSEG array with Selections
  1.  ;
  1.  ; Using read for special processing when entering a "?".
  1.  ;
  1.  ; Get items from Selection Files #60, 71, 81, 120.51,
  1.  ; 200, 811.9, 8925.1 and 9999999.6,
  1.  ;
  1.  I SEL=8925.1 W !,"Select TITLE: "
  1.  E  W !,"Select "_$$FNAM^GMTSU(+SEL)_" Selection Item: "
  1.  R X:DTIME
  1.  I X="^^" S Y=0,DIROUT=1 Q
  1.  I X="^" S Y=-1,(GETSLQIT,ASKCPQIT)="" Q
  1.  I X["?" W:$O(GMTSEG(SBS,0)) !!,"Current Selection items are   " D SHOWDEF
  1.  S DIC(0)="EMQ",DIC=$$FLOC^GMTSU(+SEL)
  1.  I SEL=60 S DIC("S")="I $P(^(0),U,4)=""CH"",""BO""[$P(^(0),U,3)"
  1.  I SEL=9999999.64 D
  1.  . I $P($G(^GMT(142.1,+$P($G(GMTSEG(SBS)),U,2),0)),U,4)="GECH" D
  1.  . .S DIC("S")="I (($P(^(0),U,10)=""C"")&(+$P(^(0),U,11)'=1))&($P(^(0),"" "",1)=""GEC"")"
  1.  . E  D
  1.  ..S DIC("S")="I +$P(^(0),U,11)'=1"
  1.  ..I SEL=9999999.64 S DIC("W")="W ?47,$S($P(^(0),U,10)=""F"":""FACTOR"",$P(^(0),U,10)=""C"":""CATEGORY"")"
  1.  ;I SEL=9999999.64 S DIC("S")="I +$P(^(0),U,11)'=1"
  1.  ;I SEL=9999999.64 S DIC("W")="W ?47,$S($P(^(0),U,10)=""F"":""FACTOR"",$P(^(0),U,10)=""C"":""CATEGORY"")"
  1.  I SEL=811.9 S DIC("S")="I +$P(^(0),U,6)'=1"
  1.  I SEL=8925.1 S DIC("S")="I $P(^TIU(8925.1,+Y,0),U,4)=""DOC"",+$$ISA^TIULX(+Y,3)"
  1.  D ^DIC
  1.  I $D(DTOUT) S DIROUT=1
  1.  I $D(DIROUT) Q
  1.  I $D(DUOUT) S (GETSLQIT,ASKCPQIT)="" Q
  1.  I X["?" S Y="",GMI=GMI-1 Q
  1.  I X]"",Y=-1 S Y=0,GMI=GMI-1 Q  ;Continue selecting items when incorrect item entered
  1.  Q:Y=-1
  1.  I GMTSF&(X'="") K GMTSEG(SBS,SEL) S GMTSF=0,GMTSEG(SBS,SEL,0)=DIC
  1.  I DIC="^LAB(60,",'$L($P(^LAB(60,+Y,0),U,5)) D RESOLVE(+Y,.GMTSEG,.GMI) Q
  1.  S GMTSEG(SBS,SEL,GMI)=+Y
  1.  Q
  1. SHOWDEF ; Writes out loaded (default) selection items
  1.  N GMTSN,GMTSWHL
  1.  I $G(GMTSJ)']"" S GMTSJ=$O(GMTSEG(SBS,0)) I GMTSJ']"" W !!,"No SELECTION ITEMS chosen.",! Q
  1.  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)
  1.  Q
  1. RESOLVE(GMREF,GMTSEG,GMI) ; Call ORUS to resolve compound items
  1.  N SELCT,GMJ,GMHEAD,X,Y
  1.  K ^XUTL("OR",$J,"ORU"),^("ORV"),^("ORW")
  1.  ;   This subroutine will increment the variable GMI
  1.  ;   if any item are picked.  Need to decrement GMI 
  1.  ;   by one (1) so it works right
  1.  S GMI=GMI-1
  1.  ;   Don't exceed allowed # of selection
  1.  I +$G(SELCNT) S SELCT=SELCNT-GMI
  1.  S GMHEAD="-- "_$P($G(^LAB(60,+GMREF,.1)),U)_" --"
  1.  S ^XUTL("OR",$J,"GMTS",0)="LAB TEST^1^^0" D COMPILE(+GMREF)
  1.  I $P(^XUTL("OR",$J,"GMTS",0),U,4)'>0 D  Q
  1.  . K ^XUTL("OR",$J,"GMTS") W $C(7),"  INVALID TEST...Please choose another."
  1.  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"
  1.  S ORUS("A")="Select"_$S(+$P(ORUS(0),U,2):" 1 - "_+$P(ORUS(0),U,2),1:"")_" LAB TEST(s): "
  1.  S ORUS("B")=$S(+$P(ORUS(0),U,2):"1-"_+$P(ORUS(0),U,2),1:"ALL")
  1.  D EN^ORUS K ^XUTL("OR",$J,"GMTS"),^("ORU"),^("ORV"),^("ORW")
  1.  Q:+Y'>0  S GMJ=0 F  S GMJ=$O(Y(GMJ)) Q:GMJ'>0  D
  1.  . S GMI=GMI+1,GMTSEG(SBS,SEL,GMI)=+Y(GMJ)
  1.  Q
  1. COMPILE(GMTEST) ; Compile menu for ORUS call
  1.  N GMC,GMI,GMJ,GMROOT
  1.  S GMI=0 F  S GMI=$O(^LAB(60,GMTEST,2,GMI)) Q:GMI'>0  D
  1.  . S GMJ=+$G(^LAB(60,GMTEST,2,+GMI,0))
  1.  . S GMROOT=$G(^LAB(60,+GMJ,0))
  1.  . I $L($P(GMROOT,U,5)),("BO"[$P(GMROOT,U,3)) D
  1.  . . S GMC=+$P($G(^XUTL("OR",$J,"GMTS",0)),U,4)+1
  1.  . . S ^XUTL("OR",$J,"GMTS",GMJ,0)=$P(GMROOT,U),$P(^XUTL("OR",$J,"GMTS",0),U,4)=GMC
  1.  . E  D
  1.  . . D COMPILE(+$G(^LAB(60,GMTEST,2,GMI,0)))
  1.  Q
  1.  W !!?15,"Select the tests which you wish to include, in the",!?19,"sequence in which you wish them to appear."
  1.  W !!?((80-$L(GMHEAD))\2),GMHEAD,!
  1.  Q