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