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

DGRRUTL.m

Go to the documentation of this file.
  1. DGRRUTL ;alb/aas - DG Replacement and Rehosting RPC for VADPT ;10/21/05 13:19
  1. ;;5.3;Registration;**538,1015**;Aug 13, 1993;Build 21
  1. ;
  1. QUIT
  1. ;
  1. ADD(STR) ; -- add string to array
  1. SET DGRRLINE=DGRRLINE+1
  1. SET @DGRRESLT@(DGRRLINE)=STR
  1. QUIT
  1. ;
  1. CHARCHK(STR) ; -- replace xml character limits with entities
  1. NEW A,I,X,Y,Z,NEWSTR
  1. SET (Y,Z)=""
  1. IF STR["&" SET NEWSTR=STR DO SET STR=Y_Z
  1. . FOR X=1:1 SET Y=Y_$PIECE(NEWSTR,"&",X)_"&",Z=$PIECE(STR,"&",X+1,999) QUIT:Z'["&"
  1. IF STR["<" FOR SET STR=$PIECE(STR,"<",1)_"<"_$PIECE(STR,"<",2,99) Q:STR'["<"
  1. IF STR[">" FOR SET STR=$PIECE(STR,">",1)_">"_$PIECE(STR,">",2,99) Q:STR'[">"
  1. IF STR["'" FOR SET STR=$PIECE(STR,"'",1)_"'"_$PIECE(STR,"'",2,99) Q:STR'["'"
  1. IF STR["""" FOR SET STR=$PIECE(STR,"""",1)_"""_$PIECE(STR,"""",2,99) QUIT:STR'[""""
  1. ;
  1. FOR I=1:1:$LENGTH(STR) DO
  1. . SET X=$EXTRACT(STR,I)
  1. . SET A=$ASCII(X)
  1. . IF A<31 S STR=$P(STR,X,1)_$P(STR,X,2,99)
  1. QUIT STR
  1. ;
  1. SITENO() ; institution number, including suffix, from vasite.
  1. Q $P($$SITE^VASITE(),"^",3)
  1. ;
  1. SITENAM() ; - Institution name, from vasite
  1. Q $P($$SITE^VASITE(),"^",2)
  1. ;
  1. PRODST1() ; Production account status check 1
  1. ; -- Returns 1 if production, 0 if not
  1. N X S X=$G(^XMB("NETNAME"))
  1. Q $L(X,".")=3!($L(X,".")=4&(X[".MED."))
  1. ;
  1. PRODST2() ; Production account status check 2
  1. ; -- returns 1 if Default Processing Id from HL COMMUNICATION SERVER PARAMETERS file is Production, 0 if not
  1. Q ($P($$PARAM^HLCS2,"^",3)="P")
  1. ;
  1. DOMAIN() ; -- get the default domain
  1. QUIT $$KSP^XUPARAM("WHERE")
  1. ;
  1. XMLHDR() ; -- provides current XML standard header
  1. QUIT "<?xml version=""1.0"" encoding=""utf-8"" ?>"
  1. ;
  1. CHKSUM(ARRAY) ;
  1. NEW VAL,ITEM,DATA,CHAR
  1. SET VAL=0
  1. SET ITEM=0
  1. FOR S ITEM=$ORDER(ARRAY(ITEM)) QUIT:ITEM="" SET DATA=ARRAY(ITEM) DO
  1. . FOR CHAR=1:1:$L(DATA) S VAL=($ASCII(DATA,CHAR)*CHAR*ITEM)+VAL
  1. QUIT VAL