BLRRPOST ; cmi/anch/maw - BLR Reference Lab Post Init ; [ 03/13/06 ]
;;5.2;LR;**1021**;Jul 27, 2006
;;1.0;BLR REFERENCE LAB;;MAR 14, 2005
;
;
;this routine will set up the necessary site parameters and compile
;the scripts for the Reference Lab software
;
MAIN ;PEP - Main Routine Driver
D SETLA7
D SITE
D CUSER
D UPIN
D EOJ
Q
;
SITE ;EP - setup the site parameters in BLR MASTER CONTROL
;and BLR REFERENCE LAB
X ^%ZOSF("EON")
W !,"Now setting up reference lab parameters.."
S DIC="^BLRRL(",DIC(0)="AEMQZ"
S DIC("A")="Setup Parameters for which Reference Lab: "
D ^DIC
S BLRRL=+Y
Q:'BLRRL
S BLRRLE=$P($G(^BLRRL(BLRRL,0)),U)
S DIE=DIC,DA=BLRRL,DR=".02:.07;.09;.16;1:7;20"
D ^DIE
K DIE,DR,DIC,DA
W !!,"Now setting up GIS HL7 Message Parameters.."
S BLRMSG=$O(^INTHL7M("B","HL IHS LAB O01 "_BLRRLE,0))
Q:'BLRMSG
S BLRMSGI=$O(^INTHL7M("B","HL IHS LAB O01 "_BLRRLE_" IN",0))
Q:'BLRMSGI
S DIE="^INTHL7M(",DA=BLRMSG,DR="7.01:7.04;.08///N"
D ^DIE
S DA=BLRMSGI,DR=".08///N"
D ^DIE
K DIE,DR,DA
S DIC="^BLRSITE(",DIC(0)="AEMQZ"
S DIC("A")="Add this Reference Lab to which Site: "
D ^DIC
Q:Y<0
S DIE=DIC,DA=+Y,DR="3001////"_BLRRL
D ^DIE
K DIC,DIE,DR,DA
W !!,"Now setting up Lab HL7 Message Parameter File.."
I $O(^LAHM(62.48,"B",BLRRLE,0)) D
. K DD,DO,DIC
. S BLRHM=$O(^LAHM(62.48,"B",BLRRLE,0))
. I 'BLRHM W !!,"Error creating entry in LAHM(62.48" Q
. S DA(1)=BLRHM
. S DIC="^LAHM(62.48,"_DA(1)_",90,",DIC(0)="L"
. S DIC("P")=$P(^DD(62.48,90,0),U,2)
. S BLRRID=$P($G(^INTHL7M(BLRMSG,7)),U,4)_$P($G(^INTHL7M(BLRMSG,7)),U,2)
. S X=BLRRID
. D FILE^DICN
. I '+$G(Y) W !!,"Error creating entry in LAHM(62.48" Q
. S DIE="^LAHM(62.48,",DA=BLRHM,DR="2///A"
. D ^DIE
W !!,"Now activating Reference Lab Interface.."
F BLRY=BLRMSG,BLRMSGI D COMPILE^BHLU(BLRY)
Q
;
SETLA7 ;-- setup the LA7 Message Parameter File
S BLRDA=0 F S BLRDA=$O(^BLRRL(BLRDA)) Q:'BLRDA D
. K DD,DO,DIC
. S BLRRF=$P($G(^BLRRL(BLRDA,0)),U)
. S BLRPIN="D QUE^BLR"_$E(BLRRF,1)_"IIN"
. Q:$O(^LAHM(62.48,"B",BLRRF,0))
. S DIC="^LAHM(62.48,",DIC(0)="L"
. S X=BLRRF
. S DIC("DR")="1///HL7;2///I;4///Y;5///"_$G(BLRPIN)
. D FILE^DICN
Q
;
CUSER ;-- create a lab technician user for the interface
W !,"Now creating TECHNICIAN,LAB for filing data..."
Q:$O(^VA(200,"B","TECHNICIAN,LAB",0))
K DD,DO
S DIC="^VA(200,",DIC(0)="L",X="TECHNICIAN,LAB"
S DIC("DR")="1///LT"
D FILE^DICN
K DIC
Q
;
UPIN ;-- create UPIN cross reference
Q
;
EOJ ;-- kill variables and quit
X ^%ZOSF("EOFF")
D EN^XBVK("BLR")
Q
;
BLRRPOST ; cmi/anch/maw - BLR Reference Lab Post Init ; [ 03/13/06 ]
+1 ;;5.2;LR;**1021**;Jul 27, 2006
+2 ;;1.0;BLR REFERENCE LAB;;MAR 14, 2005
+3 ;
+4 ;
+5 ;this routine will set up the necessary site parameters and compile
+6 ;the scripts for the Reference Lab software
+7 ;
MAIN ;PEP - Main Routine Driver
+1 DO SETLA7
+2 DO SITE
+3 DO CUSER
+4 DO UPIN
+5 DO EOJ
+6 QUIT
+7 ;
SITE ;EP - setup the site parameters in BLR MASTER CONTROL
+1 ;and BLR REFERENCE LAB
+2 XECUTE ^%ZOSF("EON")
+3 WRITE !,"Now setting up reference lab parameters.."
+4 SET DIC="^BLRRL("
SET DIC(0)="AEMQZ"
+5 SET DIC("A")="Setup Parameters for which Reference Lab: "
+6 DO ^DIC
+7 SET BLRRL=+Y
+8 IF 'BLRRL
QUIT
+9 SET BLRRLE=$PIECE($GET(^BLRRL(BLRRL,0)),U)
+10 SET DIE=DIC
SET DA=BLRRL
SET DR=".02:.07;.09;.16;1:7;20"
+11 DO ^DIE
+12 KILL DIE,DR,DIC,DA
+13 WRITE !!,"Now setting up GIS HL7 Message Parameters.."
+14 SET BLRMSG=$ORDER(^INTHL7M("B","HL IHS LAB O01 "_BLRRLE,0))
+15 IF 'BLRMSG
QUIT
+16 SET BLRMSGI=$ORDER(^INTHL7M("B","HL IHS LAB O01 "_BLRRLE_" IN",0))
+17 IF 'BLRMSGI
QUIT
+18 SET DIE="^INTHL7M("
SET DA=BLRMSG
SET DR="7.01:7.04;.08///N"
+19 DO ^DIE
+20 SET DA=BLRMSGI
SET DR=".08///N"
+21 DO ^DIE
+22 KILL DIE,DR,DA
+23 SET DIC="^BLRSITE("
SET DIC(0)="AEMQZ"
+24 SET DIC("A")="Add this Reference Lab to which Site: "
+25 DO ^DIC
+26 IF Y<0
QUIT
+27 SET DIE=DIC
SET DA=+Y
SET DR="3001////"_BLRRL
+28 DO ^DIE
+29 KILL DIC,DIE,DR,DA
+30 WRITE !!,"Now setting up Lab HL7 Message Parameter File.."
+31 IF $ORDER(^LAHM(62.48,"B",BLRRLE,0))
Begin DoDot:1
+32 KILL DD,DO,DIC
+33 SET BLRHM=$ORDER(^LAHM(62.48,"B",BLRRLE,0))
+34 IF 'BLRHM
WRITE !!,"Error creating entry in LAHM(62.48"
QUIT
+35 SET DA(1)=BLRHM
+36 SET DIC="^LAHM(62.48,"_DA(1)_",90,"
SET DIC(0)="L"
+37 SET DIC("P")=$PIECE(^DD(62.48,90,0),U,2)
+38 SET BLRRID=$PIECE($GET(^INTHL7M(BLRMSG,7)),U,4)_$PIECE($GET(^INTHL7M(BLRMSG,7)),U,2)
+39 SET X=BLRRID
+40 DO FILE^DICN
+41 IF '+$GET(Y)
WRITE !!,"Error creating entry in LAHM(62.48"
QUIT
+42 SET DIE="^LAHM(62.48,"
SET DA=BLRHM
SET DR="2///A"
+43 DO ^DIE
End DoDot:1
+44 WRITE !!,"Now activating Reference Lab Interface.."
+45 FOR BLRY=BLRMSG,BLRMSGI
DO COMPILE^BHLU(BLRY)
+46 QUIT
+47 ;
SETLA7 ;-- setup the LA7 Message Parameter File
+1 SET BLRDA=0
FOR
SET BLRDA=$ORDER(^BLRRL(BLRDA))
IF 'BLRDA
QUIT
Begin DoDot:1
+2 KILL DD,DO,DIC
+3 SET BLRRF=$PIECE($GET(^BLRRL(BLRDA,0)),U)
+4 SET BLRPIN="D QUE^BLR"_$EXTRACT(BLRRF,1)_"IIN"
+5 IF $ORDER(^LAHM(62.48,"B",BLRRF,0))
QUIT
+6 SET DIC="^LAHM(62.48,"
SET DIC(0)="L"
+7 SET X=BLRRF
+8 SET DIC("DR")="1///HL7;2///I;4///Y;5///"_$GET(BLRPIN)
+9 DO FILE^DICN
End DoDot:1
+10 QUIT
+11 ;
CUSER ;-- create a lab technician user for the interface
+1 WRITE !,"Now creating TECHNICIAN,LAB for filing data..."
+2 IF $ORDER(^VA(200,"B","TECHNICIAN,LAB",0))
QUIT
+3 KILL DD,DO
+4 SET DIC="^VA(200,"
SET DIC(0)="L"
SET X="TECHNICIAN,LAB"
+5 SET DIC("DR")="1///LT"
+6 DO FILE^DICN
+7 KILL DIC
+8 QUIT
+9 ;
UPIN ;-- create UPIN cross reference
+1 QUIT
+2 ;
EOJ ;-- kill variables and quit
+1 XECUTE ^%ZOSF("EOFF")
+2 DO EN^XBVK("BLR")
+3 QUIT
+4 ;
