- 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 ;
