Routine: BHLRXPS1

BHLRXPS1 ; IHS/TUCSON/DCP - HL7 - POST-INIT FOR COTS PHARMACY INSTALLATION - 2 ;

 ;;1.0;IHS SUPPORT FOR HL7 INTERFACES;;JUL 7, 1997

 ; This routine creates the BHLBPS and VIKRX entries in the

 ; HL7 APPLICATION PARAMETER file. It is a continuation of BHLRXPST and

 ; is not independently callable.

START ; ENTRY POINT from BHLRXPST

 Q:'$D(^HL(771))

 S BHLFAC=$P(^AUTTLOC($P($G(^AUTTSITE(1,0)),U,1),0),U,10)

 I 'BHLFAC W !,"Unable to determine facility ASUFAC 6-digit number." Q

 S BHLCODE=$O(^HL(779.004,"B","USA",""))

 I 'BHLCODE W !,"Unable to determine Country Code." Q

SETVAR ; set up variables for DIC call

 S DIC="^HL(771,",DIC(0)="L",DLAYGO=771

 S DIC("DR")="2////a;3////"_BHLFAC_";4////"_BHLMGRP_";7////"_BHLCODE_";100////|"

ADD ; add application parameter entries

 F X="BHLBPS","VIKRX" D

 .  I $D(^HL(771,"B",X)) W !,"....exists:  ",X Q

 .  K DD,DO D FILE^DICN

 .  S ^HL(771,D0,"EC")="^~\&" ;                      encoding characters

 .  I Y<0 W !,"Entry was unsuccessful:  ",X Q

 .  W !,"....adding:  ",X

 .  Q

EOJ ; clean up and leave

 K DIC,X,Y,DD,DO,D0,DA,DDH,DI,DIE,DR,DLAYGO

BHLRXPS1  ; IHS/TUCSON/DCP - HL7 - POST-INIT FOR COTS PHARMACY INSTALLATION - 2 ;

 +1       ;;1.0;IHS SUPPORT FOR HL7 INTERFACES;;JUL 7, 1997

 +2       ;

 +3       ; This routine creates the BHLBPS and VIKRX entries in the

 +4       ; HL7 APPLICATION PARAMETER file. It is a continuation of BHLRXPST and

 +5       ; is not independently callable.

 +6       ;

START     ; ENTRY POINT from BHLRXPST

 +1        IF '$DATA(^HL(771))

               QUIT

 +2        SET BHLFAC=$PIECE(^AUTTLOC($PIECE($GET(^AUTTSITE(1,0)),U,1),0),U,10)

 +3        IF 'BHLFAC

               WRITE !,"Unable to determine facility ASUFAC 6-digit number."

               QUIT

 +4        SET BHLCODE=$ORDER(^HL(779.004,"B","USA",""))

 +5        IF 'BHLCODE

               WRITE !,"Unable to determine Country Code."

               QUIT

 +6       ;

SETVAR    ; set up variables for DIC call

 +1        SET DIC="^HL(771,"

           SET DIC(0)="L"

           SET DLAYGO=771

 +2        SET DIC("DR")="2////a;3////"_BHLFAC_";4////"_BHLMGRP_";7////"_BHLCODE_";100////|"

 +3       ;

ADD       ; add application parameter entries

 +1        FOR X="BHLBPS","VIKRX"

               Begin DoDot:1

 +2                IF $DATA(^HL(771,"B",X))

                       WRITE !,"....exists:  ",X

                       QUIT

 +3                KILL DD,DO

                   DO FILE^DICN

 +4       ;                      encoding characters

                   SET ^HL(771,D0,"EC")="^~\&"

 +5                IF Y<0

                       WRITE !,"Entry was unsuccessful:  ",X

                       QUIT

 +6                WRITE !,"....adding:  ",X

 +7                QUIT

               End DoDot:1

 +8       ;

EOJ       ; clean up and leave

 +1        KILL DIC,X,Y,DD,DO,D0,DA,DDH,DI,DIE,DR,DLAYGO

 +2        QUIT

BHLRXPS1.m