source: cprs/branches/tmg-cprs/m_files/TMGHUI1.m@ 1099

TMGHUI1 ;TMG/kst/Custom version of HUI code ;03/25/06
         ;;1.0;TMG-LIB;**1**;01/12/05
 
 
HUIPSUPD ;DLD/Pacific HUI/Updates orderable item file with PS Orderable Items ; 1/25/05 7:55am
         ;;This routine populates the drug orderable items
 
 ;"HUI MISCELLANEOUS FUNCTIONS (used/customized in TMG library)
 
 ;"=======================================================================
 ;" API -- Public Functions.
 ;"=======================================================================
 ;"myGO  ;" - global list-   (global lister)
 
 ;"=======================================================================
 ;"PRIVATE API FUNCTIONS
 ;"=======================================================================
 
 ;"=======================================================================
 ;"=======================================================================
 
EN
        ;" loop through PS(50.7 and add to OE Ordeable item
        new PSOIEN
        do DT^DICRW
        set PSOIEN=$order(^PS(50.7,0))
        if +PSOIEN>0 for  do  quit:'PSOIEN
        . do ADD(PSOIEN)
        . set PSOIEN=$order(^PS(50.7,PSOIEN))
        quit
 
 
ADD(PSOIEN)
        ;" Calls PS Orderable Item update routines
        do EN^PSSPOIDT(PSOIEN)
        do EN2^PSSHL1(PSOIEN,"MUP")
        quit
 
SET
        ;" - updates view set
        new DIC,X,Y,IEN,D,TYPE,NM,DGNM,UPDTIME,ATTEMPT
        do DT^DICRW
        set DIC="^ORD(101.44,"
        set DIC(0)="AQ"
        for  D ^DIC  quit:+Y  quit:X="^"
        quit:X="^"
        set IEN=+Y
        set NM=$P(Y,U,2)
        set DGNM=$P(NM,"ORWDSET ",2)
        set UPDTIME=$H
        set ATTEMPT=""
        do FVBLD^ORWUL
        quit
 
 
myGO;" - global list-   (global lister)
        ;- Jan 2005 - DLD - PACIFIC HUI
        ; - THis routine allows global out of a partial global
        ;" //kt note: Obtained from N. Anthracite 11/4/05.  She got
        ;"   it from Norman Dodd <norman.dodd@bluecliffinc.com>
        ;"   Reformatted for full commands
        ;"   User interface changes made also.
        ;"   This function dumps one or more globals to selected output device
 
        write !,"Global Output Utility",!
        if '$data(%zdebug) new $et do
        . set $et="zg "_$zl_":ERR^%GO"
        . use $p:(ctrap=$c(3):exc="zg "_$zl_":EXIT^%GO")
        new g,gn,m,n,c,gl,in,%ZD,%ZG,%ZH,fmt
        set c=0
        for  read !,"Enter Global ([enter] if done): ",in,!  do  quit:in=""
        . quit:in=""
        . if $extract(in)="?",$length(in)=1 do help quit
        . if $extract(in)="^",$length(in)=1 set in="" quit
        . if $extract(in)'="^" do help quit
        . if in["(",in'[")" do help quit
        . set c=c+1,gl(c)=in
        if '$data(gl) write !,"No globals selected" quit
        read !,"Header Label: ",%ZH,!
        read !,"Output Format: GO or ZWR: ",fmt,!
        if (fmt="")!($extract("ZWR",1,$length(fmt))=$translate(fmt,"zwr","ZWR"))  set fmt=1
        else  set fmt=0
        for  do  quit:$length(%ZD)
        .  read !,"Output device: <terminal>: ",%ZD,!
        .  if '$length(%ZD) set %ZD=$p quit
        .  if %ZD="^" quit
        .  if %ZD="?" do  quit
        .  .  write !!,"Select the device you want for output"
        .  .  write !,"If you wish to exit enter a carat (^)",!
        .  .  set %ZD=""
        .  if $zparse(%ZD)="" write "  no such device" set %ZD="" quit
        .  open %ZD:(newversion:block=2048:record=2044:exception="g noopen"):0
        .  if '$t  write !,%ZD," is not available" set %ZD="" quit
        .  quit
noopen  .  write !,$p($ZS,",",2,999),! close %ZD set %ZD=""
        quit:%ZD="^"
        write !!
        if '$length(%ZH) set %ZH="%GO Global Output Utility"
        use %ZD
        write %ZH,!,"GT.M ",$zd($h,"DD-MON-YEAR 24:60:SS")
        write:fmt " ZWR"
        write !
        set c=0,(m,n)=0
        for  set c=$order(gl(c)) quit:'+c  set gn=gl(c),g=gn do
        .  use $p
        .  write:$x>70 !
        .  write gn,?$x\10+1*10
        .  use %ZD
        .  if $p=%ZD write !
        .  quit:g=""
        .  set m=m+1
        .  if $data(@g)'[0 write g do   set n=n+1
        .  .  if fmt  write "=" do fw(@g)
        .  .  else  write !,@g,!
        .  for  set g=$q(@g) quit:g=""  do
        .  .  if fmt  zwr @g
        .  .  else  write g,!,@g,!
        .  .  set n=n+1
        use %ZD write !!
        use $p
        write !!,"Total of ",n," node",$s(n=1:"",1:"s")
        write " in ",m," global",$s(m=1:".",1:"s."),!!
        close:%ZD'=$p %ZD
        use $p:(ctrap="":exc="")
        quit
 
fw(s)
        ;" variables used in this function are: fwlen, s, cc, fastate, isctl, i, thistime
        ;" initialize this procedure
        set fwlen=$length(s)
        if fwlen=0  write !  quit
        if s=+s  write s,!  quit
        set cc=$extract(s)
        if cc?1C  write "$C(",$a(cc)  set fastate=2
        else  write """",cc  w:cc="""" cc  set fastate=1
        ;" start the loop to deal with the whole string.
        for i=2:1:fwlen  set cc=$extract(s,i,i),isctl=cc?1C  d
        .  set thistime=1
        .  if fastate=1  do
         .  .  if (isctl)  write """_$C(",$a(cc)  set fastate=2,thistime=0
         .  .  else  write cc  w:cc="""" cc
        .  if (fastate=2)&thistime  do
         .  .  if (isctl)!(cc="""")  write ",",$a(cc)
         .  .  else  write ")_""",cc  set fastate=1
        if fastate=1  write """",!
        else  write ")",!
        quit
 
ERR     use $p write !,$p($zs,",",2,99),!
        ; Warning - Fall-though
        set $ec=""
EXIT    if $data(%ZD),%ZD'=$p close %ZD
        use $p:(ctrap="":exc="")
        quit
 
help;
        write !,"Enter a global reference to start at with ^"
        write !,"i.e ^DPT or ^VA(200)"
        quit