DGRR557U ; ALB/SGG - PersonServiceDemographic HL7 Build and Send ;08/16/04 ; Compiled August 16, 2004 12:41:01
;;5.3;Registration;**557**;Aug 13, 1993
;
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGRR557U 1923 printed Sep 23, 2025@20:33:25 Page 2
DGRR557U ; ALB/SGG - PersonServiceDemographic HL7 Build and Send ;08/16/04 ; Compiled August 16, 2004 12:41:01
+1 ;;5.3;Registration;**557**;Aug 13, 1993
+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
