XBUTL.m

XBUTL ;IHS/ITSC/CLS - XB MISCELLANEOUS UTILITIES [ 10/06/2005  9:59 AM ]

 ;;3.0;IHS/VA UTILITIES;**11**;July 20, 2005

 ;

LINK(P,C) ;link protocols child to parent

 ;Input: P-Parent protocol

 ;       C-Child protocol

 N IENARY,PIEN,AIEN,FDA,ERR

 Q:'$L(P)!('$L(C))

 S IENARY(1)=$$FIND1^DIC(101,"","",P)

 S AIEN=$$FIND1^DIC(101,"","",C)

 Q:'IENARY(1)!'AIEN

 S FDA(101.01,"?+2,"_IENARY(1)_",",.01)=AIEN

 D UPDATE^DIE("S","FDA","IENARY","ERR")

 ;I $G(ERR("DIERR",1)) W ! ZW ERR  ;IHS/CIA/PLS for debugging use

 Q

LUHN(X) ;calulate check digit, Luhn formula for NPI

 ;x=10 digit number

 I '+X S X=0 Q X

 I $E(X,1,5)=80840 D

 .S X=$E(X,6,15)

 S XBSTRING=""

 I X'?10N S X=0 Q X

 S XBCD=$E(X,10)

 F I=1:1:9 D

 .I (I#2) D

 ..S XBSTRING=XBSTRING_($E(X,I)*2)

 .I '(I#2) D

 ..S XBSTRING=XBSTRING_$E(X,I)

 S XBTOT=0

 F I=1:1:$L(XBSTRING) D

 .S XBTOT=XBTOT+$E(XBSTRING,I)

 S XBTOT=XBTOT+24

 S XBTOT=1000-XBTOT

 S X=$E(XBTOT,$L(XBTOT))

 I X'=XBCD S X=0 Q X

 S X=1 Q X

XBUTL     ;IHS/ITSC/CLS - XB MISCELLANEOUS UTILITIES [ 10/06/2005  9:59 AM ]

 +1       ;;3.0;IHS/VA UTILITIES;**11**;July 20, 2005

 +2       ;

LINK(P,C) ;link protocols child to parent

 +1       ;Input: P-Parent protocol

 +2       ;       C-Child protocol

 +3        NEW IENARY,PIEN,AIEN,FDA,ERR

 +4        IF '$LENGTH(P)!('$LENGTH(C))

               QUIT 

 +5        SET IENARY(1)=$$FIND1^DIC(101,"","",P)

 +6        SET AIEN=$$FIND1^DIC(101,"","",C)

 +7        IF 'IENARY(1)!'AIEN

               QUIT 

 +8        SET FDA(101.01,"?+2,"_IENARY(1)_",",.01)=AIEN

 +9        DO UPDATE^DIE("S","FDA","IENARY","ERR")

 +10      ;I $G(ERR("DIERR",1)) W ! ZW ERR  ;IHS/CIA/PLS for debugging use

 +11       QUIT 

LUHN(X)   ;calulate check digit, Luhn formula for NPI

 +1       ;x=10 digit number

 +2        IF '+X

               SET X=0

               QUIT X

 +3        IF $EXTRACT(X,1,5)=80840

               Begin DoDot:1

 +4                SET X=$EXTRACT(X,6,15)

               End DoDot:1

 +5        SET XBSTRING=""

 +6        IF X'?10N

               SET X=0

               QUIT X

 +7        SET XBCD=$EXTRACT(X,10)

 +8        FOR I=1:1:9

               Begin DoDot:1

 +9                IF (I#2)

                       Begin DoDot:2

 +10                       SET XBSTRING=XBSTRING_($EXTRACT(X,I)*2)

                       End DoDot:2

 +11               IF '(I#2)

                       Begin DoDot:2

 +12                       SET XBSTRING=XBSTRING_$EXTRACT(X,I)

                       End DoDot:2

               End DoDot:1

 +13       SET XBTOT=0

 +14       FOR I=1:1:$LENGTH(XBSTRING)

               Begin DoDot:1

 +15               SET XBTOT=XBTOT+$EXTRACT(XBSTRING,I)

               End DoDot:1

 +16       SET XBTOT=XBTOT+24

 +17       SET XBTOT=1000-XBTOT

 +18       SET X=$EXTRACT(XBTOT,$LENGTH(XBTOT))

 +19       IF X'=XBCD

               SET X=0

               QUIT X

 +20       SET X=1

           QUIT X