| 1 | DGRR557U ; ALB/SGG - PersonServiceDemographic HL7 Build and Send ;08/16/04 ; Compiled August 16, 2004 12:41:01
|
|---|
| 2 | ;;5.3;Registration;**557**;Aug 13, 1993
|
|---|
| 3 | ;
|
|---|
| 4 | QUIT
|
|---|
| 5 | ;
|
|---|
| 6 | ADD(STR) ; -- add string to array
|
|---|
| 7 | SET DGRRLINE=DGRRLINE+1
|
|---|
| 8 | SET @DGRRESLT@(DGRRLINE)=STR
|
|---|
| 9 | QUIT
|
|---|
| 10 | ;
|
|---|
| 11 | CHARCHK(STR) ; -- replace xml character limits with entities
|
|---|
| 12 | NEW A,I,X,Y,Z,NEWSTR
|
|---|
| 13 | SET (Y,Z)=""
|
|---|
| 14 | IF STR["&" SET NEWSTR=STR DO SET STR=Y_Z
|
|---|
| 15 | . FOR X=1:1 SET Y=Y_$PIECE(NEWSTR,"&",X)_"&",Z=$PIECE(STR,"&",X+1,999) QUIT:Z'["&"
|
|---|
| 16 | IF STR["<" FOR SET STR=$PIECE(STR,"<",1)_"<"_$PIECE(STR,"<",2,99) Q:STR'["<"
|
|---|
| 17 | IF STR[">" FOR SET STR=$PIECE(STR,">",1)_">"_$PIECE(STR,">",2,99) Q:STR'[">"
|
|---|
| 18 | IF STR["'" FOR SET STR=$PIECE(STR,"'",1)_"'"_$PIECE(STR,"'",2,99) Q:STR'["'"
|
|---|
| 19 | IF STR["""" FOR SET STR=$PIECE(STR,"""",1)_"""_$PIECE(STR,"""",2,99) QUIT:STR'[""""
|
|---|
| 20 | ;
|
|---|
| 21 | FOR I=1:1:$LENGTH(STR) DO
|
|---|
| 22 | . SET X=$EXTRACT(STR,I)
|
|---|
| 23 | . SET A=$ASCII(X)
|
|---|
| 24 | . IF A<31 S STR=$P(STR,X,1)_$P(STR,X,2,99)
|
|---|
| 25 | QUIT STR
|
|---|
| 26 | ;
|
|---|
| 27 | SITENO() ; institution number, including suffix, from vasite.
|
|---|
| 28 | Q $P($$SITE^VASITE(),"^",3)
|
|---|
| 29 | ;
|
|---|
| 30 | SITENAM() ; - Institution name, from vasite
|
|---|
| 31 | Q $P($$SITE^VASITE(),"^",2)
|
|---|
| 32 | ;
|
|---|
| 33 | PRODST1() ; Production account status check 1
|
|---|
| 34 | ; -- Returns 1 if production, 0 if not
|
|---|
| 35 | N X S X=$G(^XMB("NETNAME"))
|
|---|
| 36 | Q $L(X,".")=3!($L(X,".")=4&(X[".MED."))
|
|---|
| 37 | ;
|
|---|
| 38 | PRODST2() ; Production account status check 2
|
|---|
| 39 | ; -- returns 1 if Default Processing Id from HL COMMUNICATION SERVER PARAMETERS file is Production, 0 if not
|
|---|
| 40 | Q ($P($$PARAM^HLCS2,"^",3)="P")
|
|---|
| 41 | ;
|
|---|
| 42 | DOMAIN() ; -- get the default domain
|
|---|
| 43 | QUIT $$KSP^XUPARAM("WHERE")
|
|---|
| 44 | ;
|
|---|
| 45 | XMLHDR() ; -- provides current XML standard header
|
|---|
| 46 | QUIT "<?xml version=""1.0"" encoding=""utf-8"" ?>"
|
|---|
| 47 | ;
|
|---|
| 48 | CHKSUM(ARRAY) ;
|
|---|
| 49 | NEW VAL,ITEM,DATA,CHAR
|
|---|
| 50 | SET VAL=0
|
|---|
| 51 | SET ITEM=0
|
|---|
| 52 | FOR S ITEM=$ORDER(ARRAY(ITEM)) QUIT:ITEM="" SET DATA=ARRAY(ITEM) DO
|
|---|
| 53 | . FOR CHAR=1:1:$L(DATA) S VAL=($ASCII(DATA,CHAR)*CHAR*ITEM)+VAL
|
|---|
| 54 | QUIT VAL
|
|---|
