BDW10P4 ;ihs/cmi/maw - BDW Patch 4
;;1.0;IHS DATA WAREHOUSE;**4**;MAY 28, 2004;Build 24
;
ENV ;-- environment check
I '$$INSTALLD("GIS*3.01*16") D SORRY(2)
I '$$INSTALLD("BDW*1.0*3") D SORRY(2)
;I '$$INSTALLD("AICD*4.0") 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
D MPORT
D ADDZPR13
D ADDIFC
D RMIFC
D ADDOIMC
D GISICD
D GIS
Q
;
MPORT ;-- import the INXPORT global
D MPORT^BHLU
Q
;
ADDZPR13 ;-- lets add the CPT Code Modifier field to GIS
I '$O(^INTHL7F("B","HL IHS DW1 ZPR-13",0)) D
. N BDWFDA,BDWIENS,BDWERR
. S BDWIENS="+1,"
. S BDWFDA(4012,BDWIENS,.01)="HL IHS DW1 ZPR-13"
. S BDWFDA(4012,BDWIENS,.02)=$O(^INTHL7FT("B","STRING",0))
. S BDWFDA(4012,BDWIENS,.03)=999
. S BDWFDA(4012,BDWIENS,3)="@BDW1ZPR13"
. D UPDATE^DIE("","BDWFDA","BDWIENS","BDWERR(1)")
. ;I $D(BDWERR(1)) W !,"Error adding HL IHS DW1 ZPR-13 to the SCRIPT GENERATOR FIELD file"
. S BDWFLD=BDWIENS(1)
I $G(BDWFLD) D
. N BDWSFDA,BDWSIENS,BDWSERR,BDWSEG
. S BDWSEG=$O(^INTHL7S("B","HL IHS DW1 ZPR",0))
. Q:'BDWSEG
. Q:$O(^INTHL7S(BDWSEG,1,"B",BDWFLD,0)) ;already there
. S BDWSIENS="+2,"_BDWSEG_","
. S BDWSFDA(4010.01,BDWSIENS,.01)=BDWFLD
. S BDWSFDA(4010.01,BDWSIENS,.02)=13
. D UPDATE^DIE("","BDWSFDA","BDWSIENS","BDWSERR(1)")
. ;I $D(BDWSERR(1)) W !,"Error adding HL IHS DW1 ZPR-13 to the HL IHS DW1 ZPR segment"
K BDWFLD
Q
;
RMIFC ;-- remove the IFC from ALPMR
N MS,SG,SGI
S MS=$O(^INTHL7M("B","HL IHS DW1ALPMR A08",0))
Q:'MS
S SG=$O(^INTHL7S("B","HL IHS DW1ALPMR OBX IFC",0))
Q:'SG
S SGI=$O(^INTHL7M(MS,1,"B",SG,0))
Q:'SGI
S DA(1)=MS,DA=SGI
S DIK="^INTHL7M("_DA(1)_",1,"
D ^DIK
K DIK,DA
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)")
Q
;
ADDOIMC ;-- add outgoing initial mumps code to message
N MSG,ARY,ERR
S MSG=$O(^INTHL7M("B","HL IHS DW1ALPMR A08",0))
Q:'MSG
S ARY(1)="D VST^BHLV,DW1^BHLV,^BDWALPMR"
D WP^DIE(4011,MSG_",",6,,"ARY","ERR")
Q
;
GIS ;-- ADD PR1 CPT MODIFIER field here, and provider narrative
N BDWX
S BDWX=$O(^INTHL7F("B","HL IHS DW1 PR1-16",0))
Q:'BDWX
S ^INTHL7F(BDWX,"C")="@BDW1PR116"
S BDWX=$O(^INTHL7F("B","HL IHS DW1 ZDX-1",0))
Q:'BDWX
S ^INTHL7F(BDWX,"C")="@BDW1ZDX1"
S BDWX=$O(^INTHL7F("B","HL IHS DW1 OBX CPT-13",0))
Q:'BDWX
S ^INTHL7F(BDWX,"C")="@BDW1CPT13"
N I,BDWM
F I="HL IHS DW1 A08","HL IHS DW1ALPMR A08" D
. S BDWM=$O(^INTHL7M("B",I,0))
. Q:'BDWM
. D COMPILE^BHLU(BDWM)
Q
;
GISICD ;-- populate the ZV1-35 field of GIS, then recompile
N BDWX
S BDWX=$O(^INTHL7F("B","HL IHS DW1 ZV1-35",0))
Q:'BDWX
S ^INTHL7F(BDWX,5)="S X=$$CDEATH^BDWUTIL1(DFN)"
S BDWX=$O(^INTHL7F("B","HL IHS DW1 ZRB-5",0))
Q:'BDWX
S ^INTHL7F(BDWX,5)="S X=$$CDEATH^BDWUTIL1(DFN)"
N I,BDWM
F I="HL IHS DW1 A31","HL IHS DW1 A40" D
. S BDWM=$O(^INTHL7M("B",I,0))
. Q:'BDWM
. D COMPILE^BHLU(BDWM)
Q
;
BDW10P4 ;ihs/cmi/maw - BDW Patch 4
+1 ;;1.0;IHS DATA WAREHOUSE;**4**;MAY 28, 2004;Build 24
+2 ;
ENV ;-- environment check
+1 IF '$$INSTALLD("GIS*3.01*16")
DO SORRY(2)
+2 IF '$$INSTALLD("BDW*1.0*3")
DO SORRY(2)
+3 ;I '$$INSTALLD("AICD*4.0") D 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 DO MPORT
+2 DO ADDZPR13
+3 DO ADDIFC
+4 DO RMIFC
+5 DO ADDOIMC
+6 DO GISICD
+7 DO GIS
+8 QUIT
+9 ;
MPORT ;-- import the INXPORT global
+1 DO MPORT^BHLU
+2 QUIT
+3 ;
ADDZPR13 ;-- lets add the CPT Code Modifier field to GIS
+1 IF '$ORDER(^INTHL7F("B","HL IHS DW1 ZPR-13",0))
Begin DoDot:1
+2 NEW BDWFDA,BDWIENS,BDWERR
+3 SET BDWIENS="+1,"
+4 SET BDWFDA(4012,BDWIENS,.01)="HL IHS DW1 ZPR-13"
+5 SET BDWFDA(4012,BDWIENS,.02)=$ORDER(^INTHL7FT("B","STRING",0))
+6 SET BDWFDA(4012,BDWIENS,.03)=999
+7 SET BDWFDA(4012,BDWIENS,3)="@BDW1ZPR13"
+8 DO UPDATE^DIE("","BDWFDA","BDWIENS","BDWERR(1)")
+9 ;I $D(BDWERR(1)) W !,"Error adding HL IHS DW1 ZPR-13 to the SCRIPT GENERATOR FIELD file"
+10 SET BDWFLD=BDWIENS(1)
End DoDot:1
+11 IF $GET(BDWFLD)
Begin DoDot:1
+12 NEW BDWSFDA,BDWSIENS,BDWSERR,BDWSEG
+13 SET BDWSEG=$ORDER(^INTHL7S("B","HL IHS DW1 ZPR",0))
+14 IF 'BDWSEG
QUIT
+15 ;already there
IF $ORDER(^INTHL7S(BDWSEG,1,"B",BDWFLD,0))
QUIT
+16 SET BDWSIENS="+2,"_BDWSEG_","
+17 SET BDWSFDA(4010.01,BDWSIENS,.01)=BDWFLD
+18 SET BDWSFDA(4010.01,BDWSIENS,.02)=13
+19 DO UPDATE^DIE("","BDWSFDA","BDWSIENS","BDWSERR(1)")
+20 ;I $D(BDWSERR(1)) W !,"Error adding HL IHS DW1 ZPR-13 to the HL IHS DW1 ZPR segment"
End DoDot:1
+21 KILL BDWFLD
+22 QUIT
+23 ;
RMIFC ;-- remove the IFC from ALPMR
+1 NEW MS,SG,SGI
+2 SET MS=$ORDER(^INTHL7M("B","HL IHS DW1ALPMR A08",0))
+3 IF 'MS
QUIT
+4 SET SG=$ORDER(^INTHL7S("B","HL IHS DW1ALPMR OBX IFC",0))
+5 IF 'SG
QUIT
+6 SET SGI=$ORDER(^INTHL7M(MS,1,"B",SG,0))
+7 IF 'SGI
QUIT
+8 SET DA(1)=MS
SET DA=SGI
+9 SET DIK="^INTHL7M("_DA(1)_",1,"
+10 DO ^DIK
+11 KILL DIK,DA
+12 QUIT
+13 ;
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 QUIT
+16 ;
ADDOIMC ;-- add outgoing initial mumps code to message
+1 NEW MSG,ARY,ERR
+2 SET MSG=$ORDER(^INTHL7M("B","HL IHS DW1ALPMR A08",0))
+3 IF 'MSG
QUIT
+4 SET ARY(1)="D VST^BHLV,DW1^BHLV,^BDWALPMR"
+5 DO WP^DIE(4011,MSG_",",6,,"ARY","ERR")
+6 QUIT
+7 ;
GIS ;-- ADD PR1 CPT MODIFIER field here, and provider narrative
+1 NEW BDWX
+2 SET BDWX=$ORDER(^INTHL7F("B","HL IHS DW1 PR1-16",0))
+3 IF 'BDWX
QUIT
+4 SET ^INTHL7F(BDWX,"C")="@BDW1PR116"
+5 SET BDWX=$ORDER(^INTHL7F("B","HL IHS DW1 ZDX-1",0))
+6 IF 'BDWX
QUIT
+7 SET ^INTHL7F(BDWX,"C")="@BDW1ZDX1"
+8 SET BDWX=$ORDER(^INTHL7F("B","HL IHS DW1 OBX CPT-13",0))
+9 IF 'BDWX
QUIT
+10 SET ^INTHL7F(BDWX,"C")="@BDW1CPT13"
+11 NEW I,BDWM
+12 FOR I="HL IHS DW1 A08","HL IHS DW1ALPMR A08"
Begin DoDot:1
+13 SET BDWM=$ORDER(^INTHL7M("B",I,0))
+14 IF 'BDWM
QUIT
+15 DO COMPILE^BHLU(BDWM)
End DoDot:1
+16 QUIT
+17 ;
GISICD ;-- populate the ZV1-35 field of GIS, then recompile
+1 NEW BDWX
+2 SET BDWX=$ORDER(^INTHL7F("B","HL IHS DW1 ZV1-35",0))
+3 IF 'BDWX
QUIT
+4 SET ^INTHL7F(BDWX,5)="S X=$$CDEATH^BDWUTIL1(DFN)"
+5 SET BDWX=$ORDER(^INTHL7F("B","HL IHS DW1 ZRB-5",0))
+6 IF 'BDWX
QUIT
+7 SET ^INTHL7F(BDWX,5)="S X=$$CDEATH^BDWUTIL1(DFN)"
+8 NEW I,BDWM
+9 FOR I="HL IHS DW1 A31","HL IHS DW1 A40"
Begin DoDot:1
+10 SET BDWM=$ORDER(^INTHL7M("B",I,0))
+11 IF 'BDWM
QUIT
+12 DO COMPILE^BHLU(BDWM)
End DoDot:1
+13 QUIT
+14 ;
