DGRR557U.m

DGRR557U ; ALB/SGG - PersonServiceDemographic HL7 Build and Send ;08/16/04  ; Compiled August 16, 2004 12:41:01

 ;;5.3;Registration;**557,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

DGRR557U  ; ALB/SGG - PersonServiceDemographic HL7 Build and Send ;08/16/04  ; Compiled August 16, 2004 12:41:01

 +1       ;;5.3;Registration;**557,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