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

ABMDF27E.m

Go to the documentation of this file. 
  1. ABMDF27E ; IHS/ASDST/DMJ - Set HCFA1500 Print Array - Part 5 ;  
  1.  ;;2.6;IHS 3P BILLING SYSTEM;**3,4,8,9,11,21**;NOV 12, 2009;Build 379
  1.  ;
  1.  ;IHS/SD/SDR - v2.5 p12 - IM25331 - Put taxonomy code if NPI ONLY
  1.  ;IHS/SD/SDR - v2.5 p12 - IM25352 - Included fix supplied by Walt Reich (PIMC)
  1.  ;   Put space between anes. data for readability
  1.  ;IHS/SD/SDR - v2.5 p13 - IM25899 - Alignment changes
  1.  ;IHS/SD/SDR,AML - v2.5 p13 - NO IM - Change for satellite prov# in 24k
  1.  ;IHS/SD/SDR,AML - abm*2.6*3 - NOHEAT - Correction to box 24K when NPI or not
  1.  ;IHS/SD/SDR - abm*2.6*4 - HEAT12115 - Allow 5+ DX codes
  1.  ;IHS/SD/SDR - 2.6*21 - HEAT168435 - Changed change to see if line item is a drug, now only checks for N4, not length of field
  1.  ;
  1.  ; *********************************************************************
  1.  ;
  1. EMG ;EP for setting Emerg or Special Prog variable
  1.  S (ABM,ABM("EPSDT"))=0
  1.  F  S ABM=$O(^ABMDBILL(DUZ(2),ABMP("BDFN"),59,ABM)) Q:'ABM  D
  1.  .S ABM("X")=$P(^ABMDBILL(DUZ(2),ABMP("BDFN"),59,ABM,0),U)
  1.  .Q:ABM("X")=""
  1.  .I $P(^ABMDCODE(ABM("X"),0),U)["EPSDT"!($P(^(0),U))["FAMILY" S ABM("EPSDT")=1
  1.  S ABM("EMG")=$S($P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),8)),U,5)="Y":1,1:0)
  1.  Q
  1.  ;
  1. PROC ;EP for setting the procedure portion of the ABMF array
  1.  ; input vars: ABMS(ABMS) - the procedure line in internal format
  1.  ;             ABMS("I")  - the current line number
  1.  ;
  1.  ; output vars: ABMF(ABMS("I"))   - procedure line in external format
  1.  ;              ABMF(ABMS("I")-1) - top line for extended descriptions
  1.  ;
  1.  K %DT
  1.  S ABMFDT=$P(ABMS(ABMS),U,2)  ;Service date from
  1.  S X=$P($P(ABMS(ABMS),U,2),"@")  ;Service date from
  1.  D ^%DT
  1.  S $P(ABMS(ABMS),U,2)=Y                 ; Service date from in FM Format
  1.  S ABMTDT=$P(ABMS(ABMS),U,3)  ;Service date to
  1.  S X=$P($P(ABMS(ABMS),U,3),"@")  ;Service date to
  1.  D ^%DT
  1.  S $P(ABMS(ABMS),U,3)=Y                 ; Service date to in FM format
  1.  S ABMR(ABMS,ABMLN)=""
  1.  S ABMR(ABMS,ABMLN)=$P(ABMS(ABMS),U,2,3) ; Form locator 24A
  1.  ;check if time on charge (anes); if so, add as line 1
  1.  I ABMFDT["@" D
  1.  .S $P(ABMR(ABMS,ABMLN-1),U)="7Begin "_$TR($P(ABMFDT,"@",2),":")
  1.  .S $P(ABMR(ABMS,ABMLN-1),U)=$P(ABMR(ABMS,ABMLN-1),U)_" End "_$TR($P(ABMTDT,"@",2),":")
  1.  ;
  1.  ; Set Place of service                 ; Form locator 24B 
  1.  ;   21 if visit type is inpatient
  1.  ;   24 if visit type is ambulatory surgery
  1.  ;   23 if clinic is emergency medicine (code 30)
  1.  ;   11 for all other cases
  1.  I $P(ABMS(ABMS),U,10) S $P(ABMR(ABMS,ABMLN),U,3)=$P($G(^ABMDCODE($P(ABMS(ABMS),U,10),0)),U)
  1.  E  D
  1.  .S $P(ABMR(ABMS,ABMLN),U,3)=$S(ABMP("VTYP")=111!($G(ABMP("BTYP"))=111):21,ABMP("BTYP")=831:24,1:11)
  1.  .;   if Place of service set to 11 check to see if pointer exists 
  1.  .;   in Parameter file to Code file and use it
  1.  .I $P(ABMR(ABMS,ABMLN),U,3)=11 D
  1.  ..S ABMPTR=$P($G(^ABMDPARM(ABMP("LDFN"),1,3)),"^",6)
  1.  ..S:ABMPTR="" ABMPTR=$P($G(^ABMDPARM(DUZ(2),1,3)),"^",6) Q:'ABMPTR
  1.  ..Q:'$D(^ABMDCODE(ABMPTR,0))
  1.  ..S $P(ABMR(ABMS,ABMLN),U,3)=$P(^ABMDCODE(ABMPTR,0),U)
  1.  .I $P($G(^DIC(40.7,+ABMP("CLN"),0)),"^",2)=30 D
  1.  ..S $P(ABMR(ABMS,ABMLN),U,3)=23
  1.  ;
  1.  ; Set CPT/HCPCS                        ; Form locator 24D
  1.  I $P($G(^ABMNINS(DUZ(2),ABMP("INS"),1,ABMP("VTYP"),0)),U,16)]"" D
  1.  .S $P(ABMR(ABMS,ABMLN),U,5)=$P($$CPT^ABMCVAPI($P(^ABMNINS(DUZ(2),ABMP("INS"),1,ABMP("VTYP"),0),U,16),ABMP("VDT")),U,2)  ;CSV-c
  1.  E  I $P($G(ABMS(ABMS)),U,4)]"" D  I 1
  1.  .S $P(ABMR(ABMS,ABMLN),U,5)=" "_$P(ABMS(ABMS),U,4)
  1.  .; If CPT code, and modifier exists, add it
  1.  .S $P(ABMR(ABMS,ABMLN),U,5)=" "_$P(ABMR(ABMS,ABMLN),U,5)_$S($E($P(ABMS(ABMS),U,8))="#":" "_$P($P(ABMS(ABMS),U,8)," "),1:"")
  1.  .S:$G(ABM("EPSDT")) $P(ABMR(ABMS,ABMLN),U,9)="X"  ; Form locator 24H
  1.  .S:$G(ABM("EMG")) $P(ABMR(ABMS,ABMLN),U,4)="X"   ; Form locator 24C
  1.  E  D  ;abm*2.6*11 HEAT30524
  1.  .I $P($G(^AUTNINS(ABMP("INS"),0)),U)["PHC MEDICAID" S $P(ABMS(ABMS),U,8)=$TR($P(ABMS(ABMS),U,8),"-")  ;abm*2.6*11 HEAT30524
  1.  S:$P(ABMR(ABMS,ABMLN),U,5)["NO CODE SELECTED" $P(ABMR(ABMS,ABMLN),U,5)=""  ;abm*2.6*11 HEAT91425
  1.  ;E  D  ;abm*2.6*7 HEAT30524
  1.  ;start old code abm*2.6*8
  1.  ;I $P($G(^ABMNINS(DUZ(2),ABMP("INS"),1,ABMP("VTYP"),0)),U,16)]"" D  ;abm*2.6*7 HEAT30524
  1.  ;.I $L($P(ABMS(ABMS),U,8))>16 D  Q
  1.  ;..S ABMU("LNG")=60
  1.  ;..S ABMU("TXT")=$P(ABMS(ABMS),U,8)
  1.  ;..S ABMU=3
  1.  ;..D LNG^ABMDWRAP
  1.  ;..S ABMLND=ABMLN-1,J=0
  1.  ;..F  S J=$O(ABMU(J)) Q:+J=0!(+J>2)  D
  1.  ;...S $P(ABMR(ABMS,ABMLND),U)=$G(ABMU(J))
  1.  ;...S ABMLND=ABMLND+1
  1.  ;.K ABMU
  1.  ;.S $P(ABMR(ABMS,ABMLN),U,5)=$P(ABMS(ABMS),U,8)
  1.  ;end old code start new code
  1.  ;I $L($P(ABMS(ABMS),U,8))>16,($E($P(ABMS(ABMS),U,8),1,2)="N4") D  ;abm*2.6*21 IHS/SD/SDR HEAT168435
  1.  I ($E($P(ABMS(ABMS),U,8),1,2)="N4") D  ;abm*2.6*21 IHS/SD/SDR HEAT168435
  1.  .S ABMU("LNG")=60
  1.  .S ABMU("TXT")=$P(ABMS(ABMS),U,8)
  1.  .S ABMU=3
  1.  .D LNG^ABMDWRAP
  1.  .S ABMLND=ABMLN-1,J=0
  1.  .F  S J=$O(ABMU(J)) Q:+J=0!(+J>2)  D
  1.  ..S $P(ABMR(ABMS,ABMLND),U)=$G(ABMU(J))
  1.  ..S ABMLND=ABMLND+1
  1.  .K ABMU
  1.  E  S:($E($P(ABMS(ABMS),U,8),1,2)="N4") $P(ABMR(ABMS,ABMLN),U,5)=$P(ABMS(ABMS),U,8)
  1.  ;end new code abm*2.6*8
  1.  S ABMCORDX=$P(ABMS(ABMS),U,5)
  1.  ;I +ABMCORDX>4,$G(ABMP("BDFN")) D  ;abm*2.6*4 HEAT12115
  1.  I +ABMCORDX>8,$G(ABMP("BDFN")) D  ;abm*2.6*4 HEAT12115
  1.  .S ABMCORDX=$P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),17,ABMCORDX,0)),"^",2)
  1.  I $D(ABMP("FLAT")),$G(ABMP("BDFN")) D
  1.  .N ABMDXCNT,ABMTMP
  1.  .S ABMDXCNT=$P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),17,0)),U,4)
  1.  .S:+ABMDXCNT>4 ABMDXCNT=4
  1.  .F ABMTMP=1:1:ABMDXCNT S $P(ABMCORDX,",",ABMTMP)=ABMTMP
  1.  ; Diagnosis code               Form locator 24E
  1.  S $P(ABMR(ABMS,ABMLN),U,6)=$TR(ABMCORDX,",")
  1.  ; Charges                      Form locator 24F
  1.  S $P(ABMR(ABMS,ABMLN),U,7)=$P(ABMS(ABMS),U)
  1.  ; Days or units                Form locator 24G
  1.  S $P(ABMR(ABMS,ABMLN),U,8)=$P(ABMS(ABMS),U,6)
  1.  ; Reserved for local use       Form locator 24K (1)
  1.  I $P(ABMS(ABMS),"^",9)'="" D
  1.  .S ABMLOCAL=$P(ABMS(ABMS),"^",9)
  1.  .I $P($G(^ABMNINS(DUZ(2),ABMP("INS"),1,ABMP("VTYP"),0)),"^",15)="MD" D
  1.  ..S $P(ABMR(ABMS,ABMLN-1),U,3)=ABMLOCAL
  1.  .K ABMLOCAL
  1.  ;S:($P(ABMS(ABMS),U,11)&($G(ABMP("NPIS"))'="")&(ABMP("NPIS")'="N")) $P(ABMR(ABMS,ABMLN-1),U,3)=$P(ABMS(ABMS),U,9)  ;abm*2.6*3 NOHEAT
  1.  ;S:($P(ABMS(ABMS),U,11)&($G(ABMP("NPIS"))'="")&(ABMP("NPIS")'="N")) $P(ABMR(ABMS,ABMLN-1),U,3)="ZZ "_$P(ABMS(ABMS),U,9)  ;abm*2.6*8 HEAT31586
  1.  ;start new code abm*2.6*8 HEAT31586
  1.   I $G(ABMP("EXP"))=27 D
  1.  .S:+$G(ABMDUZ2)=0 ABMDUZ2=DUZ(2)
  1.  .S ABMPQ=$S(ABMP("ITYPE")="R":"1C"_" ",ABMP("ITYPE")="D":"1D"_" ",$P($G(^ABMNINS(ABMDUZ2,ABMP("INS"),1,ABMP("VTYP"),1)),U)'="":$P($G(^ABMREFID($P($G(^ABMNINS(ABMDUZ2,ABMP("INS"),1,ABMP("VTYP"),1)),U),0)),U),1:"0B"_" ")
  1.  I ($P(ABMS(ABMS),U,11)&($G(ABMP("NPIS"))'="")&(ABMP("NPIS")'="N")) D
  1.  .S $P(ABMR(ABMS,ABMLN-1),U,2)=ABMPQ
  1.  .S $P(ABMR(ABMS,ABMLN-1),U,3)=$P(ABMS(ABMS),U,9)
  1.  ;end new code HEAT31586
  1.  I $G(ABMP("ITYPE"))="R"&($G(ABMP("BTYP"))="831") S $P(ABMR(ABMS,ABMLN-1),U,3)=""
  1.  S:$P(ABMS(ABMS),U,11) $P(ABMR(ABMS,ABMLN),U,11)=$P(ABMS(ABMS),U,11)  ;Form Locator 24K (2)
  1.  K ABMS(ABMS),ABMPTR,ABMCORDX
  1.  Q