BCHPOS1.m

BCHPOS1 ; IHS/TUCSON/LAB - POST INIT - 2 ;  [ 10/28/96  2:05 PM ]

 ;;1.0;IHS RPMS CHR SYSTEM;;OCT 28, 1996

 ; - This routine finds or creates the CHR MANAGER mail group

 ; - adds the CHR MANAGER mail group to the following bulletins:

 ;       BCH CHR TRANSMISSION ERROR

 ;       BCH PCC PACKAGE LINK FAIL

 ; - creates the BCH entry in the HL7 APPLICATION PARAMETER file

 ; - adds the 1-99 CHRPC## entries to the HL7 APPLICATION PARAMETER file

 ;

 ;

START ;start of routine

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

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

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

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

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

 D SETVAR ;                  set up DIC variables

 D BCHENTRY ;                create the BCH entry

 D ADD99 ;                   populate the file with 99 entries

 ;

EOJ ;

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

 K BCHN,BCHFAC,BCHCODE,BCHMGRP

 Q

 ;end of routine

 ;----------------------------------

SETVAR ;set up variables for DIC call

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

 S DIC("DR")="2////a;3////"_BCHFAC_";4////"_BCHMGRP_";7////"_BCHCODE_";101////~|\&"

 Q

 ;

BCHENTRY ;create the BCH entry

 K DD,DO

 S X="BCH"

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

 D FILE^DICN K DIC

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

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

 K Y,X

 Q

 ;

ADD99 ;populate the file with 99 entries

 ;

 F BCHN=1:1:99 S:BCHN<10 BCHN=0_BCHN D  Q:BCHN>99

 .  K DD,D0 D SETVAR

 .  S X="CHRPC"_BCHN

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

 .  D FILE^DICN

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

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

 .  K X

 .  Q

 K DIC,X,Y

 Q

BCHPOS1   ; IHS/TUCSON/LAB - POST INIT - 2 ;  [ 10/28/96  2:05 PM ]

 +1       ;;1.0;IHS RPMS CHR SYSTEM;;OCT 28, 1996

 +2       ; - This routine finds or creates the CHR MANAGER mail group

 +3       ; - adds the CHR MANAGER mail group to the following bulletins:

 +4       ;       BCH CHR TRANSMISSION ERROR

 +5       ;       BCH PCC PACKAGE LINK FAIL

 +6       ; - creates the BCH entry in the HL7 APPLICATION PARAMETER file

 +7       ; - adds the 1-99 CHRPC## entries to the HL7 APPLICATION PARAMETER file

 +8       ;

 +9       ;

START     ;start of routine

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

               QUIT 

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

 +3        IF 'BCHFAC

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

               QUIT 

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

 +5        IF 'BCHCODE

               WRITE !,"Unable to determine Country Code."

               QUIT 

 +6       ;                  set up DIC variables

           DO SETVAR

 +7       ;                create the BCH entry

           DO BCHENTRY

 +8       ;                   populate the file with 99 entries

           DO ADD99

 +9       ;

EOJ       ;

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

 +2        KILL BCHN,BCHFAC,BCHCODE,BCHMGRP

 +3        QUIT 

 +4       ;end of routine

 +5       ;----------------------------------

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////"_BCHFAC_";4////"_BCHMGRP_";7////"_BCHCODE_";101////~|\&"

 +3        QUIT 

 +4       ;

BCHENTRY  ;create the BCH entry

 +1        KILL DD,DO

 +2        SET X="BCH"

 +3        IF $DATA(^HL(771,"B","BCH"))

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

               KILL X

               QUIT 

 +4        DO FILE^DICN

           KILL DIC

 +5        IF Y<0

               WRITE !,"Entry was unsuccessful:  ",X

               KILL X

               QUIT 

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

 +7        KILL Y,X

 +8        QUIT 

 +9       ;

ADD99     ;populate the file with 99 entries

 +1       ;

 +2        FOR BCHN=1:1:99

               IF BCHN<10

                   SET BCHN=0_BCHN

               Begin DoDot:1

 +3                KILL DD,D0

                   DO SETVAR

 +4                SET X="CHRPC"_BCHN

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

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

                       QUIT 

 +6                DO FILE^DICN

 +7                IF Y<0

                       WRITE !,"Entry was unsuccessful:  ",X

                       KILL X

                       QUIT 

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

 +9                KILL X

 +10               QUIT 

               End DoDot:1

               IF BCHN>99

                   QUIT 

 +11       KILL DIC,X,Y

 +12       QUIT