ABMDVST1 ; IHS/ASDST/DMJ - PCC VISIT STUFF - PART 2 (PURPOSE OF VISIT) ;
;;2.6;IHS 3P BILLING SYSTEM;**10,14,16,18,21**;NOV 12, 2009;Build 379
;Original;TMD;03/26/96 12:11 PM
;
;IHS/ASDS/DMJ - 10/31/00 - V2.4 Patch 3 - NOIS NDA-0500-180002
; Modify code to pick up e-codes from PCC if exist
;
;IHS/SD/SDR - 11/4/02 - V2.5 P2 - NDA-0500-180002
; Modified to pick up all e-codes from PCC
;IHS/SD/SDR - v2.5 p9 - IM18472
; Modified to make sure there aren't two of the same priority ICD
;IHS/SD/SDR - v2.5 p10 - IM21619
; Added code to populate claim number from Workman's Comp file
;IHS/SD/SDR - v2.5 p13 - IM25840
; <UNDEF>DX+39^ABMDEMLC caused when there is a primary code with
; an E-code and a secondary (E-code s/b secondary)
;IHS/SD/SDR - v2.5 p13 - POA changes
;
;IHS/SD/SDR - v2.6
;IHS/SD/SDR - 2.6*14 - Populated .06 field of 17 multiple if ICD10 code. 002F
;IHS/SD/SDR - 2.6*14 - ICD10 SNOMED - populate SNOMED and dual coding fields from V POV file.
;IHS/SD/SDR - 2.6*14 - ICD10 ICD Indicator - Added code to check for 3P Claim .021 field to see if it has been set for claim;
; acts as override for ICD-10 Effective Date
;IHS/SD/SDR - 2.6*14 - Updated DX^ABMCVAPI to be numeric
;IHS/SD/SDR - 2.6*14 - Made change for E-codes if there are any for ICD-10 and to keep ICD9 and ICD10 separate.
;IHS/SD/SDR - 2.6*14 - CR3445 - Made change for sequencing; with ICD10 changes, if there were E-codes present the sequencing was getting
; messed up.
;IHS/SD/SDR - 2.6*16 - HEAT200359 - Made changes so CASE NUMBER will populated with the claim number from Reg if it is
; a workman's comp claim. Wasn't doing lookup correctly (data needed wasn't defined).
;IHS/SD/SDR - 2.6*16 - HEAT217211 - Added code to populated External Cause 2, External Cause 3, Place of Occurrence, and Place of Occurrence (E849)
;IHS/SD/SDR - 2.6*18 - HEAT239392 - Correction for E-code not crossing over from PCC Visit.
;IHS/SD/SDR - 2.6*21 - HEAT234796 - Made change so only visits with a Service Category of 'H' for Hospitalization will have the Present on Admission (POA)
; indicator cross over onto the claim in TPB.
;
;
Q:ABMIDONE
I $O(^DIC(40.7,"B","EMERGENCY MEDICINE",""))=ABMP("CLN") S ABMP("C0")=^ABMDCLM(DUZ(2),ABMP("CDFN"),0) D ASET^ABMDE3B
;E3B sets special UB-82 codes
I $O(^DIC(40.7,"B","EPSDT",""))=ABMP("CLN") S Y=67 D SP^ABMDE3B
I $O(^DIC(40.7,"B","FAMILY PLANNING",""))=ABMP("CLN") S Y=70 D SP^ABMDE3B
;
I +$P($G(^ABMDCLM(DUZ(2),ABMP("CDFN"),0)),U,21)=9 S ABMP("ICD10")=(ABMP("VDT")+1) ;abm*2.6*14 ICD10 ICD Indicator
I +$P($G(^ABMDCLM(DUZ(2),ABMP("CDFN"),0)),U,21)=10 S ABMP("ICD10")=(ABMP("VDT")-1) ;abm*2.6*14 ICD10 ICD Indicator
I (+$G(ABMP("INS"))'=0)&(+$G(ABMP("ICD10"))=0) S ABMP("ICD10")=$P($G(^ABMNINS(ABMP("LDFN"),ABMP("INS"),0)),U,12) ;abm*2.6*14 ICD10 002F
N BP,ABMPRI
S ABM=0
F S ABM=$O(^ABMDCLM(DUZ(2),ABMP("CDFN"),17,ABM)) Q:'ABM D
.S Y=^ABMDCLM(DUZ(2),ABMP("CDFN"),17,ABM,0)
.I +$P(Y,U,2)=0 Q ;skip if not sequenced ;abm*2.6*14 ICD10 002F
.S ABMPRI($P(Y,U,2),+Y)=""
.S ABMTYP=$S($P($G(^ABMDCLM(DUZ(2),ABMP("CDFN"),17,ABM,0)),U,6)=1:"ICD10",1:"ICD9")
S ABM=0
;ABMR("P") is a counter used to keep track of priorities already used
;Start with 2 unless there already exist priorities
;S ABMR("P")=$S($D(ABMPRI):$O(ABMPRI(""),-1)+1,1:2) ;abm*2.6*10 NOHEAT
;changed so default would be 1, not 2 for priority; if only 1 DX user would have to resequence
;S ABMR("P")=$S($D(ABMPRI):$O(ABMPRI(""),-1)+1,1:1) ;abm*2.6*10 NOHEAT ;abm*2.6*14 CR3445
S ABMR("P")=$S($D(ABMPRI):$O(ABMPRI(""),-1)+1,1:0) ;abm*2.6*10 NOHEAT ;abm*2.6*14 CR3445
;First check billing pointer for POV
S BP=$P(^AUPNVSIT(ABMVDFN,0),U,28)
I BP]"" D
.F S ABM=$O(^AUPNVPOV("AD",BP,ABM)) Q:'ABM K DR,DIC("DR") D POVCHK
.K DIC
S ABM=0
POV F S ABM=$O(^AUPNVPOV("AD",ABMVDFN,ABM)) Q:'ABM K DR,DIC("DR") D POVCHK
I $D(ABMPRI),'$O(ABMPRI($O(ABMPRI("")))) S ABMP("CORRSDIAG")=$O(ABMPRI(""))
K DIC
Q
;
POVCHK ;POV is dinumed. Each POV is only entered once.
N ABMPOV0,ABMICD
I '$D(^AUPNVPOV(ABM,0)) Q
S ABMPOV0=^AUPNVPOV(ABM,0)
S ABMPOV11=$G(^AUPNVPOV(ABM,11)) ;abm*2.6*14 ICD10 SNOMED
S ABMICD=$P($$DX^ABMCVAPI(+ABMPOV0,ABMP("VDT")),U,2) ;CSV-c
S ABMTYP=$S($P($$DX^ABMCVAPI(+ABMPOV0,ABMP("VDT")),U,20)=30:"ICD10",1:"ICD9") ;abm*2.6*14 ICD10 002F
;start old abm*2.6*18 IHS/SD/SDR HEAT239392
;start new code abm*2.6*14 E-codes
;S ABM("ECODE")=0
;I ABMP("VDT")<3150930 S ABM("ECODE")=+$P(ABMPOV0,U,9)
;I ABMP("VDT")>3151001&((ABMP("VDT")>ABMP("ICD10"))!(ABMP("VDT")=ABMP("ICD10"))) S ABM("ECODE")=+$P(ABMPOV0,U,9)
;I ABMP("VDT")>3151001&(ABMP("VDT")<ABMP("ICD10")) S ABM("ECODE")=+$P(ABMPOV0,U,25)
;I ABM("ECODE")'=0 D
;end new code abm*2.6*14 E-codes
;end old start new abm*2.6*18 IHS/SD/SDR HEAT239392
S ABM("ECODE")=0
;I ABMP("VDT")<ABMP("ICD10") S ABM("ECODE")=+$P(ABMPOV0,U,25)
;I (ABMP("VDT")>ABMP("ICD10"))!(ABMP("VDT")=ABMP("ICD10")) S ABM("ECODE")=+$P(ABMPOV0,U,9)
I ((ABMP("VDT")'<ABMP("ICD10"))&($P($$DX^ABMCVAPI(+$P(ABMPOV0,U,9),ABMP("VDT")),U,20)=30)) S ABM("ECODE")=+$P(ABMPOV0,U,9)
I ((ABMP("VDT")<ABMP("ICD10"))&($P($$DX^ABMCVAPI(+$P(ABMPOV0,U,9),ABMP("VDT")),U,20)'=30)) S ABM("ECODE")=+$P(ABMPOV0,U,9)
I ((ABMP("VDT")<ABMP("ICD10"))&(+$P(ABMPOV0,U,25)'=0)) S ABM("ECODE")=+$P(ABMPOV0,U,25)
;end new abm*2.6*18 IHS/SD/SDR HEAT239392
;Through the use of the ABMPRI array it would be possible to change
;the priorities of existing entries if needed.
;ABMR("PX") is priority of diagnosis
;Piece 12 is primary/secondary
;Only a non-V code can be given priority 1
;S ABMR("PX")=$S($D(ABMPRI(1))=10:ABMR("P"),$E(ABMICD,1)="V":ABMR("P"),$P(ABMPOV0,U,12)="P":1,1:ABMR("P")) ;abm*2.6*14 CR3445
S ABMR("PX")=ABMR("P") ;abm*2.6*14 CR3445
S ABMR("P")=ABMR("P")+1 ;abm*2.6*10 NOHEAT
; Do not do this section for I or D visits
I ABMP("V0")=ABMCHV0!("ID"'[$P(ABMCHV0,U,7)) D
.;Employment related POV put Y into employment rel field in claim
.I $P(ABMPOV0,U,7)=4 D
..S DIE="^ABMDCLM(DUZ(2),"
..S DA=ABMP("CDFN"),DR=".91////Y"
..;I $P(ABML(ABMP("PRI"),ABMP("INS")),U,2)'="" S DR=DR_+";.48////"_$P($G(^AUPNWC(ABMP("PDFN"),11,$P(ABML(ABMP("PRI"),ABMP("INS")),U,2),0)),U,4) ;abm*2.6*16 IHS/SD/SDR HEAT200359
..;start new abm*2.6*16 IHS/SD/SDR HEAT200359
..N ABML S ABML=""
..D ELG^ABMDLCK(ABMVDFN,.ABML,ABMP("PDFN"),ABMP("VDT"))
..S ABMT("PRI")=0,ABMWFLG=0
..F S ABMT("PRI")=$O(ABML(ABMT("PRI"))) Q:'ABMT("PRI") D Q:ABMWFLG=1
...S ABMT("INS")=$O(ABML(ABMT("PRI"),0))
...Q:ABMT("INS")'=ABMP("INS") ;not correct insurer
...I $P(ABML(ABMT("PRI"),ABMP("INS")),U,3)'="W" Q ;workman's comp only past this
...I +$P(ABML(ABMT("PRI"),ABMP("INS")),U,2)'=0 S DR=DR_";.48////"_$P($G(^AUPNWC(ABMP("PDFN"),11,$P(ABML(ABMT("PRI"),ABMP("INS")),U,2),0)),U,4)
..;end new abm*2.6*16 IHS/SD/SDR HEAT200359
..D ^DIE
..K DR
.;Injury date
.I $P(ABMPOV0,U,13)]"" D
..S DIE="^ABMDCLM(DUZ(2),"
..S DA=ABMP("CDFN")
..S DR=".82////"_$P(ABMPOV0,U,13) D ^DIE K DR
.;I $P(ABMPOV0,U,9)]"" D ;abm*2.6*14 E-codes
.I ABM("ECODE")'=0 D ;abm*2.6*14 E-codes
..;Checking to see if 1st 3 chars of ICD code are E81
..;S ABM("ECODE")=$P(ABMPOV0,"^",9) ;abm*2.6*14 E-codes
..;S ABM("Y")=$S($E($P($$DX^ABMCVAPI(ABM("ECODE"),ABMP("VDT")),U,2),1,3)="E81":1,1:5) ;CSV-c ;abm*2.6*14 updated API call
..S ABM("Y")=$S($E($P($$DX^ABMCVAPI(+ABM("ECODE"),ABMP("VDT")),U,2),1,3)="E81":1,1:5) ;CSV-c ;abm*2.6*14 updated API call
..S ABM("X")=$S($P(ABMPOV0,U,13):$P(ABMPOV0,U,13),1:ABMP("VDT"))
..D ACCODE^ABMDE3A K DIC
..;X is set to Accident type code
..S X=$S(ABM("Y")=1:ABM("Y"),$P(ABMPOV0,U,7)=4:4,1:5)
..S DIE="^ABMDCLM(DUZ(2),"
..S DA=ABMP("CDFN")
..S DR=".83////"_X D ^DIE
..S DR=".857////"_ABM("ECODE") D ^DIE
..;K ABM("ECODE") ;abm*2.6*14 E-codes
;Diagnosis subfile is at node 17
S X=$P(ABMPOV0,U) ;DX code
I +$P(ABMPOV0,U,24)'=0&(ABMP("ICD10")>ABMP("VDT")) S X=$P(ABMPOV0,U,24),ABMTYP="ICD9" ;abm*2.6*14 dual coding - ICD9 dual coding field
S DINUM=X,ABMR("NAR")=$P(ABMPOV0,U,4) ;DINUM and provider narrative
S DA(1)=ABMP("CDFN")
S DIC="^ABMDCLM(DUZ(2),"_DA(1)_",17,"
S DIC(0)="LE" K DD,DO
S DIC("P")=$P(^DD(9002274.3,17,0),U,2)
;S DIC("DR")=".02////"_ABMR("PX")_";.03////"_ABMR("NAR") ;abm*2.6*14 ICD10 002F
I (ABMP("ICD10")<ABMP("VDT")!(ABMP("ICD10")=ABMP("VDT")))&(ABMTYP="ICD10") S DIC("DR")=".02////"_ABMR("P") ;abm*2.6*14 ICD10 002F
I (ABMP("ICD10")>ABMP("VDT")&(ABMTYP="ICD9")) S DIC("DR")=".02////"_ABMR("P") ;abm*2.6*14 ICD10 002F
S DIC("DR")=$S($G(DIC("DR"))'="":DIC("DR")_";",1:"")_".03////"_ABMR("NAR") ;abm*2.6*14 ICD10 002F
;S DIC("DR")=DIC("DR")_";.04////"_$P(ABMPOV0,U,9) ;E-code ;abm*2.6*14 E-codes
S:(+ABM("ECODE")'=0) DIC("DR")=DIC("DR")_";.04////"_ABM("ECODE") ;E-code ;abm*2.6*14 E-codes
;S DIC("DR")=DIC("DR")_";.05////"_$P(ABMPOV0,U,22) ;abm*2.6*21 IHS/SD/SDR HEAT234796
I SERVCAT="H" S DIC("DR")=DIC("DR")_";.05////"_$P(ABMPOV0,U,22) ;abm*2.6*21 IHS/SD/SDR HEAT234796
I $P($$DX^ABMCVAPI(+X,ABMP("VDT")),U,20)=30 S DIC("DR")=DIC("DR")_";.06////1" ;abm*2.6*14 ICD10 002F and updated API call
;start new code abm*2.6*14 ICD10 SNOMED/dual coding
S:$P(ABMPOV0,U,18)'="" DIC("DR")=DIC("DR")_";.07////"_$P(ABMPOV0,U,18) ;abm*2.6*16 IHS/SD/SDR HEAT217211
S:$P(ABMPOV0,U,19)'="" DIC("DR")=DIC("DR")_";.08////"_$P(ABMPOV0,U,19) ;abm*2.6*16 IHS/SD/SDR HEAT217211
S:$P(ABMPOV0,U,21)'="" DIC("DR")=DIC("DR")_";.09////"_$P(ABMPOV0,U,21) ;abm*2.6*16 IHS/SD/SDR HEAT217211
S:$P(ABMPOV0,U,24)'="" DIC("DR")=DIC("DR")_";21////"_$P(ABMPOV0,U,24)
S:$P(ABMPOV0,U,25)'="" DIC("DR")=DIC("DR")_";23////"_$P(ABMPOV0,U,25)
S:$P(ABMPOV0,U,26)'="" DIC("DR")=DIC("DR")_";24////"_$P(ABMPOV0,U,26)
S:$P(ABMPOV0,U,27)'="" DIC("DR")=DIC("DR")_";25////"_$P(ABMPOV0,U,27)
S:$P(ABMPOV0,U,28)'="" DIC("DR")=DIC("DR")_";26////"_$P(ABMPOV0,U,28) ;abm*2.6*16 IHS/SD/SDR HEAT217211
S:$P(ABMPOV11,U)'="" DIC("DR")=DIC("DR")_";11////"_$P(ABMPOV11,U)
S:$P(ABMPOV11,U,2)'="" DIC("DR")=DIC("DR")_";13////"_$P(ABMPOV11,U,2)
S:$P(ABMPOV11,U,3)'="" DIC("DR")=DIC("DR")_";15////"_$P(ABMPOV11,U,3)
;end new code ICD10 SNOMED/dual coding
I $D(^ABMDCLM(DUZ(2),ABMP("CDFN"),17,DINUM,0)) D Q
.S DIE=DIC
.S DA=DINUM
.S DR=$P(DIC("DR"),";",2)
.K DINUM,DIC
.D ^DIE
.K DIE,X,Y
S ABMPRI(ABMR("PX"),X)=""
K DD,DO D FILE^DICN
;I ABMR("PX")>1 S ABMR("P")=ABMR("P")+1 ;abm*2.6*14 ICD10 002F
I ABMP("ICD10")<ABMP("VDT")!(ABMP("ICD10")=ABMP("VDT")),ABMR("PX")>1 S ABMR("P")=ABMR("P")+1 ;abm*2.6*14 ICD10 002F
K DIC,X,Y
K DIC("DR")
;S ABMECD=$P(ABMPOV0,U,9) ;E-code ;abm*2.6*14 E-codes
S ABMECD=ABM("ECODE") ;E-code ;abm*2.6*14 E-codes
;Q:ABMECD="" ;abm*2.6*14 E-codes
Q:ABMECD=0 ;abm*2.6*14 E-codes
;entry already exists in array; shift others down one to make room
;abm*2.6*14 start old CR3445
;I ABMR("P")-1'=1,($O(ABMPRI(1,0))'="") D
;.S ABMOPRI=999
;.F S ABMOPRI=$O(ABMPRI(ABMOPRI),-1) Q:ABMOPRI=1 D Q:DA=$P(ABMPOV0,U)
;..S DA(1)=ABMP("CDFN")
;..S DIE="^ABMDCLM(DUZ(2),"_DA(1)_",17,"
;..S DA=$O(ABMPRI(ABMOPRI,0))
;..Q:DA=$P(ABMPOV0,U)
;..S DR=".02////"_(+ABMOPRI+1)
;..;S DR=DR_";.05////"_+$P($G(ABMPOV0),U,21) ;abm*2.6*14
;..S:($P($G(ABMPOV0),U,22)'="") DR=DR_";.05////"_$P($G(ABMPOV0),U,22) ;abm*2.6*14
;..I ABMTYP="ICD10" S DR=DR_";.06////1" ;abm*2.6*14 E-codes ICD Indicator
;..D ^DIE
;..S ABMPRI(ABMOPRI+1,DA)=""
;..K ABMPRI(ABMOPRI,DA)
;..S ABMR("P")=ABMR("P")-1
;end old CR3445
S ABMR("P")=ABMR("P")+1 ;abm*2.6*14 CR3445
S (DINUM,X)=ABMECD
S DA(1)=ABMP("CDFN")
S DIC="^ABMDCLM(DUZ(2),"_DA(1)_",17,"
S DIC(0)="LE" K DD,DO
S DIC("P")=$P(^DD(9002274.3,17,0),U,2)
;S DIC("DR")=".02////"_ABMR("P")_";.03////"_ABMR("NAR") ;abm*2.6*14 ICD10 002F
I ABMP("ICD10")<ABMP("VDT")!(ABMP("ICD10")=ABMP("VDT"))&(ABMTYP="ICD10") S DIC("DR")=".02////"_ABMR("P") ;abm*2.6*14 ICD10 002F
I (ABMP("ICD10")>ABMP("VDT")&(ABMTYP="ICD9")) S DIC("DR")=".02////"_ABMR("P") ;abm*2.6*14 ICD10 002F
S DIC("DR")=$S($G(DIC("DR"))'="":DIC("DR")_";",1:"")_".03////"_ABMR("NAR") ;abm*2.6*14 ICD10 002F
S DIC("DR")=DIC("DR")_";.05////"_$P($G(ABMPOV0),U,22)
I ABMTYP="ICD10" S DIC("DR")=DIC("DR")_";.06////1" ;abm*2.6*14 E-codes ICD Indicator
S ABMPRI(ABMR("P"),ABMECD)=""
K DD,DO D FILE^DICN
;I ABMR("PX")>0 S ABMR("P")=ABMR("P")+1 ;abm*2.6*14 CR3445
K DIC,X,Y
Q
ABMDVST1 ; IHS/ASDST/DMJ - PCC VISIT STUFF - PART 2 (PURPOSE OF VISIT) ;
+1 ;;2.6;IHS 3P BILLING SYSTEM;**10,14,16,18,21**;NOV 12, 2009;Build 379
+2 ;Original;TMD;03/26/96 12:11 PM
+3 ;
+4 ;IHS/ASDS/DMJ - 10/31/00 - V2.4 Patch 3 - NOIS NDA-0500-180002
+5 ; Modify code to pick up e-codes from PCC if exist
+6 ;
+7 ;IHS/SD/SDR - 11/4/02 - V2.5 P2 - NDA-0500-180002
+8 ; Modified to pick up all e-codes from PCC
+9 ;IHS/SD/SDR - v2.5 p9 - IM18472
+10 ; Modified to make sure there aren't two of the same priority ICD
+11 ;IHS/SD/SDR - v2.5 p10 - IM21619
+12 ; Added code to populate claim number from Workman's Comp file
+13 ;IHS/SD/SDR - v2.5 p13 - IM25840
+14 ; <UNDEF>DX+39^ABMDEMLC caused when there is a primary code with
+15 ; an E-code and a secondary (E-code s/b secondary)
+16 ;IHS/SD/SDR - v2.5 p13 - POA changes
+17 ;
+18 ;IHS/SD/SDR - v2.6
+19 ;IHS/SD/SDR - 2.6*14 - Populated .06 field of 17 multiple if ICD10 code. 002F
+20 ;IHS/SD/SDR - 2.6*14 - ICD10 SNOMED - populate SNOMED and dual coding fields from V POV file.
+21 ;IHS/SD/SDR - 2.6*14 - ICD10 ICD Indicator - Added code to check for 3P Claim .021 field to see if it has been set for claim;
+22 ; acts as override for ICD-10 Effective Date
+23 ;IHS/SD/SDR - 2.6*14 - Updated DX^ABMCVAPI to be numeric
+24 ;IHS/SD/SDR - 2.6*14 - Made change for E-codes if there are any for ICD-10 and to keep ICD9 and ICD10 separate.
+25 ;IHS/SD/SDR - 2.6*14 - CR3445 - Made change for sequencing; with ICD10 changes, if there were E-codes present the sequencing was getting
+26 ; messed up.
+27 ;IHS/SD/SDR - 2.6*16 - HEAT200359 - Made changes so CASE NUMBER will populated with the claim number from Reg if it is
+28 ; a workman's comp claim. Wasn't doing lookup correctly (data needed wasn't defined).
+29 ;IHS/SD/SDR - 2.6*16 - HEAT217211 - Added code to populated External Cause 2, External Cause 3, Place of Occurrence, and Place of Occurrence (E849)
+30 ;IHS/SD/SDR - 2.6*18 - HEAT239392 - Correction for E-code not crossing over from PCC Visit.
+31 ;IHS/SD/SDR - 2.6*21 - HEAT234796 - Made change so only visits with a Service Category of 'H' for Hospitalization will have the Present on Admission (POA)
+32 ; indicator cross over onto the claim in TPB.
+33 ;
+34 ;
+35 IF ABMIDONE
QUIT
+36 IF $ORDER(^DIC(40.7,"B","EMERGENCY MEDICINE",""))=ABMP("CLN")
SET ABMP("C0")=^ABMDCLM(DUZ(2),ABMP("CDFN"),0)
DO ASET^ABMDE3B
+37 ;E3B sets special UB-82 codes
+38 IF $ORDER(^DIC(40.7,"B","EPSDT",""))=ABMP("CLN")
SET Y=67
DO SP^ABMDE3B
+39 IF $ORDER(^DIC(40.7,"B","FAMILY PLANNING",""))=ABMP("CLN")
SET Y=70
DO SP^ABMDE3B
+40 ;
+41 ;abm*2.6*14 ICD10 ICD Indicator
IF +$PIECE($GET(^ABMDCLM(DUZ(2),ABMP("CDFN"),0)),U,21)=9
SET ABMP("ICD10")=(ABMP("VDT")+1)
+42 ;abm*2.6*14 ICD10 ICD Indicator
IF +$PIECE($GET(^ABMDCLM(DUZ(2),ABMP("CDFN"),0)),U,21)=10
SET ABMP("ICD10")=(ABMP("VDT")-1)
+43 ;abm*2.6*14 ICD10 002F
IF (+$GET(ABMP("INS"))'=0)&(+$GET(ABMP("ICD10"))=0)
SET ABMP("ICD10")=$PIECE($GET(^ABMNINS(ABMP("LDFN"),ABMP("INS"),0)),U,12)
+44 NEW BP,ABMPRI
+45 SET ABM=0
+46 FOR
SET ABM=$ORDER(^ABMDCLM(DUZ(2),ABMP("CDFN"),17,ABM))
IF 'ABM
QUIT
Begin DoDot:1
+47 SET Y=^ABMDCLM(DUZ(2),ABMP("CDFN"),17,ABM,0)
+48 ;skip if not sequenced ;abm*2.6*14 ICD10 002F
IF +$PIECE(Y,U,2)=0
QUIT
+49 SET ABMPRI($PIECE(Y,U,2),+Y)=""
+50 SET ABMTYP=$SELECT($PIECE($GET(^ABMDCLM(DUZ(2),ABMP("CDFN"),17,ABM,0)),U,6)=1:"ICD10",1:"ICD9")
End DoDot:1
+51 SET ABM=0
+52 ;ABMR("P") is a counter used to keep track of priorities already used
+53 ;Start with 2 unless there already exist priorities
+54 ;S ABMR("P")=$S($D(ABMPRI):$O(ABMPRI(""),-1)+1,1:2) ;abm*2.6*10 NOHEAT
+55 ;changed so default would be 1, not 2 for priority; if only 1 DX user would have to resequence
+56 ;S ABMR("P")=$S($D(ABMPRI):$O(ABMPRI(""),-1)+1,1:1) ;abm*2.6*10 NOHEAT ;abm*2.6*14 CR3445
+57 ;abm*2.6*10 NOHEAT ;abm*2.6*14 CR3445
SET ABMR("P")=$SELECT($DATA(ABMPRI):$ORDER(ABMPRI(""),-1)+1,1:0)
+58 ;First check billing pointer for POV
+59 SET BP=$PIECE(^AUPNVSIT(ABMVDFN,0),U,28)
+60 IF BP]""
Begin DoDot:1
+61 FOR
SET ABM=$ORDER(^AUPNVPOV("AD",BP,ABM))
IF 'ABM
QUIT
KILL DR,DIC("DR")
DO POVCHK
+62 KILL DIC
End DoDot:1
+63 SET ABM=0
POV FOR
SET ABM=$ORDER(^AUPNVPOV("AD",ABMVDFN,ABM))
IF 'ABM
QUIT
KILL DR,DIC("DR")
DO POVCHK
+1 IF $DATA(ABMPRI)
IF '$ORDER(ABMPRI($ORDER(ABMPRI(""))))
SET ABMP("CORRSDIAG")=$ORDER(ABMPRI(""))
+2 KILL DIC
+3 QUIT
+4 ;
POVCHK ;POV is dinumed. Each POV is only entered once.
+1 NEW ABMPOV0,ABMICD
+2 IF '$DATA(^AUPNVPOV(ABM,0))
QUIT
+3 SET ABMPOV0=^AUPNVPOV(ABM,0)
+4 ;abm*2.6*14 ICD10 SNOMED
SET ABMPOV11=$GET(^AUPNVPOV(ABM,11))
+5 ;CSV-c
SET ABMICD=$PIECE($$DX^ABMCVAPI(+ABMPOV0,ABMP("VDT")),U,2)
+6 ;abm*2.6*14 ICD10 002F
SET ABMTYP=$SELECT($PIECE($$DX^ABMCVAPI(+ABMPOV0,ABMP("VDT")),U,20)=30:"ICD10",1:"ICD9")
+7 ;start old abm*2.6*18 IHS/SD/SDR HEAT239392
+8 ;start new code abm*2.6*14 E-codes
+9 ;S ABM("ECODE")=0
+10 ;I ABMP("VDT")<3150930 S ABM("ECODE")=+$P(ABMPOV0,U,9)
+11 ;I ABMP("VDT")>3151001&((ABMP("VDT")>ABMP("ICD10"))!(ABMP("VDT")=ABMP("ICD10"))) S ABM("ECODE")=+$P(ABMPOV0,U,9)
+12 ;I ABMP("VDT")>3151001&(ABMP("VDT")<ABMP("ICD10")) S ABM("ECODE")=+$P(ABMPOV0,U,25)
+13 ;I ABM("ECODE")'=0 D
+14 ;end new code abm*2.6*14 E-codes
+15 ;end old start new abm*2.6*18 IHS/SD/SDR HEAT239392
+16 SET ABM("ECODE")=0
+17 ;I ABMP("VDT")<ABMP("ICD10") S ABM("ECODE")=+$P(ABMPOV0,U,25)
+18 ;I (ABMP("VDT")>ABMP("ICD10"))!(ABMP("VDT")=ABMP("ICD10")) S ABM("ECODE")=+$P(ABMPOV0,U,9)
+19 IF ((ABMP("VDT")'<ABMP("ICD10"))&($PIECE($$DX^ABMCVAPI(+$PIECE(ABMPOV0,U,9),ABMP("VDT")),U,20)=30))
SET ABM("ECODE")=+$PIECE(ABMPOV0,U,9)
+20 IF ((ABMP("VDT")<ABMP("ICD10"))&($PIECE($$DX^ABMCVAPI(+$PIECE(ABMPOV0,U,9),ABMP("VDT")),U,20)'=30))
SET ABM("ECODE")=+$PIECE(ABMPOV0,U,9)
+21 IF ((ABMP("VDT")<ABMP("ICD10"))&(+$PIECE(ABMPOV0,U,25)'=0))
SET ABM("ECODE")=+$PIECE(ABMPOV0,U,25)
+22 ;end new abm*2.6*18 IHS/SD/SDR HEAT239392
+23 ;Through the use of the ABMPRI array it would be possible to change
+24 ;the priorities of existing entries if needed.
+25 ;ABMR("PX") is priority of diagnosis
+26 ;Piece 12 is primary/secondary
+27 ;Only a non-V code can be given priority 1
+28 ;S ABMR("PX")=$S($D(ABMPRI(1))=10:ABMR("P"),$E(ABMICD,1)="V":ABMR("P"),$P(ABMPOV0,U,12)="P":1,1:ABMR("P")) ;abm*2.6*14 CR3445
+29 ;abm*2.6*14 CR3445
SET ABMR("PX")=ABMR("P")
+30 ;abm*2.6*10 NOHEAT
SET ABMR("P")=ABMR("P")+1
+31 ; Do not do this section for I or D visits
+32 IF ABMP("V0")=ABMCHV0!("ID"'[$PIECE(ABMCHV0,U,7))
Begin DoDot:1
+33 ;Employment related POV put Y into employment rel field in claim
+34 IF $PIECE(ABMPOV0,U,7)=4
Begin DoDot:2
+35 SET DIE="^ABMDCLM(DUZ(2),"
+36 SET DA=ABMP("CDFN")
SET DR=".91////Y"
+37 ;I $P(ABML(ABMP("PRI"),ABMP("INS")),U,2)'="" S DR=DR_+";.48////"_$P($G(^AUPNWC(ABMP("PDFN"),11,$P(ABML(ABMP("PRI"),ABMP("INS")),U,2),0)),U,4) ;abm*2.6*16 IHS/SD/SDR HEAT200359
+38 ;start new abm*2.6*16 IHS/SD/SDR HEAT200359
+39 NEW ABML
SET ABML=""
+40 DO ELG^ABMDLCK(ABMVDFN,.ABML,ABMP("PDFN"),ABMP("VDT"))
+41 SET ABMT("PRI")=0
SET ABMWFLG=0
+42 FOR
SET ABMT("PRI")=$ORDER(ABML(ABMT("PRI")))
IF 'ABMT("PRI")
QUIT
Begin DoDot:3
+43 SET ABMT("INS")=$ORDER(ABML(ABMT("PRI"),0))
+44 ;not correct insurer
IF ABMT("INS")'=ABMP("INS")
QUIT
+45 ;workman's comp only past this
IF $PIECE(ABML(ABMT("PRI"),ABMP("INS")),U,3)'="W"
QUIT
+46 IF +$PIECE(ABML(ABMT("PRI"),ABMP("INS")),U,2)'=0
SET DR=DR_";.48////"_$PIECE($GET(^AUPNWC(ABMP("PDFN"),11,$PIECE(ABML(ABMT("PRI"),ABMP("INS")),U,2),0)),U,4)
End DoDot:3
IF ABMWFLG=1
QUIT
+47 ;end new abm*2.6*16 IHS/SD/SDR HEAT200359
+48 DO ^DIE
+49 KILL DR
End DoDot:2
+50 ;Injury date
+51 IF $PIECE(ABMPOV0,U,13)]""
Begin DoDot:2
+52 SET DIE="^ABMDCLM(DUZ(2),"
+53 SET DA=ABMP("CDFN")
+54 SET DR=".82////"_$PIECE(ABMPOV0,U,13)
DO ^DIE
KILL DR
End DoDot:2
+55 ;I $P(ABMPOV0,U,9)]"" D ;abm*2.6*14 E-codes
+56 ;abm*2.6*14 E-codes
IF ABM("ECODE")'=0
Begin DoDot:2
+57 ;Checking to see if 1st 3 chars of ICD code are E81
+58 ;S ABM("ECODE")=$P(ABMPOV0,"^",9) ;abm*2.6*14 E-codes
+59 ;S ABM("Y")=$S($E($P($$DX^ABMCVAPI(ABM("ECODE"),ABMP("VDT")),U,2),1,3)="E81":1,1:5) ;CSV-c ;abm*2.6*14 updated API call
+60 ;CSV-c ;abm*2.6*14 updated API call
SET ABM("Y")=$SELECT($EXTRACT($PIECE($$DX^ABMCVAPI(+ABM("ECODE"),ABMP("VDT")),U,2),1,3)="E81":1,1:5)
+61 SET ABM("X")=$SELECT($PIECE(ABMPOV0,U,13):$PIECE(ABMPOV0,U,13),1:ABMP("VDT"))
+62 DO ACCODE^ABMDE3A
KILL DIC
+63 ;X is set to Accident type code
+64 SET X=$SELECT(ABM("Y")=1:ABM("Y"),$PIECE(ABMPOV0,U,7)=4:4,1:5)
+65 SET DIE="^ABMDCLM(DUZ(2),"
+66 SET DA=ABMP("CDFN")
+67 SET DR=".83////"_X
DO ^DIE
+68 SET DR=".857////"_ABM("ECODE")
DO ^DIE
+69 ;K ABM("ECODE") ;abm*2.6*14 E-codes
End DoDot:2
End DoDot:1
+70 ;Diagnosis subfile is at node 17
+71 ;DX code
SET X=$PIECE(ABMPOV0,U)
+72 ;abm*2.6*14 dual coding - ICD9 dual coding field
IF +$PIECE(ABMPOV0,U,24)'=0&(ABMP("ICD10")>ABMP("VDT"))
SET X=$PIECE(ABMPOV0,U,24)
SET ABMTYP="ICD9"
+73 ;DINUM and provider narrative
SET DINUM=X
SET ABMR("NAR")=$PIECE(ABMPOV0,U,4)
+74 SET DA(1)=ABMP("CDFN")
+75 SET DIC="^ABMDCLM(DUZ(2),"_DA(1)_",17,"
+76 SET DIC(0)="LE"
KILL DD,DO
+77 SET DIC("P")=$PIECE(^DD(9002274.3,17,0),U,2)
+78 ;S DIC("DR")=".02////"_ABMR("PX")_";.03////"_ABMR("NAR") ;abm*2.6*14 ICD10 002F
+79 ;abm*2.6*14 ICD10 002F
IF (ABMP("ICD10")<ABMP("VDT")!(ABMP("ICD10")=ABMP("VDT")))&(ABMTYP="ICD10")
SET DIC("DR")=".02////"_ABMR("P")
+80 ;abm*2.6*14 ICD10 002F
IF (ABMP("ICD10")>ABMP("VDT")&(ABMTYP="ICD9"))
SET DIC("DR")=".02////"_ABMR("P")
+81 ;abm*2.6*14 ICD10 002F
SET DIC("DR")=$SELECT($GET(DIC("DR"))'="":DIC("DR")_";",1:"")_".03////"_ABMR("NAR")
+82 ;S DIC("DR")=DIC("DR")_";.04////"_$P(ABMPOV0,U,9) ;E-code ;abm*2.6*14 E-codes
+83 ;E-code ;abm*2.6*14 E-codes
IF (+ABM("ECODE")'=0)
SET DIC("DR")=DIC("DR")_";.04////"_ABM("ECODE")
+84 ;S DIC("DR")=DIC("DR")_";.05////"_$P(ABMPOV0,U,22) ;abm*2.6*21 IHS/SD/SDR HEAT234796
+85 ;abm*2.6*21 IHS/SD/SDR HEAT234796
IF SERVCAT="H"
SET DIC("DR")=DIC("DR")_";.05////"_$PIECE(ABMPOV0,U,22)
+86 ;abm*2.6*14 ICD10 002F and updated API call
IF $PIECE($$DX^ABMCVAPI(+X,ABMP("VDT")),U,20)=30
SET DIC("DR")=DIC("DR")_";.06////1"
+87 ;start new code abm*2.6*14 ICD10 SNOMED/dual coding
+88 ;abm*2.6*16 IHS/SD/SDR HEAT217211
IF $PIECE(ABMPOV0,U,18)'=""
SET DIC("DR")=DIC("DR")_";.07////"_$PIECE(ABMPOV0,U,18)
+89 ;abm*2.6*16 IHS/SD/SDR HEAT217211
IF $PIECE(ABMPOV0,U,19)'=""
SET DIC("DR")=DIC("DR")_";.08////"_$PIECE(ABMPOV0,U,19)
+90 ;abm*2.6*16 IHS/SD/SDR HEAT217211
IF $PIECE(ABMPOV0,U,21)'=""
SET DIC("DR")=DIC("DR")_";.09////"_$PIECE(ABMPOV0,U,21)
+91 IF $PIECE(ABMPOV0,U,24)'=""
SET DIC("DR")=DIC("DR")_";21////"_$PIECE(ABMPOV0,U,24)
+92 IF $PIECE(ABMPOV0,U,25)'=""
SET DIC("DR")=DIC("DR")_";23////"_$PIECE(ABMPOV0,U,25)
+93 IF $PIECE(ABMPOV0,U,26)'=""
SET DIC("DR")=DIC("DR")_";24////"_$PIECE(ABMPOV0,U,26)
+94 IF $PIECE(ABMPOV0,U,27)'=""
SET DIC("DR")=DIC("DR")_";25////"_$PIECE(ABMPOV0,U,27)
+95 ;abm*2.6*16 IHS/SD/SDR HEAT217211
IF $PIECE(ABMPOV0,U,28)'=""
SET DIC("DR")=DIC("DR")_";26////"_$PIECE(ABMPOV0,U,28)
+96 IF $PIECE(ABMPOV11,U)'=""
SET DIC("DR")=DIC("DR")_";11////"_$PIECE(ABMPOV11,U)
+97 IF $PIECE(ABMPOV11,U,2)'=""
SET DIC("DR")=DIC("DR")_";13////"_$PIECE(ABMPOV11,U,2)
+98 IF $PIECE(ABMPOV11,U,3)'=""
SET DIC("DR")=DIC("DR")_";15////"_$PIECE(ABMPOV11,U,3)
+99 ;end new code ICD10 SNOMED/dual coding
+100 IF $DATA(^ABMDCLM(DUZ(2),ABMP("CDFN"),17,DINUM,0))
Begin DoDot:1
+101 SET DIE=DIC
+102 SET DA=DINUM
+103 SET DR=$PIECE(DIC("DR"),";",2)
+104 KILL DINUM,DIC
+105 DO ^DIE
+106 KILL DIE,X,Y
End DoDot:1
QUIT
+107 SET ABMPRI(ABMR("PX"),X)=""
+108 KILL DD,DO
DO FILE^DICN
+109 ;I ABMR("PX")>1 S ABMR("P")=ABMR("P")+1 ;abm*2.6*14 ICD10 002F
+110 ;abm*2.6*14 ICD10 002F
IF ABMP("ICD10")<ABMP("VDT")!(ABMP("ICD10")=ABMP("VDT"))
IF ABMR("PX")>1
SET ABMR("P")=ABMR("P")+1
+111 KILL DIC,X,Y
+112 KILL DIC("DR")
+113 ;S ABMECD=$P(ABMPOV0,U,9) ;E-code ;abm*2.6*14 E-codes
+114 ;E-code ;abm*2.6*14 E-codes
SET ABMECD=ABM("ECODE")
+115 ;Q:ABMECD="" ;abm*2.6*14 E-codes
+116 ;abm*2.6*14 E-codes
IF ABMECD=0
QUIT
+117 ;entry already exists in array; shift others down one to make room
+118 ;abm*2.6*14 start old CR3445
+119 ;I ABMR("P")-1'=1,($O(ABMPRI(1,0))'="") D
+120 ;.S ABMOPRI=999
+121 ;.F S ABMOPRI=$O(ABMPRI(ABMOPRI),-1) Q:ABMOPRI=1 D Q:DA=$P(ABMPOV0,U)
+122 ;..S DA(1)=ABMP("CDFN")
+123 ;..S DIE="^ABMDCLM(DUZ(2),"_DA(1)_",17,"
+124 ;..S DA=$O(ABMPRI(ABMOPRI,0))
+125 ;..Q:DA=$P(ABMPOV0,U)
+126 ;..S DR=".02////"_(+ABMOPRI+1)
+127 ;..;S DR=DR_";.05////"_+$P($G(ABMPOV0),U,21) ;abm*2.6*14
+128 ;..S:($P($G(ABMPOV0),U,22)'="") DR=DR_";.05////"_$P($G(ABMPOV0),U,22) ;abm*2.6*14
+129 ;..I ABMTYP="ICD10" S DR=DR_";.06////1" ;abm*2.6*14 E-codes ICD Indicator
+130 ;..D ^DIE
+131 ;..S ABMPRI(ABMOPRI+1,DA)=""
+132 ;..K ABMPRI(ABMOPRI,DA)
+133 ;..S ABMR("P")=ABMR("P")-1
+134 ;end old CR3445
+135 ;abm*2.6*14 CR3445
SET ABMR("P")=ABMR("P")+1
+136 SET (DINUM,X)=ABMECD
+137 SET DA(1)=ABMP("CDFN")
+138 SET DIC="^ABMDCLM(DUZ(2),"_DA(1)_",17,"
+139 SET DIC(0)="LE"
KILL DD,DO
+140 SET DIC("P")=$PIECE(^DD(9002274.3,17,0),U,2)
+141 ;S DIC("DR")=".02////"_ABMR("P")_";.03////"_ABMR("NAR") ;abm*2.6*14 ICD10 002F
+142 ;abm*2.6*14 ICD10 002F
IF ABMP("ICD10")<ABMP("VDT")!(ABMP("ICD10")=ABMP("VDT"))&(ABMTYP="ICD10")
SET DIC("DR")=".02////"_ABMR("P")
+143 ;abm*2.6*14 ICD10 002F
IF (ABMP("ICD10")>ABMP("VDT")&(ABMTYP="ICD9"))
SET DIC("DR")=".02////"_ABMR("P")
+144 ;abm*2.6*14 ICD10 002F
SET DIC("DR")=$SELECT($GET(DIC("DR"))'="":DIC("DR")_";",1:"")_".03////"_ABMR("NAR")
+145 SET DIC("DR")=DIC("DR")_";.05////"_$PIECE($GET(ABMPOV0),U,22)
+146 ;abm*2.6*14 E-codes ICD Indicator
IF ABMTYP="ICD10"
SET DIC("DR")=DIC("DR")_";.06////1"
+147 SET ABMPRI(ABMR("P"),ABMECD)=""
+148 KILL DD,DO
DO FILE^DICN
+149 ;I ABMR("PX")>0 S ABMR("P")=ABMR("P")+1 ;abm*2.6*14 CR3445
+150 KILL DIC,X,Y
+151 QUIT
