BDW10P5 ;ihs/cmi/maw - BDW Patch 5
;;1.0;IHS DATA WAREHOUSE;**5**;MAY 28, 2018;Build 32
;
ENV ;-- environment check
I '$$INSTALLD("GIS*3.01*16") D SORRY(2)
I '$$INSTALLD("BDW*1.0*4") D SORRY(2)
I '$$INSTALLD("AG*7.1*13") D SORRY(2)
Q
;
INSTALLD(BDGSTAL) ;EP - Determine if patch BDGSTAL was installed, where
; BDGSTAL is the name of the INSTALL. E.g "AG*6.0*11".
;
NEW BDGY,DIC,X,Y
S X=$P(BDGSTAL,"*",1)
S DIC="^DIC(9.4,",DIC(0)="FM",D="C"
D IX^DIC
I Y<1 D IMES Q 0
S DIC=DIC_+Y_",22,",X=$P(BDGSTAL,"*",2)
D ^DIC
I Y<1 D IMES Q 0
I $P(BDGSTAL,"*",3)="" D IMES Q 1
S DIC=DIC_+Y_",""PAH"",",X=$P(BDGSTAL,"*",3)
D ^DIC
S BDGY=Y
D IMES
Q $S(BDGY<1:0,1:1)
IMES ;
D MES^XPDUTL($$CJ^XLFSTR("Patch """_BDGSTAL_""" is"_$S(Y<1:" *NOT*",1:"")_" Present.",IOM))
Q
SORRY(X) ;
KILL DIFQ
I X=3 S XPDQUIT=2 Q
S XPDQUIT=X
W *7,!,$$CJ^XLFSTR("Sorry....FIX IT!",IOM)
Q
;
POST ;post init
N BDWST
S BDWST=$O(^BDWSITE("B",DUZ(2),0))
I '$G(^BDWSITE(BDWST,9999999)) D RXPORT
Q:$O(^INTHL7S("B","HL IHS DW1ALPMR OBX IFC",0)) ;segment already there dont add again
S KFM="K DIE,DR,DIC,DA,DD,DO,DIK"
D ADDFLD
D ADDSEG
D ADDFSEG
D ADDIFC
K KFM
Q
;
ADDFLD ;-- add fields to INTHL7F
N I,FLD01,FLD02,FLD03,FLD3,FLD5,ADD
F I="HL IHS DW1ALPMR OBX IFC-1","HL IHS DW1ALPMR OBX IFC-2","HL IHS DW1ALPMR OBX IFC-5" D
. S FLD01=I
. S FLD02="STRING"
. S FLD03=999
. S FLD3="@BDW1IFC"_$P(I,"-",2)
. S FLD5=""
. S ADD=$$CHKF^INMPORT(FLD01,FLD02,FLD03,FLD3,FLD5)
Q
;
ADDSEG ;-- add the segment
N SEG
S SEG="HL IHS DW1ALPMR OBX IFC"
S SEGADD=$$CHKS^INMPORT(SEG,"OBX")
Q
;
ADDFSEG ;-- add the fields to the segment
N J,SEGI,SEGA
S SEGI=$O(^INTHL7S("B","HL IHS DW1ALPMR OBX IFC",0))
Q:'SEGI
F J="HL IHS DW1ALPMR OBX IFC-1","HL IHS DW1ALPMR OBX IFC-2","HL IHS DW1ALPMR OBX IFC-5" D
. S SEGA=$$SFADD^INMPORT(SEGI,J,$P(J,"-",2),"")
Q
;
ADDIFC ;-add the ifc segment to the message
N MESS,SEG
S MESS=$O(^INTHL7M("B","HL IHS DW1 A08",0))
Q:'MESS
S SEG=$O(^INTHL7S("B","HL IHS DW1ALPMR OBX IFC",0))
Q:'SEG
Q:$O(^INTHL7M(MESS,1,"B",SEG,0))
N FDA,FIENS,FERR
S FIENS="+2,"_MESS_","
S FDA(4011.01,FIENS,.01)=SEG
S FDA(4011.01,FIENS,.02)=230
S FDA(4011.01,FIENS,.03)=1
S FDA(4011.01,FIENS,.07)="P"
S FDA(4011.01,FIENS,.12)="IFC"
D UPDATE^DIE("","FDA","FIENS","FERR(1)")
D COMPILE^BHLU(MESS)
Q
;
RXPORT ;-- mark IFC for export
N RDA,RIEN,ST
S RDA=3150430.9999 F S RDA=$O(^AUPNVSIT("B",RDA)) Q:'RDA D
. S RIEN=0 F S RIEN=$O(^AUPNVSIT("B",RDA,RIEN)) Q:'RIEN D
.. Q:'$O(^AUPNVIF("AD",RIEN,0))
.. S ^AUPNVSIT("ADWO",DT,RIEN)=""
S ST=$O(^BDWSITE("B",DUZ(2),0))
Q:'ST
S ^BDWSITE(ST,9999999)=1
Q
;
BDW10P5 ;ihs/cmi/maw - BDW Patch 5
+1 ;;1.0;IHS DATA WAREHOUSE;**5**;MAY 28, 2018;Build 32
+2 ;
ENV ;-- environment check
+1 IF '$$INSTALLD("GIS*3.01*16")
DO SORRY(2)
+2 IF '$$INSTALLD("BDW*1.0*4")
DO SORRY(2)
+3 IF '$$INSTALLD("AG*7.1*13")
DO SORRY(2)
+4 QUIT
+5 ;
INSTALLD(BDGSTAL) ;EP - Determine if patch BDGSTAL was installed, where
+1 ; BDGSTAL is the name of the INSTALL. E.g "AG*6.0*11".
+2 ;
+3 NEW BDGY,DIC,X,Y
+4 SET X=$PIECE(BDGSTAL,"*",1)
+5 SET DIC="^DIC(9.4,"
SET DIC(0)="FM"
SET D="C"
+6 DO IX^DIC
+7 IF Y<1
DO IMES
QUIT 0
+8 SET DIC=DIC_+Y_",22,"
SET X=$PIECE(BDGSTAL,"*",2)
+9 DO ^DIC
+10 IF Y<1
DO IMES
QUIT 0
+11 IF $PIECE(BDGSTAL,"*",3)=""
DO IMES
QUIT 1
+12 SET DIC=DIC_+Y_",""PAH"","
SET X=$PIECE(BDGSTAL,"*",3)
+13 DO ^DIC
+14 SET BDGY=Y
+15 DO IMES
+16 QUIT $SELECT(BDGY<1:0,1:1)
IMES ;
+1 DO MES^XPDUTL($$CJ^XLFSTR("Patch """_BDGSTAL_""" is"_$SELECT(Y<1:" *NOT*",1:"")_" Present.",IOM))
+2 QUIT
SORRY(X) ;
+1 KILL DIFQ
+2 IF X=3
SET XPDQUIT=2
QUIT
+3 SET XPDQUIT=X
+4 WRITE *7,!,$$CJ^XLFSTR("Sorry....FIX IT!",IOM)
+5 QUIT
+6 ;
POST ;post init
+1 NEW BDWST
+2 SET BDWST=$ORDER(^BDWSITE("B",DUZ(2),0))
+3 IF '$GET(^BDWSITE(BDWST,9999999))
DO RXPORT
+4 ;segment already there dont add again
IF $ORDER(^INTHL7S("B","HL IHS DW1ALPMR OBX IFC",0))
QUIT
+5 SET KFM="K DIE,DR,DIC,DA,DD,DO,DIK"
+6 DO ADDFLD
+7 DO ADDSEG
+8 DO ADDFSEG
+9 DO ADDIFC
+10 KILL KFM
+11 QUIT
+12 ;
ADDFLD ;-- add fields to INTHL7F
+1 NEW I,FLD01,FLD02,FLD03,FLD3,FLD5,ADD
+2 FOR I="HL IHS DW1ALPMR OBX IFC-1","HL IHS DW1ALPMR OBX IFC-2","HL IHS DW1ALPMR OBX IFC-5"
Begin DoDot:1
+3 SET FLD01=I
+4 SET FLD02="STRING"
+5 SET FLD03=999
+6 SET FLD3="@BDW1IFC"_$PIECE(I,"-",2)
+7 SET FLD5=""
+8 SET ADD=$$CHKF^INMPORT(FLD01,FLD02,FLD03,FLD3,FLD5)
End DoDot:1
+9 QUIT
+10 ;
ADDSEG ;-- add the segment
+1 NEW SEG
+2 SET SEG="HL IHS DW1ALPMR OBX IFC"
+3 SET SEGADD=$$CHKS^INMPORT(SEG,"OBX")
+4 QUIT
+5 ;
ADDFSEG ;-- add the fields to the segment
+1 NEW J,SEGI,SEGA
+2 SET SEGI=$ORDER(^INTHL7S("B","HL IHS DW1ALPMR OBX IFC",0))
+3 IF 'SEGI
QUIT
+4 FOR J="HL IHS DW1ALPMR OBX IFC-1","HL IHS DW1ALPMR OBX IFC-2","HL IHS DW1ALPMR OBX IFC-5"
Begin DoDot:1
+5 SET SEGA=$$SFADD^INMPORT(SEGI,J,$PIECE(J,"-",2),"")
End DoDot:1
+6 QUIT
+7 ;
ADDIFC ;-add the ifc segment to the message
+1 NEW MESS,SEG
+2 SET MESS=$ORDER(^INTHL7M("B","HL IHS DW1 A08",0))
+3 IF 'MESS
QUIT
+4 SET SEG=$ORDER(^INTHL7S("B","HL IHS DW1ALPMR OBX IFC",0))
+5 IF 'SEG
QUIT
+6 IF $ORDER(^INTHL7M(MESS,1,"B",SEG,0))
QUIT
+7 NEW FDA,FIENS,FERR
+8 SET FIENS="+2,"_MESS_","
+9 SET FDA(4011.01,FIENS,.01)=SEG
+10 SET FDA(4011.01,FIENS,.02)=230
+11 SET FDA(4011.01,FIENS,.03)=1
+12 SET FDA(4011.01,FIENS,.07)="P"
+13 SET FDA(4011.01,FIENS,.12)="IFC"
+14 DO UPDATE^DIE("","FDA","FIENS","FERR(1)")
+15 DO COMPILE^BHLU(MESS)
+16 QUIT
+17 ;
RXPORT ;-- mark IFC for export
+1 NEW RDA,RIEN,ST
+2 SET RDA=3150430.9999
FOR
SET RDA=$ORDER(^AUPNVSIT("B",RDA))
IF 'RDA
QUIT
Begin DoDot:1
+3 SET RIEN=0
FOR
SET RIEN=$ORDER(^AUPNVSIT("B",RDA,RIEN))
IF 'RIEN
QUIT
Begin DoDot:2
+4 IF '$ORDER(^AUPNVIF("AD",RIEN,0))
QUIT
+5 SET ^AUPNVSIT("ADWO",DT,RIEN)=""
End DoDot:2
End DoDot:1
+6 SET ST=$ORDER(^BDWSITE("B",DUZ(2),0))
+7 IF 'ST
QUIT
+8 SET ^BDWSITE(ST,9999999)=1
+9 QUIT
+10 ;
