BHLINIT1.m

BHLINIT1 ; ; 7-JUL-1997

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

 ; LOADS AND INDEXES DD'S

 ;

 K DIF,DIK,D,DDF,DDT,DTO,D0,DLAYGO,DIC,DIDUZ,DIR,DA,DFR,DTN,DIX,DZ D DT^DICRW S %=1,U="^",DSEC=1

 S NO=$P("I 0^I $D(@X)#2,X[U",U,%) I %<1 K DIFQ Q

ASK I %=1,$D(DIFQ(0)) W !,"SHALL I WRITE OVER FILE SECURITY CODES" S %=2 D YN^DICN S DSEC=%=1 I %<1 K DIFQ Q

 F X="BUL" D W Q:'$D(DIFQ)

 Q:'$D(DIFQ)  S %=2 W !!,"ARE YOU SURE EVERYTHING'S OK" D YN^DICN I %-1 K DIFQ Q

 I $D(DIFKEP) F DIDIU=0:0 S DIDIU=$O(DIFKEP(DIDIU)) Q:DIDIU'>0  S DIU=DIDIU,DIU(0)=DIFKEP(DIDIU) D EN^DIU2

 D DT^DICRW K ^UTILITY(U,$J),^UTILITY("DIK",$J) D WAIT^DICD

 S DN="^BHLIN" F R=1:1:1 D @(DN_$$B36(R)) W "."

 F  S D=$O(^UTILITY(U,$J,"SBF","")) Q:D'>0  K:'DIFQ(D) ^(D) S D=$O(^(D,"")) I D>0  K ^(D) D IX

DATA W "." S (D,DDF(1),DDT(0))=$O(^UTILITY(U,$J,0)) Q:D'>0

 I DIFQR(D) S DTO=0,DMRG=1,DTO(0)=^(D),Z=^(D)_"0)",D0=^(D,0),@Z=D0,DFR(1)="^UTILITY(U,$J,DDF(1),D0,",DKP=DIFQR(D)'=2 F D0=0:0 S D0=$O(^UTILITY(U,$J,DDF(1),D0)) S:D0="" D0=-1 Q:'$D(^(D0,0))  S Z=^(0) D I^DITR

 K ^UTILITY(U,$J,DDF(1)),DDF,DDT,DTO,DFR,DFN,DTN G DATA

 ;

W S Y=$P($T(@X),";",2) W !,"NOTE: This package also contains "_Y_"S",! Q:'$D(DIFQ(0))

 S %=1 W ?6,"SHALL I WRITE OVER EXISTING "_Y_"S OF THE SAME NAME" D YN^DICN I '% W !?6,"Answer YES to replace the current "_Y_"S with the incoming ones." G W

 S:%=2 DIFQ(X)=0 K:%<0 DIFQ

 Q

 ;

OPT ;OPTION

RTN ;ROUTINE DOCUMENTATION NOTE

FUN ;FUNCTION

BUL ;BULLETIN

KEY ;SECURITY KEY

HEL ;HELP FRAME

DIP ;PRINT TEMPLATE

DIE ;INPUT TEMPLATE

DIB ;SORT TEMPLATE

DIS ;FORM

 ;

SBF ;FILE AND SUB FILE NUMBERS

IX W "." S DIK="A" F %=0:0 S DIK=$O(^DD(D,DIK)) Q:DIK=""  K ^(DIK)

 S DA(1)=D,DIK="^DD("_D_"," D IXALL^DIK

 I $D(^DIC(D,"%",0)) S DIK="^DIC(D,""%""," G IXALL^DIK

 Q

B36(X) Q $$N(X\(36*36)#36+1)_$$N(X\36#36+1)_$$N(X#36+1)

N(%) Q $E("0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ",%)

BHLINIT1  ; ; 7-JUL-1997

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

 +2       ; LOADS AND INDEXES DD'S

 +3       ;

 +4        KILL DIF,DIK,D,DDF,DDT,DTO,D0,DLAYGO,DIC,DIDUZ,DIR,DA,DFR,DTN,DIX,DZ

           DO DT^DICRW

           SET %=1

           SET U="^"

           SET DSEC=1

 +5        SET NO=$PIECE("I 0^I $D(@X)#2,X[U",U,%)

           IF %<1

               KILL DIFQ

               QUIT 

ASK        IF %=1

               IF $DATA(DIFQ(0))

                   WRITE !,"SHALL I WRITE OVER FILE SECURITY CODES"

                   SET %=2

                   DO YN^DICN

                   SET DSEC=%=1

                   IF %<1

                       KILL DIFQ

                       QUIT 

 +1        FOR X="BUL"

               DO W

               IF '$DATA(DIFQ)

                   QUIT 

 +2        IF '$DATA(DIFQ)

               QUIT 

           SET %=2

           WRITE !!,"ARE YOU SURE EVERYTHING'S OK"

           DO YN^DICN

           IF %-1

               KILL DIFQ

               QUIT 

 +3        IF $DATA(DIFKEP)

               FOR DIDIU=0:0

                   SET DIDIU=$ORDER(DIFKEP(DIDIU))

                   IF DIDIU'>0

                       QUIT 

                   SET DIU=DIDIU

                   SET DIU(0)=DIFKEP(DIDIU)

                   DO EN^DIU2

 +4        DO DT^DICRW

           KILL ^UTILITY(U,$JOB),^UTILITY("DIK",$JOB)

           DO WAIT^DICD

 +5        SET DN="^BHLIN"

           FOR R=1:1:1

               DO @(DN_$$B36(R))

               WRITE "."

 +6        FOR 

               SET D=$ORDER(^UTILITY(U,$JOB,"SBF",""))

               IF D'>0

                   QUIT 

               IF 'DIFQ(D)

                   KILL ^(D)

               SET D=$ORDER(^(D,""))

               IF D>0

                   KILL ^(D)

                   DO IX

DATA       WRITE "."

           SET (D,DDF(1),DDT(0))=$ORDER(^UTILITY(U,$JOB,0))

           IF D'>0

               QUIT 

 +1        IF DIFQR(D)

               SET DTO=0

               SET DMRG=1

               SET DTO(0)=^(D)

               SET Z=^(D)_"0)"

               SET D0=^(D,0)

               SET @Z=D0

               SET DFR(1)="^UTILITY(U,$J,DDF(1),D0,"

               SET DKP=DIFQR(D)'=2

               FOR D0=0:0

                   SET D0=$ORDER(^UTILITY(U,$JOB,DDF(1),D0))

                   IF D0=""

                       SET D0=-1

                   IF '$DATA(^(D0,0))

                       QUIT 

                   SET Z=^(0)

                   DO I^DITR

 +2        KILL ^UTILITY(U,$JOB,DDF(1)),DDF,DDT,DTO,DFR,DFN,DTN

           GOTO DATA

 +3       ;

W          SET Y=$PIECE($TEXT(@X),";",2)

           WRITE !,"NOTE: This package also contains "_Y_"S",!

           IF '$DATA(DIFQ(0))

               QUIT 

 +1        SET %=1

           WRITE ?6,"SHALL I WRITE OVER EXISTING "_Y_"S OF THE SAME NAME"

           DO YN^DICN

           IF '%

               WRITE !?6,"Answer YES to replace the current "_Y_"S with the incoming ones."

               GOTO W

 +2        IF %=2

               SET DIFQ(X)=0

           IF %<0

               KILL DIFQ

 +3        QUIT 

 +4       ;

OPT       ;OPTION

RTN       ;ROUTINE DOCUMENTATION NOTE

FUN       ;FUNCTION

BUL       ;BULLETIN

KEY       ;SECURITY KEY

HEL       ;HELP FRAME

DIP       ;PRINT TEMPLATE

DIE       ;INPUT TEMPLATE

DIB       ;SORT TEMPLATE

DIS       ;FORM

 +1       ;

SBF       ;FILE AND SUB FILE NUMBERS

IX         WRITE "."

           SET DIK="A"

           FOR %=0:0

               SET DIK=$ORDER(^DD(D,DIK))

               IF DIK=""

                   QUIT 

               KILL ^(DIK)

 +1        SET DA(1)=D

           SET DIK="^DD("_D_","

           DO IXALL^DIK

 +2        IF $DATA(^DIC(D,"%",0))

               SET DIK="^DIC(D,""%"","

               GOTO IXALL^DIK

 +3        QUIT 

B36(X)     QUIT $$N(X\(36*36)#36+1)_$$N(X\36#36+1)_$$N(X#36+1)

N(%)       QUIT $EXTRACT("0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ",%)