APCD3M ; IHS/CMI/LAB - PCC TO 3M CODER INTERFACE ;
;;2.0;IHS PCC SUITE;**2,11**;MAY 14, 2009;Build 58
;;2.0
;
; This routine processes inbound HL7 messages from the 3M Coder
; and generates outbound HL7 messages to send to the 3M Coder.
;
; The entry point IN is called by the HL7 package to process
; an inbound message from the 3M Coder. An entry is generated
; in file 9001001.9 for the specified visit which contains the
; ICD codes and provider narratives required to generate the
; appropriate V POV and V PROCEDURE entries for this visit.
;
; The entry point OUT is called to generate an HL7 message
; containing patient demographic and medical data required
; by the 3M Coder to assign ICD codes to V POV entries. The
; visit IEN is passed in APCDVSIT.
;
;cmi/anch/maw 10/11/2005 modified due to change in 3m structure
;cmi/anch/maw 12/2/2005 maw added clean of destination queue before sending
;cmi/anch/maw 3/6/2007 maw modified DISPCPT to screen off description
;cmi/anch/maw 3/6/2007 maw modified DISPICD to get if a V code
;cmi/tucson/lab 11/12/2007 code set versioning
;
Q ;do not enter at top of routine
;
IN ; EP - PROCESS HL7 MESSAGE FROM 3M CODER
;maw this is where the inbound stuff starts
NEW APCD3COD,APCD3IEN,APCD3NAR,APCDQ,I,J,X,Y
D INMAIN
D EOJ
Q
;
INMAIN ; INBOUND MAINLINE LOGIC
D INSTALL ; generate 9001001.9 entry
Q
;
INSTALL ; GENERATE 9001001.9 ENTRY
F J=1:1 S X=$G(APCDHL7M(J)) Q:X="" D Q:$G(APCD3MER)
. S Y=$P(X,"|") ; get segment
. I Y="PV1" D IPV1 Q ; pv1 segment
. I Y="DG1" D IDG1 Q ; dg1 segment
. I Y="PR1" D IPR1 Q ; pr1 segment
. I Y="DRG" D IDRG Q ; drg segment
. Q
Q
;
IPV1 ; PV1 SEGMENT
S X=$P(X,"|",20)
I 'X S APCD3MER="200^No Visit IEN in Message" D ERR Q
S DIC="^APCD3MV(",DIC(0)="L",DLAYGO=9001001.9,DIC("DR")=".02////"_UIF
S DINUM=X
D FILE
I Y<0 S APCD3MER="100^Error adding message to 3M file" D ERR Q
S APCD3IEN=+Y
Q
;
IDG1 ; DG1 SEGMENT
S APCD3COD=$P($P(X,"|",4),U) ; get ICD9 code
S APCD3TXT=$P($P(X,"|",4),U,2) ;icd desc
S APCD3DTP=$P(X,"|",7) ;diagnosis type
Q:$G(APCD3DTP)="A" ;don't file admit dx
;I $E(APCD3COD,1,1)="E" S APCDECOD=APCD3COD D Q
;. I APCDECOD'["." S APCDECOD=$E(APCDECOD,1,4)_"."_$E(APCDECOD,5,999)
;. D UPDCODE Q
I $E(APCD3COD,1,1)="E" D
. I APCD3COD'["." S APCD3COD=$E(APCD3COD,1,4)_"."_$E(APCD3COD,5,999)
I $E(APCD3COD,1,1)'="E" D
. I APCD3COD'["." S APCD3COD=$E(APCD3COD,1,3)_"."_$E(APCD3COD,4,999)
I APCD3COD="" S APCD3MER="204^POV ICD9 code missing" Q
S X=APCD3COD,DA(1)=APCD3IEN,DIC="^APCD3MV("_DA(1)_",11,",DIC(0)="L",DIC("P")=$P(^DD(9001001.9,1101,0),U,2)
S DIC("DR")=".02///"_$G(APCD3TXT)
D FILE
I Y<0 S APCD3MER="210^Error adding POV to 3M file" D ERR Q
S APCDDG1=+Y
Q
;
IPR1 ; PR1 SEGMENT
S APCD3COD=$P($P(X,"|",4),U) ; get ICD9 code
S APCD3TXT=$P($P(X,"|",4),U,2) ; cpt description
S APCDCTP=$P($P(X,"|",4),U,3) ; get type of coding system
S APCD3MOD=$P(X,"|",17) ; get modifier
I APCD3COD="" S APCD3MER="208^PROC ICD9 code missing" Q
I $G(APCDCTP)="CP" D ICPT Q ;goto cpt filer then quit
I $G(APCDCTP)="H" D ICPT Q ;hcps codes
I $E(APCD3COD,1)'?.N D ICPT Q ;non icd codes
;I $L(APCD3COD)>4 D ICPT Q ;cpt codes 10/25/2005 maw commented out
I APCD3COD'["." S APCD3COD=$E(APCD3COD,1,2)_"."_$E(APCD3COD,3,999)
S X=APCD3COD,DA(1)=APCD3IEN,DIC="^APCD3MV("_DA(1)_",12,",DIC(0)="L",DIC("P")=$P(^DD(9001001.9,1201,0),U,2)
S DIC("DR")=".02///"_$G(APCD3TXT)
D FILE
I Y<0 S APCD3MER="211^Error adding Procedure to 3M file" D ERR Q
S APCDPR1=+Y
Q
;
IDRG ;-- get the drg
S APCD3DRG=$P(X,"|",2)
I APCD3DRG'="" S APCD3DRG="DRG"_+APCD3DRG
S DIE="^APCD3MV(",DA=APCD3IEN,DR=".03///"_APCD3DRG
D ^DIE
I $D(Y) S APCD3MER="220^Error adding DRG to 3M file" D ERR
Q
;
ICPT ;-- file cpt codes
S X=APCD3COD_" - "_APCD3TXT ;file cpt and text
S DA(1)=APCD3IEN,DIC="^APCD3MV("_DA(1)_",13,",DIC(0)="L",DIC("P")=$P(^DD(9001001.9,1301,0),U,2)
I $G(APCD3MOD)?.N S DIC("DR")=".02////"_$G(APCD3MOD)
D FILE
Q
;
DISPCPT ;-- display the cpt picklist for user
S APCDDA=0 F I=1:1 S APCDDA=$O(^APCD3MV(APCDVSIT,13,APCDDA)) Q:'APCDDA D
. S APCD3CPT=$P($G(^APCD3MV(APCDVSIT,13,APCDDA,0)),U)
. S APCD3MOD=$P($G(^APCD3MV(APCDVSIT,13,APCDDA,0)),U,2)
. W !,$G(I)_") Cpt: "_$G(APCD3CPT)_$S($G(APCD3MOD)'="":" Modifier: "_$G(APCD3MOD),1:"")
. S APCDCPTA(I)=APCDDA_U_APCD3CPT_U_APCD3MOD
Q:'$O(APCDCPTA(""))
S APCDPCPT=""
R !!,"Which CPT should I attach to this procedure: ",APCDRX:DTIME
Q:APCDRX="^"
Q:APCDRX=""
I '$G(APCDCPTA(APCDRX)) W !,"Not a valid Selection, Try Again." G DISPCPT
S APCDUCPT=$P($G(APCDCPTA(APCDRX)),U)
;S APCDPCPT=$P($G(APCDCPTA(APCDRX)),U,2) ;cmi/anch/maw 3/6/2007 orig line
S APCDPCPT=+$P($G(APCDCPTA(APCDRX)),U,2) ;cmi/anch/maw 3/6/2007 modified
S APCDPMOD=$P($G(APCDPMOD(APCDRX)),U,3)
;I $G(APCDPCPT)'="" S APCDPCPT=$O(^ICPT("B",APCDPCPT,0))
I $G(APCDPCPT)'="" S APCDPCPT=$P($$CPT^ICPTCOD(APCDPCPT),U,1)
I APCDPCPT=-1 S APCDPCPT=""
I APCDPCPT'="" S APCDPCPT="`"_APCDPCPT
I $G(APCDPMOD)'="" D
.I $$VERSION^XPDUTL("BCSV")>0 S APCDPMOD=$O(^DIC(81.3,APCDPMOD,0)) Q
.S APCDPMOD=$O(^AUTTCMOD("B",APCDPMOD,0))
I APCDPMOD'="" S APCDPMOD="`"_APCDPMOD
;maw kill these cpt's after the template
S APCDCPTU(APCDUCPT)=APCDVSIT ;set variable since they were picked
Q
;
DISPICD ;-- display the icd code picklist for user
S APCDPDA=0 F I=1:1 S APCDPDA=$O(^AUPNVPOV("AD",APCDVSIT,APCDPDA)) Q:'APCDPDA D
. Q:'$G(^AUPNVPOV(APCDPDA,0))
. S APCDDXI=$P(^AUPNVPOV(APCDPDA,0),U)
. Q:APCDDXI=""
. ;Q:'$G(^ICD9(APCDDXI,0)) ;cmi/anch/maw 3/6/2007 orig line
. ;Q:'$D(^ICD9(APCDDXI,0)) ;cmi/anch/maw 3/6/2007 not picking up v codes
. Q:$P($$ICDDX^ICDEX(APCDDXI),U,1)<0
. ;S APCDDXC=$P(^ICD9(APCDDXI,0),U)
. S APCDDXC=$P($$ICDDX^ICDEX(APCDDXI,$$VD^APCLV(APCDVSIT)),U,2)
. ;S APCDDXE=$G(^ICD9(APCDDXI,1))
. S APCDDXE=$P($$ICDDX^ICDEX(APCDDXI,$$VD^APCLV(APCDVSIT)),U,4)
. W !,$G(I)_") Dx Code: "_$G(APCDDXC)_" Dx Desc: "_$G(APCDDXE)
. S APCDICDA(I)=APCDPDA_U_APCDDXC
Q:'$O(APCDICDA(""))
S APCDPICD=""
R !!,"Which DX should I attach to this procedure: ",APCDIRX:DTIME
Q:APCDIRX="^"
Q:APCDIRX=""
I '$G(APCDICDA(APCDIRX)) W !,"Not a valid Selection, Try Again." G DISPICD
S APCDPICD=$P($G(APCDICDA(APCDIRX)),U,2)
I $G(APCDPICD)'="" S APCDPICD=+$$CODEN^ICDEX(APCDPICD,80) I $P(APCDPICD,U)=-1 S APCDPICD=""
I APCDPICD'="" S APCDPICD="`"_APCDPICD
Q
;
DISPECD ;-- display the ecode picklist for user
S APCDI=1
S APCDDA=0 F S APCDDA=$O(^APCD3MV(APCDVSIT,11,APCDDA)) Q:'APCDDA D
. S APCD3ECD=$P($G(^APCD3MV(APCDVSIT,11,APCDDA,0)),U)
. Q:$E(APCD3ECD,1,1)'="E"
. W !,$G(APCDI)_") E Code: "_$G(APCD3ECD)
. S APCDECDA(APCDI)=APCDDA_U_APCD3ECD
. S APCDI=APCDI+1
Q:'$O(APCDECDA(""))
S APCDPECD=""
R !!,"Which E Code should I attach to this diagnosis: ",APCDEX:DTIME
Q:APCDEX="^"
Q:APCDEX=""
I '$G(APCDECDA(APCDEX)) W !,"Not a valid Selection, Try Again." G DISPECD
S APCDUECD=$P($G(APCDECDA(APCDEX)),U)
S APCDPECD=$P($G(APCDECDA(APCDEX)),U,2)
I $G(APCDPECD)'="" S APCDCECD=+$$CODEN^ICDEX(APCDPECD,80) I $P(APCDCECD,U)=-1 S APCDCECD=""
I APCDCECD="" S APCDPECD=""
;I APCDPECD'="" S APCDPECD="`"_APCDPECD
Q
;
FILE ; CALL FILE^DICN
K DD,DO
D FILE^DICN
K D,D0,D1,DA,DI,DIADD,DIC,DICR,DIE,DLAYGO,DQ,DR,DINUM
Q
;
UPDCODE ;-- add ecode to coded entry
Q:'$G(APCDDG1)
S DA=$G(APCDDG1)
Q:$P($G(^APCD3MV(APCD3IEN,11,DA,0)),U,4) ;e code exists
S DA(1)=APCD3IEN,DIE="^APCD3MV("_DA(1)_",11,",DR=".04////"_APCDECOD
D ^DIE
Q
;
OUT(APCDVSIT) ; EP - SEND HL7 MESSAGE TO 3M CODER
; called by PCC Data Entry and ADT Data Entry
D OUTMAIN
I $G(APCD3MER) D ERR
Q
;
OUTMAIN ; OUTBOUND MAINLINE LOGIC
D OUTINIT ; initialization/check protocol
D GEN^APCD3MG(APCDVSIT)
Q:$G(APCD3MER)
Q:APCDQ
S APCDIP=$G(APCD3MIP)
S BHLIP=APCDIP ;needed for protocol
W !!,"Now Sending to 3M"
S APCDBP=$O(^INTHPC("B","HL IHS 3M SENDER "_BHLIP,0))
Q:'APCDBP
F APCDJOB="FORMAT CONTROLLER","OUTPUT CONTROLLER" D
. S APCDY=$$CHK^BHLBCK(APCDJOB,"")
D CLNDST(BHLIP) ;12/2/2005 maw added to eliminate duplicate sends
S APCDMSG=$$A^INHB(APCDBP)
S X="BHL SEND TO 3M",DIC=101 D EN^XQOR
Q
;
CLNDST(IP) ;-- cleanout destination queue before creating message
N BHLDST
S BHLDST=$O(^INRHD("B","HL IHS 3M CODER "_IP,0))
Q:'BHLDST
K ^INLHDEST(BHLDST)
Q
;
OUTINIT ; OUTBOUND INITIALIZATION
S APCDQ=1
D:$G(APCD3MIP)="" OUTGETIP ; get IP address
S APCDQ=0
Q
;
OUTGETIP ; GET IP ADDRESS
I $G(APCD3MIP)="" D
. W !
. S DIR(0)="FO^1:2",DIR("A")="Enter your 3M Workstation ID "
. KILL DA D ^DIR KILL DIR
. S APCD3MIP=$G(X)
. Q
I APCD3MIP="" S APCD3MER="101^No ID address entered" D ERR Q
Q
;
ERR ;-- log the error here
W !,$P($G(APCD3MER),U,2) Q ;maw needs work
S APCDERR="D TRAP^BHLERR"
I $G(APCD3MER)="GEN" D
. S BHLEFL=APCDEFL
. S BHLFLD=APCDFLD
I $P($G(APCD3MER),U,2)]"" S APCD3MER="GEN"
S BHLERCD=APCD3MER X APCDERR
Q
;
EOJ ;-- kill variables
D EN^XBVK("APCD")
Q
;
APCD3M ; IHS/CMI/LAB - PCC TO 3M CODER INTERFACE ;
+1 ;;2.0;IHS PCC SUITE;**2,11**;MAY 14, 2009;Build 58
+2 ;;2.0
+3 ;
+4 ; This routine processes inbound HL7 messages from the 3M Coder
+5 ; and generates outbound HL7 messages to send to the 3M Coder.
+6 ;
+7 ; The entry point IN is called by the HL7 package to process
+8 ; an inbound message from the 3M Coder. An entry is generated
+9 ; in file 9001001.9 for the specified visit which contains the
+10 ; ICD codes and provider narratives required to generate the
+11 ; appropriate V POV and V PROCEDURE entries for this visit.
+12 ;
+13 ; The entry point OUT is called to generate an HL7 message
+14 ; containing patient demographic and medical data required
+15 ; by the 3M Coder to assign ICD codes to V POV entries. The
+16 ; visit IEN is passed in APCDVSIT.
+17 ;
+18 ;cmi/anch/maw 10/11/2005 modified due to change in 3m structure
+19 ;cmi/anch/maw 12/2/2005 maw added clean of destination queue before sending
+20 ;cmi/anch/maw 3/6/2007 maw modified DISPCPT to screen off description
+21 ;cmi/anch/maw 3/6/2007 maw modified DISPICD to get if a V code
+22 ;cmi/tucson/lab 11/12/2007 code set versioning
+23 ;
+24 ;do not enter at top of routine
QUIT
+25 ;
IN ; EP - PROCESS HL7 MESSAGE FROM 3M CODER
+1 ;maw this is where the inbound stuff starts
+2 NEW APCD3COD,APCD3IEN,APCD3NAR,APCDQ,I,J,X,Y
+3 DO INMAIN
+4 DO EOJ
+5 QUIT
+6 ;
INMAIN ; INBOUND MAINLINE LOGIC
+1 ; generate 9001001.9 entry
DO INSTALL
+2 QUIT
+3 ;
INSTALL ; GENERATE 9001001.9 ENTRY
+1 FOR J=1:1
SET X=$GET(APCDHL7M(J))
IF X=""
QUIT
Begin DoDot:1
+2 ; get segment
SET Y=$PIECE(X,"|")
+3 ; pv1 segment
IF Y="PV1"
DO IPV1
QUIT
+4 ; dg1 segment
IF Y="DG1"
DO IDG1
QUIT
+5 ; pr1 segment
IF Y="PR1"
DO IPR1
QUIT
+6 ; drg segment
IF Y="DRG"
DO IDRG
QUIT
+7 QUIT
End DoDot:1
IF $GET(APCD3MER)
QUIT
+8 QUIT
+9 ;
IPV1 ; PV1 SEGMENT
+1 SET X=$PIECE(X,"|",20)
+2 IF 'X
SET APCD3MER="200^No Visit IEN in Message"
DO ERR
QUIT
+3 SET DIC="^APCD3MV("
SET DIC(0)="L"
SET DLAYGO=9001001.9
SET DIC("DR")=".02////"_UIF
+4 SET DINUM=X
+5 DO FILE
+6 IF Y<0
SET APCD3MER="100^Error adding message to 3M file"
DO ERR
QUIT
+7 SET APCD3IEN=+Y
+8 QUIT
+9 ;
IDG1 ; DG1 SEGMENT
+1 ; get ICD9 code
SET APCD3COD=$PIECE($PIECE(X,"|",4),U)
+2 ;icd desc
SET APCD3TXT=$PIECE($PIECE(X,"|",4),U,2)
+3 ;diagnosis type
SET APCD3DTP=$PIECE(X,"|",7)
+4 ;don't file admit dx
IF $GET(APCD3DTP)="A"
QUIT
+5 ;I $E(APCD3COD,1,1)="E" S APCDECOD=APCD3COD D Q
+6 ;. I APCDECOD'["." S APCDECOD=$E(APCDECOD,1,4)_"."_$E(APCDECOD,5,999)
+7 ;. D UPDCODE Q
+8 IF $EXTRACT(APCD3COD,1,1)="E"
Begin DoDot:1
+9 IF APCD3COD'["."
SET APCD3COD=$EXTRACT(APCD3COD,1,4)_"."_$EXTRACT(APCD3COD,5,999)
End DoDot:1
+10 IF $EXTRACT(APCD3COD,1,1)'="E"
Begin DoDot:1
+11 IF APCD3COD'["."
SET APCD3COD=$EXTRACT(APCD3COD,1,3)_"."_$EXTRACT(APCD3COD,4,999)
End DoDot:1
+12 IF APCD3COD=""
SET APCD3MER="204^POV ICD9 code missing"
QUIT
+13 SET X=APCD3COD
SET DA(1)=APCD3IEN
SET DIC="^APCD3MV("_DA(1)_",11,"
SET DIC(0)="L"
SET DIC("P")=$PIECE(^DD(9001001.9,1101,0),U,2)
+14 SET DIC("DR")=".02///"_$GET(APCD3TXT)
+15 DO FILE
+16 IF Y<0
SET APCD3MER="210^Error adding POV to 3M file"
DO ERR
QUIT
+17 SET APCDDG1=+Y
+18 QUIT
+19 ;
IPR1 ; PR1 SEGMENT
+1 ; get ICD9 code
SET APCD3COD=$PIECE($PIECE(X,"|",4),U)
+2 ; cpt description
SET APCD3TXT=$PIECE($PIECE(X,"|",4),U,2)
+3 ; get type of coding system
SET APCDCTP=$PIECE($PIECE(X,"|",4),U,3)
+4 ; get modifier
SET APCD3MOD=$PIECE(X,"|",17)
+5 IF APCD3COD=""
SET APCD3MER="208^PROC ICD9 code missing"
QUIT
+6 ;goto cpt filer then quit
IF $GET(APCDCTP)="CP"
DO ICPT
QUIT
+7 ;hcps codes
IF $GET(APCDCTP)="H"
DO ICPT
QUIT
+8 ;non icd codes
IF $EXTRACT(APCD3COD,1)'?.N
DO ICPT
QUIT
+9 ;I $L(APCD3COD)>4 D ICPT Q ;cpt codes 10/25/2005 maw commented out
+10 IF APCD3COD'["."
SET APCD3COD=$EXTRACT(APCD3COD,1,2)_"."_$EXTRACT(APCD3COD,3,999)
+11 SET X=APCD3COD
SET DA(1)=APCD3IEN
SET DIC="^APCD3MV("_DA(1)_",12,"
SET DIC(0)="L"
SET DIC("P")=$PIECE(^DD(9001001.9,1201,0),U,2)
+12 SET DIC("DR")=".02///"_$GET(APCD3TXT)
+13 DO FILE
+14 IF Y<0
SET APCD3MER="211^Error adding Procedure to 3M file"
DO ERR
QUIT
+15 SET APCDPR1=+Y
+16 QUIT
+17 ;
IDRG ;-- get the drg
+1 SET APCD3DRG=$PIECE(X,"|",2)
+2 IF APCD3DRG'=""
SET APCD3DRG="DRG"_+APCD3DRG
+3 SET DIE="^APCD3MV("
SET DA=APCD3IEN
SET DR=".03///"_APCD3DRG
+4 DO ^DIE
+5 IF $DATA(Y)
SET APCD3MER="220^Error adding DRG to 3M file"
DO ERR
+6 QUIT
+7 ;
ICPT ;-- file cpt codes
+1 ;file cpt and text
SET X=APCD3COD_" - "_APCD3TXT
+2 SET DA(1)=APCD3IEN
SET DIC="^APCD3MV("_DA(1)_",13,"
SET DIC(0)="L"
SET DIC("P")=$PIECE(^DD(9001001.9,1301,0),U,2)
+3 IF $GET(APCD3MOD)?.N
SET DIC("DR")=".02////"_$GET(APCD3MOD)
+4 DO FILE
+5 QUIT
+6 ;
DISPCPT ;-- display the cpt picklist for user
+1 SET APCDDA=0
FOR I=1:1
SET APCDDA=$ORDER(^APCD3MV(APCDVSIT,13,APCDDA))
IF 'APCDDA
QUIT
Begin DoDot:1
+2 SET APCD3CPT=$PIECE($GET(^APCD3MV(APCDVSIT,13,APCDDA,0)),U)
+3 SET APCD3MOD=$PIECE($GET(^APCD3MV(APCDVSIT,13,APCDDA,0)),U,2)
+4 WRITE !,$GET(I)_") Cpt: "_$GET(APCD3CPT)_$SELECT($GET(APCD3MOD)'="":" Modifier: "_$GET(APCD3MOD),1:"")
+5 SET APCDCPTA(I)=APCDDA_U_APCD3CPT_U_APCD3MOD
End DoDot:1
+6 IF '$ORDER(APCDCPTA(""))
QUIT
+7 SET APCDPCPT=""
+8 READ !!,"Which CPT should I attach to this procedure: ",APCDRX:DTIME
+9 IF APCDRX="^"
QUIT
+10 IF APCDRX=""
QUIT
+11 IF '$GET(APCDCPTA(APCDRX))
WRITE !,"Not a valid Selection, Try Again."
GOTO DISPCPT
+12 SET APCDUCPT=$PIECE($GET(APCDCPTA(APCDRX)),U)
+13 ;S APCDPCPT=$P($G(APCDCPTA(APCDRX)),U,2) ;cmi/anch/maw 3/6/2007 orig line
+14 ;cmi/anch/maw 3/6/2007 modified
SET APCDPCPT=+$PIECE($GET(APCDCPTA(APCDRX)),U,2)
+15 SET APCDPMOD=$PIECE($GET(APCDPMOD(APCDRX)),U,3)
+16 ;I $G(APCDPCPT)'="" S APCDPCPT=$O(^ICPT("B",APCDPCPT,0))
+17 IF $GET(APCDPCPT)'=""
SET APCDPCPT=$PIECE($$CPT^ICPTCOD(APCDPCPT),U,1)
+18 IF APCDPCPT=-1
SET APCDPCPT=""
+19 IF APCDPCPT'=""
SET APCDPCPT="`"_APCDPCPT
+20 IF $GET(APCDPMOD)'=""
Begin DoDot:1
+21 IF $$VERSION^XPDUTL("BCSV")>0
SET APCDPMOD=$ORDER(^DIC(81.3,APCDPMOD,0))
QUIT
+22 SET APCDPMOD=$ORDER(^AUTTCMOD("B",APCDPMOD,0))
End DoDot:1
+23 IF APCDPMOD'=""
SET APCDPMOD="`"_APCDPMOD
+24 ;maw kill these cpt's after the template
+25 ;set variable since they were picked
SET APCDCPTU(APCDUCPT)=APCDVSIT
+26 QUIT
+27 ;
DISPICD ;-- display the icd code picklist for user
+1 SET APCDPDA=0
FOR I=1:1
SET APCDPDA=$ORDER(^AUPNVPOV("AD",APCDVSIT,APCDPDA))
IF 'APCDPDA
QUIT
Begin DoDot:1
+2 IF '$GET(^AUPNVPOV(APCDPDA,0))
QUIT
+3 SET APCDDXI=$PIECE(^AUPNVPOV(APCDPDA,0),U)
+4 IF APCDDXI=""
QUIT
+5 ;Q:'$G(^ICD9(APCDDXI,0)) ;cmi/anch/maw 3/6/2007 orig line
+6 ;Q:'$D(^ICD9(APCDDXI,0)) ;cmi/anch/maw 3/6/2007 not picking up v codes
+7 IF $PIECE($$ICDDX^ICDEX(APCDDXI),U,1)<0
QUIT
+8 ;S APCDDXC=$P(^ICD9(APCDDXI,0),U)
+9 SET APCDDXC=$PIECE($$ICDDX^ICDEX(APCDDXI,$$VD^APCLV(APCDVSIT)),U,2)
+10 ;S APCDDXE=$G(^ICD9(APCDDXI,1))
+11 SET APCDDXE=$PIECE($$ICDDX^ICDEX(APCDDXI,$$VD^APCLV(APCDVSIT)),U,4)
+12 WRITE !,$GET(I)_") Dx Code: "_$GET(APCDDXC)_" Dx Desc: "_$GET(APCDDXE)
+13 SET APCDICDA(I)=APCDPDA_U_APCDDXC
End DoDot:1
+14 IF '$ORDER(APCDICDA(""))
QUIT
+15 SET APCDPICD=""
+16 READ !!,"Which DX should I attach to this procedure: ",APCDIRX:DTIME
+17 IF APCDIRX="^"
QUIT
+18 IF APCDIRX=""
QUIT
+19 IF '$GET(APCDICDA(APCDIRX))
WRITE !,"Not a valid Selection, Try Again."
GOTO DISPICD
+20 SET APCDPICD=$PIECE($GET(APCDICDA(APCDIRX)),U,2)
+21 IF $GET(APCDPICD)'=""
SET APCDPICD=+$$CODEN^ICDEX(APCDPICD,80)
IF $PIECE(APCDPICD,U)=-1
SET APCDPICD=""
+22 IF APCDPICD'=""
SET APCDPICD="`"_APCDPICD
+23 QUIT
+24 ;
DISPECD ;-- display the ecode picklist for user
+1 SET APCDI=1
+2 SET APCDDA=0
FOR
SET APCDDA=$ORDER(^APCD3MV(APCDVSIT,11,APCDDA))
IF 'APCDDA
QUIT
Begin DoDot:1
+3 SET APCD3ECD=$PIECE($GET(^APCD3MV(APCDVSIT,11,APCDDA,0)),U)
+4 IF $EXTRACT(APCD3ECD,1,1)'="E"
QUIT
+5 WRITE !,$GET(APCDI)_") E Code: "_$GET(APCD3ECD)
+6 SET APCDECDA(APCDI)=APCDDA_U_APCD3ECD
+7 SET APCDI=APCDI+1
End DoDot:1
+8 IF '$ORDER(APCDECDA(""))
QUIT
+9 SET APCDPECD=""
+10 READ !!,"Which E Code should I attach to this diagnosis: ",APCDEX:DTIME
+11 IF APCDEX="^"
QUIT
+12 IF APCDEX=""
QUIT
+13 IF '$GET(APCDECDA(APCDEX))
WRITE !,"Not a valid Selection, Try Again."
GOTO DISPECD
+14 SET APCDUECD=$PIECE($GET(APCDECDA(APCDEX)),U)
+15 SET APCDPECD=$PIECE($GET(APCDECDA(APCDEX)),U,2)
+16 IF $GET(APCDPECD)'=""
SET APCDCECD=+$$CODEN^ICDEX(APCDPECD,80)
IF $PIECE(APCDCECD,U)=-1
SET APCDCECD=""
+17 IF APCDCECD=""
SET APCDPECD=""
+18 ;I APCDPECD'="" S APCDPECD="`"_APCDPECD
+19 QUIT
+20 ;
FILE ; CALL FILE^DICN
+1 KILL DD,DO
+2 DO FILE^DICN
+3 KILL D,D0,D1,DA,DI,DIADD,DIC,DICR,DIE,DLAYGO,DQ,DR,DINUM
+4 QUIT
+5 ;
UPDCODE ;-- add ecode to coded entry
+1 IF '$GET(APCDDG1)
QUIT
+2 SET DA=$GET(APCDDG1)
+3 ;e code exists
IF $PIECE($GET(^APCD3MV(APCD3IEN,11,DA,0)),U,4)
QUIT
+4 SET DA(1)=APCD3IEN
SET DIE="^APCD3MV("_DA(1)_",11,"
SET DR=".04////"_APCDECOD
+5 DO ^DIE
+6 QUIT
+7 ;
OUT(APCDVSIT) ; EP - SEND HL7 MESSAGE TO 3M CODER
+1 ; called by PCC Data Entry and ADT Data Entry
+2 DO OUTMAIN
+3 IF $GET(APCD3MER)
DO ERR
+4 QUIT
+5 ;
OUTMAIN ; OUTBOUND MAINLINE LOGIC
+1 ; initialization/check protocol
DO OUTINIT
+2 DO GEN^APCD3MG(APCDVSIT)
+3 IF $GET(APCD3MER)
QUIT
+4 IF APCDQ
QUIT
+5 SET APCDIP=$GET(APCD3MIP)
+6 ;needed for protocol
SET BHLIP=APCDIP
+7 WRITE !!,"Now Sending to 3M"
+8 SET APCDBP=$ORDER(^INTHPC("B","HL IHS 3M SENDER "_BHLIP,0))
+9 IF 'APCDBP
QUIT
+10 FOR APCDJOB="FORMAT CONTROLLER","OUTPUT CONTROLLER"
Begin DoDot:1
+11 SET APCDY=$$CHK^BHLBCK(APCDJOB,"")
End DoDot:1
+12 ;12/2/2005 maw added to eliminate duplicate sends
DO CLNDST(BHLIP)
+13 SET APCDMSG=$$A^INHB(APCDBP)
+14 SET X="BHL SEND TO 3M"
SET DIC=101
DO EN^XQOR
+15 QUIT
+16 ;
CLNDST(IP) ;-- cleanout destination queue before creating message
+1 NEW BHLDST
+2 SET BHLDST=$ORDER(^INRHD("B","HL IHS 3M CODER "_IP,0))
+3 IF 'BHLDST
QUIT
+4 KILL ^INLHDEST(BHLDST)
+5 QUIT
+6 ;
OUTINIT ; OUTBOUND INITIALIZATION
+1 SET APCDQ=1
+2 ; get IP address
IF $GET(APCD3MIP)=""
DO OUTGETIP
+3 SET APCDQ=0
+4 QUIT
+5 ;
OUTGETIP ; GET IP ADDRESS
+1 IF $GET(APCD3MIP)=""
Begin DoDot:1
+2 WRITE !
+3 SET DIR(0)="FO^1:2"
SET DIR("A")="Enter your 3M Workstation ID "
+4 KILL DA
DO ^DIR
KILL DIR
+5 SET APCD3MIP=$GET(X)
+6 QUIT
End DoDot:1
+7 IF APCD3MIP=""
SET APCD3MER="101^No ID address entered"
DO ERR
QUIT
+8 QUIT
+9 ;
ERR ;-- log the error here
+1 ;maw needs work
WRITE !,$PIECE($GET(APCD3MER),U,2)
QUIT
+2 SET APCDERR="D TRAP^BHLERR"
+3 IF $GET(APCD3MER)="GEN"
Begin DoDot:1
+4 SET BHLEFL=APCDEFL
+5 SET BHLFLD=APCDFLD
End DoDot:1
+6 IF $PIECE($GET(APCD3MER),U,2)]""
SET APCD3MER="GEN"
+7 SET BHLERCD=APCD3MER
XECUTE APCDERR
+8 QUIT
+9 ;
EOJ ;-- kill variables
+1 DO EN^XBVK("APCD")
+2 QUIT
+3 ;
