APCD3ME ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED ;
;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58
;
;
;
EN ;EP - called from input templates
D EN^XBNEW("EN1^APCD3ME","APCDVSIT;APCDDATE;APCDCAT;APCDPAT;APCDBEEP;AUPN*")
Q
;
EN1 ;EP - called from XBNEW
D PROCESS
D XIT
Q
;
XIT ;-- exit the routine
K APCDX
K X,Y
D ^XBFMK
Q
;
PROCESS ;-- lets process
S APCDOVRR=1
K APCD3MER
I '$G(APCDVSIT) W !!,"Valid visit missing!",! Q
S DIR(0)="Y",DIR("A")="Are you ready to send the visit information to 3M for coding",DIR("B")="Y" KILL DA D ^DIR KILL DIR
Q:$D(DIRUT)
Q:'Y
I $D(^APCD3MV("B",APCDVSIT)) W !!,$C(7),$C(7),"This visit has already been sent to 3M and coded. I will",!,"file the POV's and Procedures now.",! G FILE
D OUT^APCD3M(APCDVSIT)
I $D(APCD3MER) W !!,$C(7),$C(7),"Fix error and then come back into this visit and use the 3M mnemonic",!," to code the POV's." Q
PASS ;
W !!,"Visit information has been passed to 3M, switch screens, code the visit and",!,"then press enter below when you are finished coding.",!
F S DIR(0)="Y",DIR("A")="Are you done with the coding of the POV's on the 3M coder",DIR("B")="N" KILL DA D ^DIR KILL DIR Q:'$D(DTOUT) W " Timed out"
I $D(DIRUT)!('$G(Y)) W !!,"You are exiting without filing the POV's. You must come back into this",!,"visit and use the 3M mnemonic to code the POV's.",! Q
FILE ;file pov's
I '$D(^APCD3MV("B",APCDVSIT)) W !!,"The information has not come back from 3M yet.",!! G PASS
;file pov's and procedures using fileman templates
;
W !!,"The POV's and Procedures will now be filed into PCC. You will be prompted to ",!,"complete each entry.",!
I '$G(BHLIP) D
. W !,"I can't seem to figure out for 3M Workstation ID !!"
. S DIR(0)="FO^1:2",DIR("A")="Enter your 3M Workstation ID "
. KILL DA D ^DIR KILL DIR
. S BHLIP=$G(X)
. Q
S APCDBP=$O(^INTHPC("B","HL IHS 3M SENDER "_BHLIP,0))
L -^INRHB("RUN",APCDBP)
F I=1:1:100 K ^INRHB("RUN",APCDBP)
L -^INRHB("RUN",APCDBP)
S APCDX=0 F S APCDX=$O(^APCD3MV(APCDVSIT,11,APCDX)) Q:APCDX'=+APCDX D FILEPOV
D ECDCLEAN
S APCDX=0 F S APCDX=$O(^APCD3MV(APCDVSIT,12,APCDX)) Q:APCDX'=+APCDX D FILEPROC
D CPTCLEAN
S APCDX=0 F S APCDX=$O(^APCD3MV(APCDVSIT,13,APCDX)) Q:APCDX'=+APCDX D FILECPT
D FILEDRG ;file DRG and HCFA weight if exist
W !,"All done with 3M coding.",!
D DELETE ;delete 3m entry from file
Q
;
DELETE ;
Q:$G(APCD3MER)
S DA=APCDVSIT,DIK="^APCD3MV(" D ^DIK K DA,DIK
Q
;
FILEDRG ;
I $P(^AUPNVSIT(APCDVSIT,0),U,7)'="H" Q ;only hospitalizations
NEW APCDX,APCDY S APCDX=$P(^APCD3MV(APCDVSIT,0),U,3)
;put this in .34 of the visit file
S DA=APCDVSIT,DR=".34////"_$S(APCDX:"`"_APCDX,1:APCDX),DIE="^AUPNVSIT(" D ^DIE
I $D(Y) S APCDTERM="Error encountered updating DRG." D ERR
D ^XBFMK
K APCDX
Q
;
FILEPOV ;
NEW APCDICD,APCDICDP
S APCD3MVM=11
S X=$P(^APCD3MV(APCDVSIT,11,APCDX,0),U)
Q:$E(X,1,1)="E" ;don't file ecodes
S X=$$CODEN^ICDEX(X,80)
S X=+X I X=-1 S X=""
I 'X S APCDTERM="Can't find ICD Code "_$P(^APCD3MV(APCDVSIT,11,APCDX,0),U)_" in the ICD9 Table. Notify your supervisor." D ERR Q
;W !,"Filing POV (Diagnosis) ",$P(^ICD9(X,0),U)," - ",$P(^APCD3MV(APCDVSIT,11,APCDX,0),U,2)
W !,"Filing POV (Diagnosis) ",$P($$ICDDX^ICDEX(X,$$VD^APCLV(APCDVSIT)),U,2)," - ",$P(^APCD3MV(APCDVSIT,11,APCDX,0),U,2)
S X="`"_X
S APCDTPCC=""
X:$D(^DD(9000010.07,.01,12.1)) ^DD(9000010.07,.01,12.1) S DIC="^ICD9(",DIC(0)="Q" D ^DIC K DIC
I Y=-1 S APCDTERM="ICD Lookup failed. Notify your supervisor." D ERR Q
S APCDLOOK="`"_+Y ;,APCDTNAR=$P(^APCD3MV(APCDVSIT,11,APCDX,0),U,2)
;S APCDICOD=$P($G(^APCD3MV(APCDVSIT,11,APCDX,0)),U,4) ;injury code
S DIE="^AUPNVSIT(",DR="[APCD 3MPV (ADD)]",DA=APCDVSIT,DIE("NO^")=1 D ^DIE,^XBFMK
;delete entry in multiple
S DA=APCDX,DA(1)=APCDVSIT,DIK="^APCD3MV("_DA(1)_",11," D ^DIK K DA,DIK
W !
D ^XBFMK
Q
;
FILEPROC ;
NEW APCDICD,APCDICDP
S APCD3MVM=12
S X=$P(^APCD3MV(APCDVSIT,12,APCDX,0),U),X=+$$CODEN^ICDEX(X,80.1) I $P(X,U)=-1 S X=""
I 'X S APCDTERM="Can't find ICD Code "_$P(^APCD3MV(APCDVSIT,12,APCDX,0),U)_" in the ICD0 Table. Notify your supervisor." D ERR Q
W !,"Filing Procedure ",$P($$ICDOP^ICDEX(X,$$VD^APCLV(APCDVSIT),,"I"),U,2)," - ",$P(^APCD3MV(APCDVSIT,12,APCDX,0),U,2)
S X="`"_X
S APCDTPCC=""
X:$D(^DD(9000010.08,.01,12.1)) ^DD(9000010.08,.01,12.1) S DIC="^ICD0(",DIC(0)="Q" D ^DIC K DIC
I Y=-1 S APCDTERM="ICD0 Lookup failed. Notify your supervisor." D ERR Q
S APCDLOOK="`"_+Y ;,APCDTNAR=$P(^APCD3MV(APCDVSIT,12,APCDX,0),U,2)
S DIE="^AUPNVSIT(",DR="[APCD 3MOP (ADD)]",DA=APCDVSIT,DIE("NO^")=1 D ^DIE
S DA(1)=APCDVSIT,DA=APCDX,DIE="^APCD3MV("_APCDVSIT_",12,",DR=".01///@" D ^DIE,^XBFMK
W !
D ^XBFMK
Q
;
FILECPT ;-- lets file from the APCD 3MCPE MNEMONIC
NEW APCDCPT,APCDCPTP
S APCD3MVM=13
S X=$P(^APCD3MV(APCDVSIT,13,APCDX,0),U)
S X=$TR($P(X,"-")," ")
;S X=$O(^ICPT("B",X,0))
S X=$P($$CPT^ICPTCOD(X,$$VD^APCLV(APCDVSIT)),U,1) I X=-1 S X=""
I 'X S APCDTERM="Can't find CPT Code "_$P(^APCD3MV(APCDVSIT,13,APCDX,0),U)_" in the CPT Table. Notify your supervisor." D ERR Q
S APCDCMOD=$P(^APCD3MV(APCDVSIT,13,APCDX,0),U,2)
;W !,"Filing CPT ",$P(^ICPT(X,0),U)," - "_$P($G(^ICPT(X,0)),U,2)_" Modifier: ",$P(^APCD3MV(APCDVSIT,13,APCDX,0),U,2)
W !,"Filing CPT ",$P($$CPT^ICPTCOD(X,$$VD^APCLV(APCDVSIT)),U,2)," - "_$P($$CPT^ICPTCOD(X,$$VD^APCLV(APCDVSIT)),U,3)_" Modifier: ",$P(^APCD3MV(APCDVSIT,13,APCDX,0),U,2)
S X="`"_X
S APCDTPCC=""
X:$D(^DD(9000010.18,.01,12.1)) ^DD(9000010.18,.01,12.1) S DIC="^ICPT(",DIC(0)="Q" D ^DIC K DIC
I Y=-1 S APCDTERM="ICPT Lookup failed. Notify your supervisor." D ERR Q
S APCDLOOK="`"_+Y
S DIE="^AUPNVSIT(",DR="[APCD 3MCPE (ADD)]",DA=APCDVSIT,DIE("NO^")=1 D ^DIE
S DA(1)=APCDVSIT,DA=APCDX,DIE="^APCD3MV("_APCDVSIT_",13,",DR=".01///@" D ^DIE,^XBFMK
W !
D ^XBFMK
Q
;
ECDCLEAN ;-- cleanup ecodes from the dx multiple
S APCDECDA=0 F S APCDECDA=$O(^APCD3MV(APCDVSIT,11,APCDECDA)) Q:'APCDECDA D
. Q:$E($G(^APCD3MV(APCDVSIT,11,APCDECDA,0)),1,1)'="E"
. S DA(1)=APCDVSIT,DA=APCDECDA,DIE="^APCD3MV("_APCDVSIT_",11,",DR=".01///@" D ^DIE,^XBFMK
Q
;
CPTCLEAN ;-- cleanup cpt multiple before calling the 3mcpe mneumonic
S APCDCPDA=0 F S APCDCPDA=$O(APCDCPTU(APCDCPDA)) Q:'APCDCPDA D
. S APCDVSIT=$G(APCDCPTU(APCDCPDA))
. S DA(1)=APCDVSIT,DA=APCDCPDA,DIE="^APCD3MV("_APCDVSIT_",13,",DR=".01///@" D ^DIE,^XBFMK
Q
;
ERR ;
S APCD3MER=1 W !!,APCDTERM
S DA(1)=APCDVSIT,DA=APCDX,DIE="^APCD3MV("_APCDVSIT_",APCD3MVM,",DR=".03///"_$E(APCDTERM,1,50) D ^DIE
D ^XBFMK
Q
APCD3ME ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED ;
+1 ;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58
+2 ;
+3 ;
+4 ;
EN ;EP - called from input templates
+1 DO EN^XBNEW("EN1^APCD3ME","APCDVSIT;APCDDATE;APCDCAT;APCDPAT;APCDBEEP;AUPN*")
+2 QUIT
+3 ;
EN1 ;EP - called from XBNEW
+1 DO PROCESS
+2 DO XIT
+3 QUIT
+4 ;
XIT ;-- exit the routine
+1 KILL APCDX
+2 KILL X,Y
+3 DO ^XBFMK
+4 QUIT
+5 ;
PROCESS ;-- lets process
+1 SET APCDOVRR=1
+2 KILL APCD3MER
+3 IF '$GET(APCDVSIT)
WRITE !!,"Valid visit missing!",!
QUIT
+4 SET DIR(0)="Y"
SET DIR("A")="Are you ready to send the visit information to 3M for coding"
SET DIR("B")="Y"
KILL DA
DO ^DIR
KILL DIR
+5 IF $DATA(DIRUT)
QUIT
+6 IF 'Y
QUIT
+7 IF $DATA(^APCD3MV("B",APCDVSIT))
WRITE !!,$CHAR(7),$CHAR(7),"This visit has already been sent to 3M and coded. I will",!,"file the POV's and Procedures now.",!
GOTO FILE
+8 DO OUT^APCD3M(APCDVSIT)
+9 IF $DATA(APCD3MER)
WRITE !!,$CHAR(7),$CHAR(7),"Fix error and then come back into this visit and use the 3M mnemonic",!," to code the POV's."
QUIT
PASS ;
+1 WRITE !!,"Visit information has been passed to 3M, switch screens, code the visit and",!,"then press enter below when you are finished coding.",!
+2 FOR
SET DIR(0)="Y"
SET DIR("A")="Are you done with the coding of the POV's on the 3M coder"
SET DIR("B")="N"
KILL DA
DO ^DIR
KILL DIR
IF '$DATA(DTOUT)
QUIT
WRITE " Timed out"
+3 IF $DATA(DIRUT)!('$GET(Y))
WRITE !!,"You are exiting without filing the POV's. You must come back into this",!,"visit and use the 3M mnemonic to code the POV's.",!
QUIT
FILE ;file pov's
+1 IF '$DATA(^APCD3MV("B",APCDVSIT))
WRITE !!,"The information has not come back from 3M yet.",!!
GOTO PASS
+2 ;file pov's and procedures using fileman templates
+3 ;
+4 WRITE !!,"The POV's and Procedures will now be filed into PCC. You will be prompted to ",!,"complete each entry.",!
+5 IF '$GET(BHLIP)
Begin DoDot:1
+6 WRITE !,"I can't seem to figure out for 3M Workstation ID !!"
+7 SET DIR(0)="FO^1:2"
SET DIR("A")="Enter your 3M Workstation ID "
+8 KILL DA
DO ^DIR
KILL DIR
+9 SET BHLIP=$GET(X)
+10 QUIT
End DoDot:1
+11 SET APCDBP=$ORDER(^INTHPC("B","HL IHS 3M SENDER "_BHLIP,0))
+12 LOCK -^INRHB("RUN",APCDBP)
+13 FOR I=1:1:100
KILL ^INRHB("RUN",APCDBP)
+14 LOCK -^INRHB("RUN",APCDBP)
+15 SET APCDX=0
FOR
SET APCDX=$ORDER(^APCD3MV(APCDVSIT,11,APCDX))
IF APCDX'=+APCDX
QUIT
DO FILEPOV
+16 DO ECDCLEAN
+17 SET APCDX=0
FOR
SET APCDX=$ORDER(^APCD3MV(APCDVSIT,12,APCDX))
IF APCDX'=+APCDX
QUIT
DO FILEPROC
+18 DO CPTCLEAN
+19 SET APCDX=0
FOR
SET APCDX=$ORDER(^APCD3MV(APCDVSIT,13,APCDX))
IF APCDX'=+APCDX
QUIT
DO FILECPT
+20 ;file DRG and HCFA weight if exist
DO FILEDRG
+21 WRITE !,"All done with 3M coding.",!
+22 ;delete 3m entry from file
DO DELETE
+23 QUIT
+24 ;
DELETE ;
+1 IF $GET(APCD3MER)
QUIT
+2 SET DA=APCDVSIT
SET DIK="^APCD3MV("
DO ^DIK
KILL DA,DIK
+3 QUIT
+4 ;
FILEDRG ;
+1 ;only hospitalizations
IF $PIECE(^AUPNVSIT(APCDVSIT,0),U,7)'="H"
QUIT
+2 NEW APCDX,APCDY
SET APCDX=$PIECE(^APCD3MV(APCDVSIT,0),U,3)
+3 ;put this in .34 of the visit file
+4 SET DA=APCDVSIT
SET DR=".34////"_$SELECT(APCDX:"`"_APCDX,1:APCDX)
SET DIE="^AUPNVSIT("
DO ^DIE
+5 IF $DATA(Y)
SET APCDTERM="Error encountered updating DRG."
DO ERR
+6 DO ^XBFMK
+7 KILL APCDX
+8 QUIT
+9 ;
FILEPOV ;
+1 NEW APCDICD,APCDICDP
+2 SET APCD3MVM=11
+3 SET X=$PIECE(^APCD3MV(APCDVSIT,11,APCDX,0),U)
+4 ;don't file ecodes
IF $EXTRACT(X,1,1)="E"
QUIT
+5 SET X=$$CODEN^ICDEX(X,80)
+6 SET X=+X
IF X=-1
SET X=""
+7 IF 'X
SET APCDTERM="Can't find ICD Code "_$PIECE(^APCD3MV(APCDVSIT,11,APCDX,0),U)_" in the ICD9 Table. Notify your supervisor."
DO ERR
QUIT
+8 ;W !,"Filing POV (Diagnosis) ",$P(^ICD9(X,0),U)," - ",$P(^APCD3MV(APCDVSIT,11,APCDX,0),U,2)
+9 WRITE !,"Filing POV (Diagnosis) ",$PIECE($$ICDDX^ICDEX(X,$$VD^APCLV(APCDVSIT)),U,2)," - ",$PIECE(^APCD3MV(APCDVSIT,11,APCDX,0),U,2)
+10 SET X="`"_X
+11 SET APCDTPCC=""
+12 IF $DATA(^DD(9000010.07,.01,12.1))
XECUTE ^DD(9000010.07,.01,12.1)
SET DIC="^ICD9("
SET DIC(0)="Q"
DO ^DIC
KILL DIC
+13 IF Y=-1
SET APCDTERM="ICD Lookup failed. Notify your supervisor."
DO ERR
QUIT
+14 ;,APCDTNAR=$P(^APCD3MV(APCDVSIT,11,APCDX,0),U,2)
SET APCDLOOK="`"_+Y
+15 ;S APCDICOD=$P($G(^APCD3MV(APCDVSIT,11,APCDX,0)),U,4) ;injury code
+16 SET DIE="^AUPNVSIT("
SET DR="[APCD 3MPV (ADD)]"
SET DA=APCDVSIT
SET DIE("NO^")=1
DO ^DIE
DO ^XBFMK
+17 ;delete entry in multiple
+18 SET DA=APCDX
SET DA(1)=APCDVSIT
SET DIK="^APCD3MV("_DA(1)_",11,"
DO ^DIK
KILL DA,DIK
+19 WRITE !
+20 DO ^XBFMK
+21 QUIT
+22 ;
FILEPROC ;
+1 NEW APCDICD,APCDICDP
+2 SET APCD3MVM=12
+3 SET X=$PIECE(^APCD3MV(APCDVSIT,12,APCDX,0),U)
SET X=+$$CODEN^ICDEX(X,80.1)
IF $PIECE(X,U)=-1
SET X=""
+4 IF 'X
SET APCDTERM="Can't find ICD Code "_$PIECE(^APCD3MV(APCDVSIT,12,APCDX,0),U)_" in the ICD0 Table. Notify your supervisor."
DO ERR
QUIT
+5 WRITE !,"Filing Procedure ",$PIECE($$ICDOP^ICDEX(X,$$VD^APCLV(APCDVSIT),,"I"),U,2)," - ",$PIECE(^APCD3MV(APCDVSIT,12,APCDX,0),U,2)
+6 SET X="`"_X
+7 SET APCDTPCC=""
+8 IF $DATA(^DD(9000010.08,.01,12.1))
XECUTE ^DD(9000010.08,.01,12.1)
SET DIC="^ICD0("
SET DIC(0)="Q"
DO ^DIC
KILL DIC
+9 IF Y=-1
SET APCDTERM="ICD0 Lookup failed. Notify your supervisor."
DO ERR
QUIT
+10 ;,APCDTNAR=$P(^APCD3MV(APCDVSIT,12,APCDX,0),U,2)
SET APCDLOOK="`"_+Y
+11 SET DIE="^AUPNVSIT("
SET DR="[APCD 3MOP (ADD)]"
SET DA=APCDVSIT
SET DIE("NO^")=1
DO ^DIE
+12 SET DA(1)=APCDVSIT
SET DA=APCDX
SET DIE="^APCD3MV("_APCDVSIT_",12,"
SET DR=".01///@"
DO ^DIE
DO ^XBFMK
+13 WRITE !
+14 DO ^XBFMK
+15 QUIT
+16 ;
FILECPT ;-- lets file from the APCD 3MCPE MNEMONIC
+1 NEW APCDCPT,APCDCPTP
+2 SET APCD3MVM=13
+3 SET X=$PIECE(^APCD3MV(APCDVSIT,13,APCDX,0),U)
+4 SET X=$TRANSLATE($PIECE(X,"-")," ")
+5 ;S X=$O(^ICPT("B",X,0))
+6 SET X=$PIECE($$CPT^ICPTCOD(X,$$VD^APCLV(APCDVSIT)),U,1)
IF X=-1
SET X=""
+7 IF 'X
SET APCDTERM="Can't find CPT Code "_$PIECE(^APCD3MV(APCDVSIT,13,APCDX,0),U)_" in the CPT Table. Notify your supervisor."
DO ERR
QUIT
+8 SET APCDCMOD=$PIECE(^APCD3MV(APCDVSIT,13,APCDX,0),U,2)
+9 ;W !,"Filing CPT ",$P(^ICPT(X,0),U)," - "_$P($G(^ICPT(X,0)),U,2)_" Modifier: ",$P(^APCD3MV(APCDVSIT,13,APCDX,0),U,2)
+10 WRITE !,"Filing CPT ",$PIECE($$CPT^ICPTCOD(X,$$VD^APCLV(APCDVSIT)),U,2)," - "_$PIECE($$CPT^ICPTCOD(X,$$VD^APCLV(APCDVSIT)),U,3)_" Modifier: ",$PIECE(^APCD3MV(APCDVSIT,13,APCDX,0),U,2)
+11 SET X="`"_X
+12 SET APCDTPCC=""
+13 IF $DATA(^DD(9000010.18,.01,12.1))
XECUTE ^DD(9000010.18,.01,12.1)
SET DIC="^ICPT("
SET DIC(0)="Q"
DO ^DIC
KILL DIC
+14 IF Y=-1
SET APCDTERM="ICPT Lookup failed. Notify your supervisor."
DO ERR
QUIT
+15 SET APCDLOOK="`"_+Y
+16 SET DIE="^AUPNVSIT("
SET DR="[APCD 3MCPE (ADD)]"
SET DA=APCDVSIT
SET DIE("NO^")=1
DO ^DIE
+17 SET DA(1)=APCDVSIT
SET DA=APCDX
SET DIE="^APCD3MV("_APCDVSIT_",13,"
SET DR=".01///@"
DO ^DIE
DO ^XBFMK
+18 WRITE !
+19 DO ^XBFMK
+20 QUIT
+21 ;
ECDCLEAN ;-- cleanup ecodes from the dx multiple
+1 SET APCDECDA=0
FOR
SET APCDECDA=$ORDER(^APCD3MV(APCDVSIT,11,APCDECDA))
IF 'APCDECDA
QUIT
Begin DoDot:1
+2 IF $EXTRACT($GET(^APCD3MV(APCDVSIT,11,APCDECDA,0)),1,1)'="E"
QUIT
+3 SET DA(1)=APCDVSIT
SET DA=APCDECDA
SET DIE="^APCD3MV("_APCDVSIT_",11,"
SET DR=".01///@"
DO ^DIE
DO ^XBFMK
End DoDot:1
+4 QUIT
+5 ;
CPTCLEAN ;-- cleanup cpt multiple before calling the 3mcpe mneumonic
+1 SET APCDCPDA=0
FOR
SET APCDCPDA=$ORDER(APCDCPTU(APCDCPDA))
IF 'APCDCPDA
QUIT
Begin DoDot:1
+2 SET APCDVSIT=$GET(APCDCPTU(APCDCPDA))
+3 SET DA(1)=APCDVSIT
SET DA=APCDCPDA
SET DIE="^APCD3MV("_APCDVSIT_",13,"
SET DR=".01///@"
DO ^DIE
DO ^XBFMK
End DoDot:1
+4 QUIT
+5 ;
ERR ;
+1 SET APCD3MER=1
WRITE !!,APCDTERM
+2 SET DA(1)=APCDVSIT
SET DA=APCDX
SET DIE="^APCD3MV("_APCDVSIT_",APCD3MVM,"
SET DR=".03///"_$EXTRACT(APCDTERM,1,50)
DO ^DIE
+3 DO ^XBFMK
+4 QUIT
