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

TIUHSL.m

Go to the documentation of this file. 
  1. TIUHSL ;;SLC/AJB,AGP - Main List Manager for TIUHS ROutines; 10/25/02
  1.  ;;1.0;TEXT INTEGRATION UTILITIES;**135**;Jun 20, 1997
  1. EN ; -- main entry point for TIUHSLSM
  1.  N CENTER,GMTSHDR,GMTSN,POP,VALMBCK,VALMSG,X
  1.  D EN^VALM("TIUHSLSM")
  1.  Q
  1.  ;
  1. HDR ; -- header code
  1.  N CENTER,HEADER,TITLE,VALMHDR,VALMSG
  1.  S TITLE="TIU Health Summary Object."
  1.  S CENTER=(IOM-$L(TITLE))/2
  1.  S HEADER=$$SETSTR^VALM1(TITLE,"",CENTER,$L(TITLE))
  1.  S VALMHDR(1)=HEADER
  1.  ;display help option
  1.  S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"
  1.  D XQORM
  1.  Q
  1.  ;
  1. INIT ; -- init variables and list array
  1.  N DIS,IEN,LINE,HSNAME,HSOBIEN,HSTYPE,NAME,NUM,TMP
  1.  K TMP($J)
  1.  S (LINE,NUM)=0
  1.  ;
  1.  ;searches file 8925.1 for hs obj and places into temp array
  1.  S IEN="" F  S IEN=$O(^TIU(8925.1,"AT","O",IEN)) Q:IEN=""  I $G(^TIU(8925.1,IEN,9))["GMTSOBJ" D
  1.  .S NAME=$P($G(^TIU(8925.1,IEN,0)),U)
  1.  .S HSOBIEN=$P($P($G(^TIU(8925.1,IEN,9)),",",2),")")
  1.  .S HSTYPE=$P($G(^GMT(142.5,HSOBIEN,0)),U,3)
  1.  .I $G(HSTYPE)'=""&($D(^GMT(142.5,HSOBIEN,0))>0) S HSTYPE=$$GET1^DIQ(142,HSTYPE,.01)
  1.  .I $G(HSTYPE)="" S HSTYPE="No Health Summary Type Found"
  1.  .S TMP($J,NAME)=IEN_U_HSTYPE
  1.  ;
  1.  ;sort temp array in alpha order and display output
  1.  S NAME=""
  1.  F  S NAME=$O(TMP($J,NAME)) Q:NAME=""  D
  1.  .S IEN=$P(TMP($J,NAME),U)
  1.  .S HSNAME=$P(TMP($J,NAME),U,2)
  1.  .S LINE=LINE+1
  1.  .S NUM=NUM+1
  1.  .;
  1.  .;set output display
  1.  .S DIS=$$SETSTR^VALM1(NUM,"",1,5)
  1.  .S DIS=$$SETSTR^VALM1(NAME,DIS,6,37)
  1.  .S DIS=$$SETSTR^VALM1(HSNAME,DIS,40,40)
  1.  .D SET^VALM10(LINE,DIS,IEN)
  1.  S VALMCNT=LINE
  1.  K TMP($J)
  1.  Q
  1.  ;
  1. CREATE ;
  1.  ;call to tiuhsobj
  1.  D CLEAN^VALM10
  1.  D FULL^VALM1
  1.  D CREATE^TIUHSOBJ
  1.  D INIT
  1.  S VALMBCK="R"
  1.  Q
  1. EDIT ;
  1.  ;lst man function to allow user to select protocal and line item in one command i.e. det=3
  1.  ;
  1.  N HSOBJ,SEL,TRUE,Y
  1.  S TRUE=0
  1.  S SEL=$P(XQORNOD(0),"=",2)
  1.  I $A($E(SEL,$L(SEL)))<48!($A($E(SEL,$L(SEL)))>57) S SEL=$E(SEL,1,$L(SEL)-1)
  1.  I SEL["," D  Q
  1.  .W $C(7),!,"Only one item number allowed." H 2
  1.  .S VALMBCK="R"
  1.  I SEL="" D
  1.  .W !,"Select Entry:  (1-"_VALMLST_") " R SEL:DTIME
  1.  .I '$T!(SEL=U)!(SEL="") S TRUE=1
  1.  I TRUE=1 Q
  1.  I 'SEL!(SEL>VALMCNT)!('$D(@VALMAR@("IDX",SEL))) D  Q
  1.  .W $C(7),!,SEL_" is not a valid item number." H 2
  1.  .S VALMBCK="R"
  1.  S Y=$O(@VALMAR@("IDX",SEL,""))
  1.  D CLEAN^VALM10
  1.  D EN^TIUHSV(+Y)
  1.  D CLEAN^VALM10
  1.  D INIT
  1.  Q
  1.  ;
  1. EDITHSO ;
  1.  ;lst man function to allow user to select protocal and line item in one command i.e. det=3
  1.  ;
  1.  N HSOBJ,IEN,OBJMETD,SEL,TRUE,Y,YESNO
  1.  S TRUE=0
  1.  S SEL=$P(XQORNOD(0),"=",2)
  1.  I $A($E(SEL,$L(SEL)))<48!($A($E(SEL,$L(SEL)))>57) S SEL=$E(SEL,1,$L(SEL)-1)
  1.  I SEL["," D  Q
  1.  .W $C(7),!,"Only one item number allowed." H 2
  1.  .S VALMBCK="R"
  1.  I SEL="" D
  1.  .W !,"Select Entry:  (1-"_VALMLST_") " R SEL:DTIME
  1.  .I '$T!(SEL=U)!(SEL="") S TRUE=1
  1.  I TRUE=1 Q
  1.  I 'SEL!(SEL>VALMCNT)!('$D(@VALMAR@("IDX",SEL))) D  Q
  1.  .W $C(7),!,SEL_" is not a valid item number." H 2
  1.  .S VALMBCK="R"
  1.  S Y=$O(@VALMAR@("IDX",SEL,""))
  1.  S IEN=+Y
  1.  S OBJMETD=^TIU(8925.1,IEN,9)
  1.  S HSOBJ=$P($P($G(OBJMETD),",",2),")")
  1.  S YESNO="Y"
  1.  I $D(^GMT(142.5,HSOBJ,0))=0 D
  1.  . W !,"No HS Object found. Create new HS Object now?"
  1.  . S DIR(0)="YA0"
  1.  . S DIR("B")="NO"
  1.  . S DIR("?")="Enter Y or N. For detailed help type ??"
  1.  . D ^DIR
  1.  . I $D(DIROUT) S DTOUT=1
  1.  . I $D(DTOUT)!($D(DUOUT)) S YESNO="N" Q
  1.  . S YESNO=$E(Y(0))
  1.  . I YESNO="Y" S HSOBJ=$$CRE^GMTSOBJ()
  1.  I $G(YESNO)="Y"&(HSOBJ>0) D
  1.  . S ^TIU(8925.1,IEN,9)="S X=$$TIU^GMTSOBJ(DFN,"_HSOBJ_")"
  1.  . D EN^TIUHSOLM(HSOBJ,IEN)
  1.  D CLEAN^VALM10
  1.  D INIT
  1.  Q
  1. FIND ;
  1.  S DIC=8925.1,DIC("A")="Enter OBJECT NAME:  "
  1.  ;
  1.  ; DIC(0)="ABEOQ" a=ask user for input, b=use b xref only
  1.  ;                e=echo    o=only find 1 if exact match
  1.  ;                q=question erroneous input
  1.  ;
  1.  ; DIC("S") ensures IEN is greater or equal to 1 and will only
  1.  ; lookup objects that contain the health summary object routine
  1.  ;
  1.  S DIC(0)="ABEOQ",DIC("S")="I Y'<1,$G(^TIU(8925.1,+Y,9))[""GMTSOBJ"""
  1.  W ! D ^DIC I Y=-1 K DIC Q
  1.  D EN^TIUHSV(+Y)
  1.  K DIC
  1.  Q
  1.  ;
  1. LSEXIT ;
  1.  ;display help option
  1.  N VALMSG
  1.  S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"
  1.  D XQORM
  1.  Q
  1.  ;
  1. XQORM ;
  1.  S XQORM("#")=$O(^ORD(101,"B","TIUHS EDIT",0))_U_"1:"_VALMCNT
  1.  S XQORM("A")="Select Action: "
  1.  Q
  1.  ;
  1. HELP ; -- help code
  1.  N X
  1.  S X="?" D DISP^XQORM1 W !!
  1.  Q
  1.  ;
  1. EXIT ; -- exit code
  1.  Q
  1.  ;
  1. EXPND ; -- expand code
  1.  Q
  1.  ;