Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ABMDVST1

ABMDVST1.m

Go to the documentation of this file. 
  1. 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
  1.  ;Original;TMD;03/26/96 12:11 PM
  1.  ;
  1.  ;IHS/ASDS/DMJ - 10/31/00 - V2.4 Patch 3 - NOIS NDA-0500-180002
  1.  ;     Modify code to pick up e-codes from PCC if exist
  1.  ;
  1.  ;IHS/SD/SDR - 11/4/02 - V2.5 P2 - NDA-0500-180002
  1.  ;    Modified to pick up all e-codes from PCC
  1.  ;IHS/SD/SDR - v2.5 p9 - IM18472
  1.  ;   Modified to make sure there aren't two of the same priority ICD
  1.  ;IHS/SD/SDR - v2.5 p10 - IM21619
  1.  ;  Added code to populate claim number from Workman's Comp file
  1.  ;IHS/SD/SDR - v2.5 p13 - IM25840
  1.  ;  <UNDEF>DX+39^ABMDEMLC caused when there is a primary code with
  1.  ;  an E-code and a secondary (E-code s/b secondary)
  1.  ;IHS/SD/SDR - v2.5 p13 - POA changes
  1.  ;
  1.  ;IHS/SD/SDR - v2.6
  1.  ;IHS/SD/SDR - 2.6*14 - Populated .06 field of 17 multiple if ICD10 code.  002F
  1.  ;IHS/SD/SDR - 2.6*14 - ICD10 SNOMED - populate SNOMED and dual coding fields from V POV file.
  1.  ;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;
  1.  ;  acts as override for ICD-10 Effective Date
  1.  ;IHS/SD/SDR - 2.6*14 - Updated DX^ABMCVAPI to be numeric
  1.  ;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.
  1.  ;IHS/SD/SDR - 2.6*14 - CR3445 - Made change for sequencing; with ICD10 changes, if there were E-codes present the sequencing was getting
  1.  ;  messed up.
  1.  ;IHS/SD/SDR - 2.6*16 - HEAT200359 - Made changes so CASE NUMBER will populated with the claim number from Reg if it is
  1.  ;  a workman's comp claim.  Wasn't doing lookup correctly (data needed wasn't defined).
  1.  ;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)
  1.  ;IHS/SD/SDR - 2.6*18 - HEAT239392 - Correction for E-code not crossing over from PCC Visit.
  1.  ;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)
  1.  ;   indicator cross over onto the claim in TPB.
  1.  ;
  1.  ;
  1.  Q:ABMIDONE
  1.  I $O(^DIC(40.7,"B","EMERGENCY MEDICINE",""))=ABMP("CLN") S ABMP("C0")=^ABMDCLM(DUZ(2),ABMP("CDFN"),0) D ASET^ABMDE3B
  1.  ;E3B sets special UB-82 codes
  1.  I $O(^DIC(40.7,"B","EPSDT",""))=ABMP("CLN") S Y=67 D SP^ABMDE3B
  1.  I $O(^DIC(40.7,"B","FAMILY PLANNING",""))=ABMP("CLN") S Y=70 D SP^ABMDE3B
  1.  ;
  1.  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
  1.  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
  1.  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
  1.  N BP,ABMPRI
  1.  S ABM=0
  1.  F  S ABM=$O(^ABMDCLM(DUZ(2),ABMP("CDFN"),17,ABM)) Q:'ABM  D
  1.  .S Y=^ABMDCLM(DUZ(2),ABMP("CDFN"),17,ABM,0)
  1.  .I +$P(Y,U,2)=0 Q  ;skip if not sequenced  ;abm*2.6*14 ICD10 002F
  1.  .S ABMPRI($P(Y,U,2),+Y)=""
  1.  .S ABMTYP=$S($P($G(^ABMDCLM(DUZ(2),ABMP("CDFN"),17,ABM,0)),U,6)=1:"ICD10",1:"ICD9")
  1.  S ABM=0
  1.  ;ABMR("P") is a counter used to keep track of priorities already used
  1.  ;Start with 2 unless there already exist priorities
  1.  ;S ABMR("P")=$S($D(ABMPRI):$O(ABMPRI(""),-1)+1,1:2)  ;abm*2.6*10 NOHEAT
  1.  ;changed so default would be 1, not 2 for priority; if only 1 DX user would have to resequence
  1.  ;S ABMR("P")=$S($D(ABMPRI):$O(ABMPRI(""),-1)+1,1:1)  ;abm*2.6*10 NOHEAT  ;abm*2.6*14 CR3445
  1.  S ABMR("P")=$S($D(ABMPRI):$O(ABMPRI(""),-1)+1,1:0)  ;abm*2.6*10 NOHEAT  ;abm*2.6*14 CR3445
  1.  ;First check billing pointer for POV
  1.  S BP=$P(^AUPNVSIT(ABMVDFN,0),U,28)
  1.  I BP]"" D
  1.  .F  S ABM=$O(^AUPNVPOV("AD",BP,ABM)) Q:'ABM  K DR,DIC("DR") D POVCHK
  1.  .K DIC
  1.  S ABM=0
  1. POV F  S ABM=$O(^AUPNVPOV("AD",ABMVDFN,ABM)) Q:'ABM  K DR,DIC("DR") D POVCHK
  1.  I $D(ABMPRI),'$O(ABMPRI($O(ABMPRI("")))) S ABMP("CORRSDIAG")=$O(ABMPRI(""))
  1.  K DIC
  1.  Q
  1.  ;
  1. POVCHK ;POV is dinumed.  Each POV is only entered once.
  1.  N ABMPOV0,ABMICD
  1.  I '$D(^AUPNVPOV(ABM,0)) Q
  1.  S ABMPOV0=^AUPNVPOV(ABM,0)
  1.  S ABMPOV11=$G(^AUPNVPOV(ABM,11))  ;abm*2.6*14 ICD10 SNOMED
  1.  S ABMICD=$P($$DX^ABMCVAPI(+ABMPOV0,ABMP("VDT")),U,2)  ;CSV-c
  1.  S ABMTYP=$S($P($$DX^ABMCVAPI(+ABMPOV0,ABMP("VDT")),U,20)=30:"ICD10",1:"ICD9")  ;abm*2.6*14 ICD10 002F
  1.  ;start old abm*2.6*18 IHS/SD/SDR HEAT239392
  1.  ;start new code abm*2.6*14 E-codes
  1.  ;S ABM("ECODE")=0
  1.  ;I ABMP("VDT")<3150930 S ABM("ECODE")=+$P(ABMPOV0,U,9)
  1.  ;I ABMP("VDT")>3151001&((ABMP("VDT")>ABMP("ICD10"))!(ABMP("VDT")=ABMP("ICD10"))) S ABM("ECODE")=+$P(ABMPOV0,U,9)
  1.  ;I ABMP("VDT")>3151001&(ABMP("VDT")<ABMP("ICD10")) S ABM("ECODE")=+$P(ABMPOV0,U,25)
  1.  ;I ABM("ECODE")'=0 D
  1.  ;end new code abm*2.6*14 E-codes
  1.  ;end old start new abm*2.6*18 IHS/SD/SDR HEAT239392
  1.  S ABM("ECODE")=0
  1.  ;I ABMP("VDT")<ABMP("ICD10") S ABM("ECODE")=+$P(ABMPOV0,U,25)
  1.  ;I (ABMP("VDT")>ABMP("ICD10"))!(ABMP("VDT")=ABMP("ICD10")) S ABM("ECODE")=+$P(ABMPOV0,U,9)
  1.  I ((ABMP("VDT")'<ABMP("ICD10"))&($P($$DX^ABMCVAPI(+$P(ABMPOV0,U,9),ABMP("VDT")),U,20)=30)) S ABM("ECODE")=+$P(ABMPOV0,U,9)
  1.  I ((ABMP("VDT")<ABMP("ICD10"))&($P($$DX^ABMCVAPI(+$P(ABMPOV0,U,9),ABMP("VDT")),U,20)'=30)) S ABM("ECODE")=+$P(ABMPOV0,U,9)
  1.  I ((ABMP("VDT")<ABMP("ICD10"))&(+$P(ABMPOV0,U,25)'=0)) S ABM("ECODE")=+$P(ABMPOV0,U,25)
  1.  ;end new abm*2.6*18 IHS/SD/SDR HEAT239392
  1.  ;Through the use of the ABMPRI array it would be possible to change
  1.  ;the priorities of existing entries if needed.
  1.  ;ABMR("PX") is priority of diagnosis
  1.  ;Piece 12 is primary/secondary
  1.  ;Only a non-V code can be given priority 1
  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
  1.  S ABMR("PX")=ABMR("P")  ;abm*2.6*14 CR3445
  1.  S ABMR("P")=ABMR("P")+1  ;abm*2.6*10 NOHEAT
  1.  ; Do not do this section for I or D visits
  1.  I ABMP("V0")=ABMCHV0!("ID"'[$P(ABMCHV0,U,7)) D
  1.  .;Employment related POV put Y into employment rel field in claim
  1.  .I $P(ABMPOV0,U,7)=4 D
  1.  ..S DIE="^ABMDCLM(DUZ(2),"
  1.  ..S DA=ABMP("CDFN"),DR=".91////Y"
  1.  ..;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
  1.  ..;start new abm*2.6*16 IHS/SD/SDR HEAT200359
  1.  ..N ABML S ABML=""
  1.  ..D ELG^ABMDLCK(ABMVDFN,.ABML,ABMP("PDFN"),ABMP("VDT"))
  1.  ..S ABMT("PRI")=0,ABMWFLG=0
  1.  ..F  S ABMT("PRI")=$O(ABML(ABMT("PRI"))) Q:'ABMT("PRI")  D  Q:ABMWFLG=1
  1.  ...S ABMT("INS")=$O(ABML(ABMT("PRI"),0))
  1.  ...Q:ABMT("INS")'=ABMP("INS")  ;not correct insurer
  1.  ...I $P(ABML(ABMT("PRI"),ABMP("INS")),U,3)'="W" Q  ;workman's comp only past this
  1.  ...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)
  1.  ..;end new abm*2.6*16 IHS/SD/SDR HEAT200359
  1.  ..D ^DIE
  1.  ..K DR
  1.  .;Injury date
  1.  .I $P(ABMPOV0,U,13)]"" D
  1.  ..S DIE="^ABMDCLM(DUZ(2),"
  1.  ..S DA=ABMP("CDFN")
  1.  ..S DR=".82////"_$P(ABMPOV0,U,13) D ^DIE K DR
  1.  .;I $P(ABMPOV0,U,9)]"" D  ;abm*2.6*14 E-codes
  1.  .I ABM("ECODE")'=0 D  ;abm*2.6*14 E-codes
  1.  ..;Checking to see if 1st 3 chars of ICD code are E81
  1.  ..;S ABM("ECODE")=$P(ABMPOV0,"^",9)  ;abm*2.6*14 E-codes
  1.  ..;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
  1.  ..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
  1.  ..S ABM("X")=$S($P(ABMPOV0,U,13):$P(ABMPOV0,U,13),1:ABMP("VDT"))
  1.  ..D ACCODE^ABMDE3A K DIC
  1.  ..;X is set to Accident type code
  1.  ..S X=$S(ABM("Y")=1:ABM("Y"),$P(ABMPOV0,U,7)=4:4,1:5)
  1.  ..S DIE="^ABMDCLM(DUZ(2),"
  1.  ..S DA=ABMP("CDFN")
  1.  ..S DR=".83////"_X D ^DIE
  1.  ..S DR=".857////"_ABM("ECODE") D ^DIE
  1.  ..;K ABM("ECODE")  ;abm*2.6*14 E-codes
  1.  ;Diagnosis subfile is at node 17
  1.  S X=$P(ABMPOV0,U)  ;DX code
  1.  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
  1.  S DINUM=X,ABMR("NAR")=$P(ABMPOV0,U,4)  ;DINUM and provider narrative
  1.  S DA(1)=ABMP("CDFN")
  1.  S DIC="^ABMDCLM(DUZ(2),"_DA(1)_",17,"
  1.  S DIC(0)="LE" K DD,DO
  1.  S DIC("P")=$P(^DD(9002274.3,17,0),U,2)
  1.  ;S DIC("DR")=".02////"_ABMR("PX")_";.03////"_ABMR("NAR")  ;abm*2.6*14 ICD10 002F
  1.  I (ABMP("ICD10")<ABMP("VDT")!(ABMP("ICD10")=ABMP("VDT")))&(ABMTYP="ICD10") S DIC("DR")=".02////"_ABMR("P")  ;abm*2.6*14 ICD10 002F
  1.  I (ABMP("ICD10")>ABMP("VDT")&(ABMTYP="ICD9")) S DIC("DR")=".02////"_ABMR("P")  ;abm*2.6*14 ICD10 002F
  1.  S DIC("DR")=$S($G(DIC("DR"))'="":DIC("DR")_";",1:"")_".03////"_ABMR("NAR")  ;abm*2.6*14 ICD10 002F
  1.  ;S DIC("DR")=DIC("DR")_";.04////"_$P(ABMPOV0,U,9)  ;E-code  ;abm*2.6*14 E-codes
  1.  S:(+ABM("ECODE")'=0) DIC("DR")=DIC("DR")_";.04////"_ABM("ECODE")  ;E-code  ;abm*2.6*14 E-codes
  1.  ;S DIC("DR")=DIC("DR")_";.05////"_$P(ABMPOV0,U,22)  ;abm*2.6*21 IHS/SD/SDR HEAT234796
  1.  I SERVCAT="H" S DIC("DR")=DIC("DR")_";.05////"_$P(ABMPOV0,U,22)  ;abm*2.6*21 IHS/SD/SDR HEAT234796
  1.  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
  1.  ;start new code abm*2.6*14 ICD10 SNOMED/dual coding
  1.  S:$P(ABMPOV0,U,18)'="" DIC("DR")=DIC("DR")_";.07////"_$P(ABMPOV0,U,18)  ;abm*2.6*16 IHS/SD/SDR HEAT217211
  1.  S:$P(ABMPOV0,U,19)'="" DIC("DR")=DIC("DR")_";.08////"_$P(ABMPOV0,U,19)  ;abm*2.6*16 IHS/SD/SDR HEAT217211
  1.  S:$P(ABMPOV0,U,21)'="" DIC("DR")=DIC("DR")_";.09////"_$P(ABMPOV0,U,21)  ;abm*2.6*16 IHS/SD/SDR HEAT217211
  1.  S:$P(ABMPOV0,U,24)'="" DIC("DR")=DIC("DR")_";21////"_$P(ABMPOV0,U,24)
  1.  S:$P(ABMPOV0,U,25)'="" DIC("DR")=DIC("DR")_";23////"_$P(ABMPOV0,U,25)
  1.  S:$P(ABMPOV0,U,26)'="" DIC("DR")=DIC("DR")_";24////"_$P(ABMPOV0,U,26)
  1.  S:$P(ABMPOV0,U,27)'="" DIC("DR")=DIC("DR")_";25////"_$P(ABMPOV0,U,27)
  1.  S:$P(ABMPOV0,U,28)'="" DIC("DR")=DIC("DR")_";26////"_$P(ABMPOV0,U,28)  ;abm*2.6*16 IHS/SD/SDR HEAT217211
  1.  S:$P(ABMPOV11,U)'="" DIC("DR")=DIC("DR")_";11////"_$P(ABMPOV11,U)
  1.  S:$P(ABMPOV11,U,2)'="" DIC("DR")=DIC("DR")_";13////"_$P(ABMPOV11,U,2)
  1.  S:$P(ABMPOV11,U,3)'="" DIC("DR")=DIC("DR")_";15////"_$P(ABMPOV11,U,3)
  1.  ;end new code ICD10 SNOMED/dual coding
  1.  I $D(^ABMDCLM(DUZ(2),ABMP("CDFN"),17,DINUM,0)) D  Q
  1.  .S DIE=DIC
  1.  .S DA=DINUM
  1.  .S DR=$P(DIC("DR"),";",2)
  1.  .K DINUM,DIC
  1.  .D ^DIE
  1.  .K DIE,X,Y
  1.  S ABMPRI(ABMR("PX"),X)=""
  1.  K DD,DO D FILE^DICN
  1.  ;I ABMR("PX")>1 S ABMR("P")=ABMR("P")+1  ;abm*2.6*14 ICD10 002F
  1.  I ABMP("ICD10")<ABMP("VDT")!(ABMP("ICD10")=ABMP("VDT")),ABMR("PX")>1 S ABMR("P")=ABMR("P")+1  ;abm*2.6*14 ICD10 002F
  1.  K DIC,X,Y
  1.  K DIC("DR")
  1.  ;S ABMECD=$P(ABMPOV0,U,9)  ;E-code  ;abm*2.6*14 E-codes
  1.  S ABMECD=ABM("ECODE")  ;E-code  ;abm*2.6*14 E-codes
  1.  ;Q:ABMECD=""  ;abm*2.6*14 E-codes
  1.  Q:ABMECD=0  ;abm*2.6*14 E-codes
  1.  ;entry already exists in array; shift others down one to make room
  1.  ;abm*2.6*14 start old CR3445
  1.  ;I ABMR("P")-1'=1,($O(ABMPRI(1,0))'="") D
  1.  ;.S ABMOPRI=999
  1.  ;.F  S ABMOPRI=$O(ABMPRI(ABMOPRI),-1) Q:ABMOPRI=1  D  Q:DA=$P(ABMPOV0,U)
  1.  ;..S DA(1)=ABMP("CDFN")
  1.  ;..S DIE="^ABMDCLM(DUZ(2),"_DA(1)_",17,"
  1.  ;..S DA=$O(ABMPRI(ABMOPRI,0))
  1.  ;..Q:DA=$P(ABMPOV0,U)
  1.  ;..S DR=".02////"_(+ABMOPRI+1)
  1.  ;..;S DR=DR_";.05////"_+$P($G(ABMPOV0),U,21)  ;abm*2.6*14
  1.  ;..S:($P($G(ABMPOV0),U,22)'="") DR=DR_";.05////"_$P($G(ABMPOV0),U,22)  ;abm*2.6*14
  1.  ;..I ABMTYP="ICD10" S DR=DR_";.06////1"  ;abm*2.6*14 E-codes ICD Indicator
  1.  ;..D ^DIE
  1.  ;..S ABMPRI(ABMOPRI+1,DA)=""
  1.  ;..K ABMPRI(ABMOPRI,DA)
  1.  ;..S ABMR("P")=ABMR("P")-1
  1.  ;end old CR3445
  1.  S ABMR("P")=ABMR("P")+1  ;abm*2.6*14 CR3445
  1.  S (DINUM,X)=ABMECD
  1.  S DA(1)=ABMP("CDFN")
  1.  S DIC="^ABMDCLM(DUZ(2),"_DA(1)_",17,"
  1.  S DIC(0)="LE" K DD,DO
  1.  S DIC("P")=$P(^DD(9002274.3,17,0),U,2)
  1.  ;S DIC("DR")=".02////"_ABMR("P")_";.03////"_ABMR("NAR")  ;abm*2.6*14 ICD10 002F
  1.  I ABMP("ICD10")<ABMP("VDT")!(ABMP("ICD10")=ABMP("VDT"))&(ABMTYP="ICD10") S DIC("DR")=".02////"_ABMR("P")  ;abm*2.6*14 ICD10 002F
  1.  I (ABMP("ICD10")>ABMP("VDT")&(ABMTYP="ICD9")) S DIC("DR")=".02////"_ABMR("P")  ;abm*2.6*14 ICD10 002F
  1.  S DIC("DR")=$S($G(DIC("DR"))'="":DIC("DR")_";",1:"")_".03////"_ABMR("NAR")  ;abm*2.6*14 ICD10 002F
  1.  S DIC("DR")=DIC("DR")_";.05////"_$P($G(ABMPOV0),U,22)
  1.  I ABMTYP="ICD10" S DIC("DR")=DIC("DR")_";.06////1"  ;abm*2.6*14 E-codes ICD Indicator
  1.  S ABMPRI(ABMR("P"),ABMECD)=""
  1.  K DD,DO D FILE^DICN
  1.  ;I ABMR("PX")>0 S ABMR("P")=ABMR("P")+1  ;abm*2.6*14 CR3445
  1.  K DIC,X,Y
  1.  Q