BCHPOS2 ; IHS/TUCSON/LAB - POST INIT - 3 ; [ 10/28/96 2:05 PM ]
;;1.0;IHS RPMS CHR SYSTEM;;OCT 28, 1996
;This routine adds the following entries into the
; PROTOCAL: 1 - 99 entries of BCH HL7 SERVER CHRPC##
;
;
START ;start of routine
Q:'$D(^ORD(101))
;
D LOOKUPS ; do lookups for field variables
D SETUP ; setup initial variables for DIC call
D PROCESS ; populate the file with 99 entries
D RINDEX ; re-index "^ORD(101,"
;
EOJ ; end of job
K DIC,X,Y,DD,DO,D0,DA,DDH,DI,DIC,DIE,DR,DLAYGO
K BCHCOND,BCHDIC,BCHDR,BCHEVNT,BCHFLG,BCHIEN,BCHISEQC,BCHITEM
K BCHMTR,BCHNAME,BCHPKG,BCHPTR,BCHRPC,BCHSA,BCHTEXT,BCHVID
K BCHN,BCHFAC,BCHCODE
Q
;end of routine
;
;----------------------------------
PROCESS ;populate the file with 99 entries
;
S BCHN=0 F BCHN=1:1:99 S:BCHN<10 BCHN=0_BCHN D Q:BCHN>99
. S BCHRPC="CHRPC"_BCHN
. S BCHNAME="BCH HL7 SERVER "_BCHRPC
. I $D(^ORD(101,"B",BCHNAME)) W !,"....exists: ",BCHNAME Q
. S BCHPTR=""
. S BCHPTR=$O(^HL(771,"B",BCHRPC,BCHPTR))
. Q:BCHPTR=""
. S DIC("DR")=BCHDR_";770.1////"_BCHPTR
. S X=BCHNAME
. K DD,DO
. S DIC=BCHDIC
. D FILE^DICN ; add entry
. I +Y<0 W !,"Entry was unsuccessful: ",X K X Q
. S BCHIEN=+Y
. W !,"....adding: ",X
. K X,Y
. D MULTIPL ; add multiple entry
. Q
Q
;
;
MULTIPL ; add multiple entry
S DIC=BCHDIC_BCHIEN_",10,"
S DIC(0)="L"
S DIC("P")=$P(^DD(101,10,0),U,2)
S DA(1)=BCHIEN
S DIC("DR")="3////1"
S X=BCHITEM
K DD,DO
D FILE^DICN
I +Y<0 W !?5,"Multiple entry was unsuccessful: ",X K X Q
K X,Y
Q
;
SETUP ; set up initial variables for DIC call
S BCHTEXT="CHR Penbased HL7 ORU Message" ; ITEM TEXT field
S BCHISEQC=1 ; SEQUENCE multiple field (ITEM)
;
K DD,DO
S BCHDIC="^ORD(101,",DIC(0)="L",DLAYGO=101
;S BCHDR="1////"_BCHTEXT_";4////E;12////"_BCHPKG_";770.5////i;770.6////P;770.8////"_BCHCOND_";770.9////"_BCHCOND_";770.95////"_BCHVID
S BCHDR="1////"_BCHTEXT_";4////E;12////"_BCHPKG_";770.3////"_BCHMTR_";770.4////"_BCHEVNT_";770.5////i;770.6////P;770.8////"_BCHCOND_";770.9////"_BCHCOND_";770.95////"_BCHVID
Q
;
LOOKUPS ; do lookups for the various fields
S BCHFLG=1
S (BCHPKG,BCHITEM,BCHSA,BCHCOND,BCHVID,BCHEVNT,BCHMTR)=0
; lookup of PACKAGE entry ien
S BCHPKG=$O(^DIC(9.4,"B","IHS RPMS CHR SYSTEM",BCHPKG))
S:'BCHPKG BCHFLG=0
; lookup of PROTOCOL file's ITEM entry ien
S BCHITEM=$O(^ORD(101,"B","BCH HL7 ORU",BCHITEM))
S:'BCHITEM BCHFLG=0
; following temporary "CHRPC15"...change to variable name!!!
; lookup of the HL7 APPLICATION PARAMETER's CHRPC## entry ien
S BCHSA=$O(^HL(771,"B","CHRPC15",BCHSA))
S:'BCHSA BCHFLG=0
; lookup of HL7 ACCEPT/APPLICATION ACK CONDITION file entry ien
S BCHCOND=$O(^HL(779.003,"B","NE",BCHCOND))
S:'BCHCOND BCHFLG=0
; lookup of HL7 VERSION file entry ien
S BCHVID=$O(^HL(771.5,"B","2.2",BCHVID))
S:'BCHVID BCHFLG=0
; lookup of MESSAGE TYPE RECEIVED file entry ien (multiple fld)
S BCHMTR=$O(^HL(771.2,"B","ORU",BCHMTR))
S:'BCHMTR BCHFLG=0
; lookup of EVENT TYPE file entry ien (multiple fld)
S BCHEVNT=$O(^HL(779.001,"B","R01",BCHEVNT))
S:'BCHEVNT BCHFLG=0
Q
;
RINDEX ;re-index the PROTOCOL file
S DIK="^ORD(101,"
W !!,"....Re-indexing the PROTOCOL file."
D IXALL^DIK
K DIK
Q
;
BCHPOS2 ; IHS/TUCSON/LAB - POST INIT - 3 ; [ 10/28/96 2:05 PM ]
+1 ;;1.0;IHS RPMS CHR SYSTEM;;OCT 28, 1996
+2 ;This routine adds the following entries into the
+3 ; PROTOCAL: 1 - 99 entries of BCH HL7 SERVER CHRPC##
+4 ;
+5 ;
START ;start of routine
+1 IF '$DATA(^ORD(101))
QUIT
+2 ;
+3 ; do lookups for field variables
DO LOOKUPS
+4 ; setup initial variables for DIC call
DO SETUP
+5 ; populate the file with 99 entries
DO PROCESS
+6 ; re-index "^ORD(101,"
DO RINDEX
+7 ;
EOJ ; end of job
+1 KILL DIC,X,Y,DD,DO,D0,DA,DDH,DI,DIC,DIE,DR,DLAYGO
+2 KILL BCHCOND,BCHDIC,BCHDR,BCHEVNT,BCHFLG,BCHIEN,BCHISEQC,BCHITEM
+3 KILL BCHMTR,BCHNAME,BCHPKG,BCHPTR,BCHRPC,BCHSA,BCHTEXT,BCHVID
+4 KILL BCHN,BCHFAC,BCHCODE
+5 QUIT
+6 ;end of routine
+7 ;
+8 ;----------------------------------
PROCESS ;populate the file with 99 entries
+1 ;
+2 SET BCHN=0
FOR BCHN=1:1:99
IF BCHN<10
SET BCHN=0_BCHN
Begin DoDot:1
+3 SET BCHRPC="CHRPC"_BCHN
+4 SET BCHNAME="BCH HL7 SERVER "_BCHRPC
+5 IF $DATA(^ORD(101,"B",BCHNAME))
WRITE !,"....exists: ",BCHNAME
QUIT
+6 SET BCHPTR=""
+7 SET BCHPTR=$ORDER(^HL(771,"B",BCHRPC,BCHPTR))
+8 IF BCHPTR=""
QUIT
+9 SET DIC("DR")=BCHDR_";770.1////"_BCHPTR
+10 SET X=BCHNAME
+11 KILL DD,DO
+12 SET DIC=BCHDIC
+13 ; add entry
DO FILE^DICN
+14 IF +Y<0
WRITE !,"Entry was unsuccessful: ",X
KILL X
QUIT
+15 SET BCHIEN=+Y
+16 WRITE !,"....adding: ",X
+17 KILL X,Y
+18 ; add multiple entry
DO MULTIPL
+19 QUIT
End DoDot:1
IF BCHN>99
QUIT
+20 QUIT
+21 ;
+22 ;
MULTIPL ; add multiple entry
+1 SET DIC=BCHDIC_BCHIEN_",10,"
+2 SET DIC(0)="L"
+3 SET DIC("P")=$PIECE(^DD(101,10,0),U,2)
+4 SET DA(1)=BCHIEN
+5 SET DIC("DR")="3////1"
+6 SET X=BCHITEM
+7 KILL DD,DO
+8 DO FILE^DICN
+9 IF +Y<0
WRITE !?5,"Multiple entry was unsuccessful: ",X
KILL X
QUIT
+10 KILL X,Y
+11 QUIT
+12 ;
SETUP ; set up initial variables for DIC call
+1 ; ITEM TEXT field
SET BCHTEXT="CHR Penbased HL7 ORU Message"
+2 ; SEQUENCE multiple field (ITEM)
SET BCHISEQC=1
+3 ;
+4 KILL DD,DO
+5 SET BCHDIC="^ORD(101,"
SET DIC(0)="L"
SET DLAYGO=101
+6 ;S BCHDR="1////"_BCHTEXT_";4////E;12////"_BCHPKG_";770.5////i;770.6////P;770.8////"_BCHCOND_";770.9////"_BCHCOND_";770.95////"_BCHVID
+7 SET BCHDR="1////"_BCHTEXT_";4////E;12////"_BCHPKG_";770.3////"_BCHMTR_";770.4////"_BCHEVNT_";770.5////i;770.6////P;770.8////"_BCHCOND_";770.9////"_BCHCOND_";770.95////"_BCHVID
+8 QUIT
+9 ;
LOOKUPS ; do lookups for the various fields
+1 SET BCHFLG=1
+2 SET (BCHPKG,BCHITEM,BCHSA,BCHCOND,BCHVID,BCHEVNT,BCHMTR)=0
+3 ; lookup of PACKAGE entry ien
+4 SET BCHPKG=$ORDER(^DIC(9.4,"B","IHS RPMS CHR SYSTEM",BCHPKG))
+5 IF 'BCHPKG
SET BCHFLG=0
+6 ; lookup of PROTOCOL file's ITEM entry ien
+7 SET BCHITEM=$ORDER(^ORD(101,"B","BCH HL7 ORU",BCHITEM))
+8 IF 'BCHITEM
SET BCHFLG=0
+9 ; following temporary "CHRPC15"...change to variable name!!!
+10 ; lookup of the HL7 APPLICATION PARAMETER's CHRPC## entry ien
+11 SET BCHSA=$ORDER(^HL(771,"B","CHRPC15",BCHSA))
+12 IF 'BCHSA
SET BCHFLG=0
+13 ; lookup of HL7 ACCEPT/APPLICATION ACK CONDITION file entry ien
+14 SET BCHCOND=$ORDER(^HL(779.003,"B","NE",BCHCOND))
+15 IF 'BCHCOND
SET BCHFLG=0
+16 ; lookup of HL7 VERSION file entry ien
+17 SET BCHVID=$ORDER(^HL(771.5,"B","2.2",BCHVID))
+18 IF 'BCHVID
SET BCHFLG=0
+19 ; lookup of MESSAGE TYPE RECEIVED file entry ien (multiple fld)
+20 SET BCHMTR=$ORDER(^HL(771.2,"B","ORU",BCHMTR))
+21 IF 'BCHMTR
SET BCHFLG=0
+22 ; lookup of EVENT TYPE file entry ien (multiple fld)
+23 SET BCHEVNT=$ORDER(^HL(779.001,"B","R01",BCHEVNT))
+24 IF 'BCHEVNT
SET BCHFLG=0
+25 QUIT
+26 ;
RINDEX ;re-index the PROTOCOL file
+1 SET DIK="^ORD(101,"
+2 WRITE !!,"....Re-indexing the PROTOCOL file."
+3 DO IXALL^DIK
+4 KILL DIK
+5 QUIT
+6 ;
