ABMDF35E ; IHS/SD/SDR - Set HCFA1500 (02/12) Print Array - Part 5 ;
;;2.6;IHS 3P BILLING SYSTEM;**13,21,22**;NOV 12, 2009;Build 418
;IHS/SD/SDR - 2.6*21 - HEAT223194 - Fixed EPSDT field so it will print either the second character from the referral
; or an 'U' for no referral.
;IHS/SD/SDR 2.6*22 HEAT335246 Added code to print the appropriate CPT based on if the NDC prompt is answered or not.
;
; *********************************************************************
;
EMG ;EP for setting Emerg or Special Prog variable
;S (ABM,ABM("EPSDT"))=0 ;abm*2.6*21 IHS/SD/SDR HEAT223194
S ABM=0 ;abm*2.6*21 IHS/SD/SDR HEAT223194
S ABM("EPSDT")="" ;abm*2.6*21 IHS/SD/SDR HEAT223194
F S ABM=$O(^ABMDBILL(DUZ(2),ABMP("BDFN"),59,ABM)) Q:'ABM D
.S ABM("X")=$P(^ABMDBILL(DUZ(2),ABMP("BDFN"),59,ABM,0),U)
.Q:ABM("X")=""
.;I $P(^ABMDCODE(ABM("X"),0),U)["EPSDT"!($P(^(0),U))["FAMILY" S ABM("EPSDT")=1 ;abm*2.6*21 IHS/SD/SDR HEAT223194
.I ($P(^ABMDCODE(ABM("X"),0),U,3)["EPSDT") D ;abm*2.6*21 IHS/SD/SDR HEAT223194
..I $P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),59,ABM,0)),U,2)="N" S ABM("EPSDT")="U" Q ;abm*2.6*21 IHS/SD/SDR HEAT223194
..S ABM("EPSDT")=$O(^ABMDBILL(DUZ(2),ABMP("BDFN"),59,ABM,1,0)) ;abm*2.6*21 IHS/SD/SDR HEAT223194
..S ABM("EPSDT")=$E($P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),59,ABM,1,ABM("EPSDT"),0)),U),2) ;abm*2.6*21 IHS/SD/SDR HEAT223194
.I ($P(^(0),U,3)["FAMILY") S ABM("EPSDT")="X" ;abm*2.6*21 IHS/SD/SDR HEAT223194
S ABM("EMG")=$S($P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),8)),U,5)="Y":1,1:0)
Q
;
PROC ;EP for setting the procedure portion of the ABMF array
; input vars: ABMS(ABMS) - the procedure line in internal format
; ABMS("I") - the current line number
;
; output vars: ABMF(ABMS("I")) - procedure line in external format
; ABMF(ABMS("I")-1) - top line for extended descriptions
;
K %DT
S ABMFDT=$P(ABMS(ABMS),U,2) ;Service date from
S X=$P($P(ABMS(ABMS),U,2),"@") ;Service date from
D ^%DT
S $P(ABMS(ABMS),U,2)=Y ; Service date from in FM Format
S ABMTDT=$P(ABMS(ABMS),U,3) ;Service date to
S X=$P($P(ABMS(ABMS),U,3),"@") ;Service date to
D ^%DT
S $P(ABMS(ABMS),U,3)=Y ; Service date to in FM format
S ABMR(ABMS,ABMLN)=""
S ABMR(ABMS,ABMLN)=$P(ABMS(ABMS),U,2,3) ; Form locator 24A
;check if time on charge (anes); if so, add as line 1
I ABMFDT["@" D
.S $P(ABMR(ABMS,ABMLN-1),U)="7Begin "_$TR($P(ABMFDT,"@",2),":")
.S $P(ABMR(ABMS,ABMLN-1),U)=$P(ABMR(ABMS,ABMLN-1),U)_" End "_$TR($P(ABMTDT,"@",2),":")
;
; Set Place of service ; Form locator 24B
; 21 if visit type is inpatient
; 24 if visit type is ambulatory surgery
; 23 if clinic is emergency medicine (code 30)
; 11 for all other cases
I $P(ABMS(ABMS),U,10) S $P(ABMR(ABMS,ABMLN),U,3)=$P($G(^ABMDCODE($P(ABMS(ABMS),U,10),0)),U)
E D
.S $P(ABMR(ABMS,ABMLN),U,3)=$S(ABMP("VTYP")=111!($G(ABMP("BTYP"))=111):21,ABMP("BTYP")=831:24,1:11)
.; if Place of service set to 11 check to see if pointer exists
.; in Parameter file to Code file and use it
.I $P(ABMR(ABMS,ABMLN),U,3)=11 D
..S ABMPTR=$P($G(^ABMDPARM(ABMP("LDFN"),1,3)),"^",6)
..S:ABMPTR="" ABMPTR=$P($G(^ABMDPARM(DUZ(2),1,3)),"^",6) Q:'ABMPTR
..Q:'$D(^ABMDCODE(ABMPTR,0))
..S $P(ABMR(ABMS,ABMLN),U,3)=$P(^ABMDCODE(ABMPTR,0),U)
.I $P($G(^DIC(40.7,+ABMP("CLN"),0)),"^",2)=30 D
..S $P(ABMR(ABMS,ABMLN),U,3)=23
;
; Set CPT/HCPCS ; Form locator 24D
I $P($G(^ABMNINS(DUZ(2),ABMP("INS"),0)),U,14)="Y" S $P(ABMR(ABMS,ABMLN),U,5)=$P(ABMS(ABMS),U,4) ;abm*2.6*22 IHS/SD/SDR HEAT335246
I $P($G(^ABMNINS(DUZ(2),ABMP("INS"),1,ABMP("VTYP"),0)),U,16)]"" D
.I $P($G(^ABMNINS(DUZ(2),ABMP("INS"),0)),U,14)="Y" Q ;don't write default CPT if they want NDC to print ;abm*2.6*22 IHS/SD/SDR HEAT335246
.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
E I $P($G(ABMS(ABMS)),U,4)]"" D I 1
.S $P(ABMR(ABMS,ABMLN),U,5)=" "_$P(ABMS(ABMS),U,4)
.; If CPT code, and modifier exists, add it
.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:"")
.;S:$G(ABM("EPSDT")) $P(ABMR(ABMS,ABMLN),U,9)="X" ; Form locator 24H ;abm*2.6*21 IHS/SD/SDR HEAT223194
.S:$G(ABM("EPSDT"))'="" $P(ABMR(ABMS,ABMLN),U,9)=$G(ABM("EPSDT")) ; Form locator 24H ;abm*2.6*21 IHS/SD/SDR HEAT223194
.S:$G(ABM("EMG")) $P(ABMR(ABMS,ABMLN),U,4)="X" ; Form locator 24C
E D
.I $P($G(^AUTNINS(ABMP("INS"),0)),U)["PHC MEDICAID" S $P(ABMS(ABMS),U,8)=$TR($P(ABMS(ABMS),U,8),"-")
S:$P(ABMR(ABMS,ABMLN),U,5)["NO CODE SELECTED" $P(ABMR(ABMS,ABMLN),U,5)=""
I $L($P(ABMS(ABMS),U,8))>16,($E($P(ABMS(ABMS),U,8),1,2)="N4") D
.S ABMU("LNG")=60
.S ABMU("TXT")=$P(ABMS(ABMS),U,8)
.S ABMU=3
.D LNG^ABMDWRAP
.S ABMLND=ABMLN-1,J=0
.F S J=$O(ABMU(J)) Q:+J=0!(+J>2) D
..S $P(ABMR(ABMS,ABMLND),U)=$G(ABMU(J))
..S ABMLND=ABMLND+1
.K ABMU
E S:($E($P(ABMS(ABMS),U,8),1,2)="N4") $P(ABMR(ABMS,ABMLN),U,5)=$P(ABMS(ABMS),U,8)
; Diagnosis code Form locator 24E
S ABMCORDX=$P(ABMS(ABMS),U,5)
S ABMCORDX=$P(ABMCORDX,",",1,4)
I +$G(ABMCORDX)=0 S ABMCORDX=1 ;for flat rate; doesn't set corr. dx
F ABMTMP=1:1:$L(ABMCORDX,",") D
.S $P(ABMCORDX,",",ABMTMP)=$P("A^B^C^D^E^F^G^H^I^J^K^L^","^",$P(ABMCORDX,",",ABMTMP))
S $P(ABMR(ABMS,ABMLN),U,6)=$TR(ABMCORDX,",")
; Charges Form locator 24F
S $P(ABMR(ABMS,ABMLN),U,7)=$P(ABMS(ABMS),U)
; Days or units Form locator 24G
S $P(ABMR(ABMS,ABMLN),U,8)=$P(ABMS(ABMS),U,6)
; Reserved for local use Form locator 24K (1)
I $P(ABMS(ABMS),"^",9)'="" D
.S ABMLOCAL=$P(ABMS(ABMS),"^",9)
.I $P($G(^ABMNINS(DUZ(2),ABMP("INS"),1,ABMP("VTYP"),0)),"^",15)="MD" D
..S $P(ABMR(ABMS,ABMLN-1),U,3)=ABMLOCAL
.K ABMLOCAL
I $G(ABMP("EXP"))=35 D
.S:+$G(ABMDUZ2)=0 ABMDUZ2=DUZ(2)
.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"_" ")
I ($P(ABMS(ABMS),U,11)&($G(ABMP("NPIS"))'="")&(ABMP("NPIS")'="N")) D
.S $P(ABMR(ABMS,ABMLN-1),U,2)=ABMPQ
.S $P(ABMR(ABMS,ABMLN-1),U,3)=$P(ABMS(ABMS),U,9)
I $G(ABMP("ITYPE"))="R"&($G(ABMP("BTYP"))="831") S $P(ABMR(ABMS,ABMLN-1),U,3)=""
S:$P(ABMS(ABMS),U,11) $P(ABMR(ABMS,ABMLN),U,11)=$P(ABMS(ABMS),U,11) ;Form Locator 24K (2)
K ABMS(ABMS),ABMPTR,ABMCORDX
Q
ABMDF35E ; IHS/SD/SDR - Set HCFA1500 (02/12) Print Array - Part 5 ;
+1 ;;2.6;IHS 3P BILLING SYSTEM;**13,21,22**;NOV 12, 2009;Build 418
+2 ;IHS/SD/SDR - 2.6*21 - HEAT223194 - Fixed EPSDT field so it will print either the second character from the referral
+3 ; or an 'U' for no referral.
+4 ;IHS/SD/SDR 2.6*22 HEAT335246 Added code to print the appropriate CPT based on if the NDC prompt is answered or not.
+5 ;
+6 ; *********************************************************************
+7 ;
EMG ;EP for setting Emerg or Special Prog variable
+1 ;S (ABM,ABM("EPSDT"))=0 ;abm*2.6*21 IHS/SD/SDR HEAT223194
+2 ;abm*2.6*21 IHS/SD/SDR HEAT223194
SET ABM=0
+3 ;abm*2.6*21 IHS/SD/SDR HEAT223194
SET ABM("EPSDT")=""
+4 FOR
SET ABM=$ORDER(^ABMDBILL(DUZ(2),ABMP("BDFN"),59,ABM))
IF 'ABM
QUIT
Begin DoDot:1
+5 SET ABM("X")=$PIECE(^ABMDBILL(DUZ(2),ABMP("BDFN"),59,ABM,0),U)
+6 IF ABM("X")=""
QUIT
+7 ;I $P(^ABMDCODE(ABM("X"),0),U)["EPSDT"!($P(^(0),U))["FAMILY" S ABM("EPSDT")=1 ;abm*2.6*21 IHS/SD/SDR HEAT223194
+8 ;abm*2.6*21 IHS/SD/SDR HEAT223194
IF ($PIECE(^ABMDCODE(ABM("X"),0),U,3)["EPSDT")
Begin DoDot:2
+9 ;abm*2.6*21 IHS/SD/SDR HEAT223194
IF $PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),59,ABM,0)),U,2)="N"
SET ABM("EPSDT")="U"
QUIT
+10 ;abm*2.6*21 IHS/SD/SDR HEAT223194
SET ABM("EPSDT")=$ORDER(^ABMDBILL(DUZ(2),ABMP("BDFN"),59,ABM,1,0))
+11 ;abm*2.6*21 IHS/SD/SDR HEAT223194
SET ABM("EPSDT")=$EXTRACT($PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),59,ABM,1,ABM("EPSDT"),0)),U),2)
End DoDot:2
+12 ;abm*2.6*21 IHS/SD/SDR HEAT223194
IF ($PIECE(^(0),U,3)["FAMILY")
SET ABM("EPSDT")="X"
End DoDot:1
+13 SET ABM("EMG")=$SELECT($PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),8)),U,5)="Y":1,1:0)
+14 QUIT
+15 ;
PROC ;EP for setting the procedure portion of the ABMF array
+1 ; input vars: ABMS(ABMS) - the procedure line in internal format
+2 ; ABMS("I") - the current line number
+3 ;
+4 ; output vars: ABMF(ABMS("I")) - procedure line in external format
+5 ; ABMF(ABMS("I")-1) - top line for extended descriptions
+6 ;
+7 KILL %DT
+8 ;Service date from
SET ABMFDT=$PIECE(ABMS(ABMS),U,2)
+9 ;Service date from
SET X=$PIECE($PIECE(ABMS(ABMS),U,2),"@")
+10 DO ^%DT
+11 ; Service date from in FM Format
SET $PIECE(ABMS(ABMS),U,2)=Y
+12 ;Service date to
SET ABMTDT=$PIECE(ABMS(ABMS),U,3)
+13 ;Service date to
SET X=$PIECE($PIECE(ABMS(ABMS),U,3),"@")
+14 DO ^%DT
+15 ; Service date to in FM format
SET $PIECE(ABMS(ABMS),U,3)=Y
+16 SET ABMR(ABMS,ABMLN)=""
+17 ; Form locator 24A
SET ABMR(ABMS,ABMLN)=$PIECE(ABMS(ABMS),U,2,3)
+18 ;check if time on charge (anes); if so, add as line 1
+19 IF ABMFDT["@"
Begin DoDot:1
+20 SET $PIECE(ABMR(ABMS,ABMLN-1),U)="7Begin "_$TRANSLATE($PIECE(ABMFDT,"@",2),":")
+21 SET $PIECE(ABMR(ABMS,ABMLN-1),U)=$PIECE(ABMR(ABMS,ABMLN-1),U)_" End "_$TRANSLATE($PIECE(ABMTDT,"@",2),":")
End DoDot:1
+22 ;
+23 ; Set Place of service ; Form locator 24B
+24 ; 21 if visit type is inpatient
+25 ; 24 if visit type is ambulatory surgery
+26 ; 23 if clinic is emergency medicine (code 30)
+27 ; 11 for all other cases
+28 IF $PIECE(ABMS(ABMS),U,10)
SET $PIECE(ABMR(ABMS,ABMLN),U,3)=$PIECE($GET(^ABMDCODE($PIECE(ABMS(ABMS),U,10),0)),U)
+29 IF '$TEST
Begin DoDot:1
+30 SET $PIECE(ABMR(ABMS,ABMLN),U,3)=$SELECT(ABMP("VTYP")=111!($GET(ABMP("BTYP"))=111):21,ABMP("BTYP")=831:24,1:11)
+31 ; if Place of service set to 11 check to see if pointer exists
+32 ; in Parameter file to Code file and use it
+33 IF $PIECE(ABMR(ABMS,ABMLN),U,3)=11
Begin DoDot:2
+34 SET ABMPTR=$PIECE($GET(^ABMDPARM(ABMP("LDFN"),1,3)),"^",6)
+35 IF ABMPTR=""
SET ABMPTR=$PIECE($GET(^ABMDPARM(DUZ(2),1,3)),"^",6)
IF 'ABMPTR
QUIT
+36 IF '$DATA(^ABMDCODE(ABMPTR,0))
QUIT
+37 SET $PIECE(ABMR(ABMS,ABMLN),U,3)=$PIECE(^ABMDCODE(ABMPTR,0),U)
End DoDot:2
+38 IF $PIECE($GET(^DIC(40.7,+ABMP("CLN"),0)),"^",2)=30
Begin DoDot:2
+39 SET $PIECE(ABMR(ABMS,ABMLN),U,3)=23
End DoDot:2
End DoDot:1
+40 ;
+41 ; Set CPT/HCPCS ; Form locator 24D
+42 ;abm*2.6*22 IHS/SD/SDR HEAT335246
IF $PIECE($GET(^ABMNINS(DUZ(2),ABMP("INS"),0)),U,14)="Y"
SET $PIECE(ABMR(ABMS,ABMLN),U,5)=$PIECE(ABMS(ABMS),U,4)
+43 IF $PIECE($GET(^ABMNINS(DUZ(2),ABMP("INS"),1,ABMP("VTYP"),0)),U,16)]""
Begin DoDot:1
+44 ;don't write default CPT if they want NDC to print ;abm*2.6*22 IHS/SD/SDR HEAT335246
IF $PIECE($GET(^ABMNINS(DUZ(2),ABMP("INS"),0)),U,14)="Y"
QUIT
+45 ;CSV-c
SET $PIECE(ABMR(ABMS,ABMLN),U,5)=$PIECE($$CPT^ABMCVAPI($PIECE(^ABMNINS(DUZ(2),ABMP("INS"),1,ABMP("VTYP"),0),U,16),ABMP("VDT")),U,2)
End DoDot:1
+46 IF '$TEST
IF $PIECE($GET(ABMS(ABMS)),U,4)]""
Begin DoDot:1
+47 SET $PIECE(ABMR(ABMS,ABMLN),U,5)=" "_$PIECE(ABMS(ABMS),U,4)
+48 ; If CPT code, and modifier exists, add it
+49 SET $PIECE(ABMR(ABMS,ABMLN),U,5)=" "_$PIECE(ABMR(ABMS,ABMLN),U,5)_$SELECT($EXTRACT($PIECE(ABMS(ABMS),U,8))="#":" "_$PIECE($PIECE(ABMS(ABMS),U,8)," "),1:"")
+50 ;S:$G(ABM("EPSDT")) $P(ABMR(ABMS,ABMLN),U,9)="X" ; Form locator 24H ;abm*2.6*21 IHS/SD/SDR HEAT223194
+51 ; Form locator 24H ;abm*2.6*21 IHS/SD/SDR HEAT223194
IF $GET(ABM("EPSDT"))'=""
SET $PIECE(ABMR(ABMS,ABMLN),U,9)=$GET(ABM("EPSDT"))
+52 ; Form locator 24C
IF $GET(ABM("EMG"))
SET $PIECE(ABMR(ABMS,ABMLN),U,4)="X"
End DoDot:1
IF 1
+53 IF '$TEST
Begin DoDot:1
+54 IF $PIECE($GET(^AUTNINS(ABMP("INS"),0)),U)["PHC MEDICAID"
SET $PIECE(ABMS(ABMS),U,8)=$TRANSLATE($PIECE(ABMS(ABMS),U,8),"-")
End DoDot:1
+55 IF $PIECE(ABMR(ABMS,ABMLN),U,5)["NO CODE SELECTED"
SET $PIECE(ABMR(ABMS,ABMLN),U,5)=""
+56 IF $LENGTH($PIECE(ABMS(ABMS),U,8))>16
IF ($EXTRACT($PIECE(ABMS(ABMS),U,8),1,2)="N4")
Begin DoDot:1
+57 SET ABMU("LNG")=60
+58 SET ABMU("TXT")=$PIECE(ABMS(ABMS),U,8)
+59 SET ABMU=3
+60 DO LNG^ABMDWRAP
+61 SET ABMLND=ABMLN-1
SET J=0
+62 FOR
SET J=$ORDER(ABMU(J))
IF +J=0!(+J>2)
QUIT
Begin DoDot:2
+63 SET $PIECE(ABMR(ABMS,ABMLND),U)=$GET(ABMU(J))
+64 SET ABMLND=ABMLND+1
End DoDot:2
+65 KILL ABMU
End DoDot:1
+66 IF '$TEST
IF ($EXTRACT($PIECE(ABMS(ABMS),U,8),1,2)="N4")
SET $PIECE(ABMR(ABMS,ABMLN),U,5)=$PIECE(ABMS(ABMS),U,8)
+67 ; Diagnosis code Form locator 24E
+68 SET ABMCORDX=$PIECE(ABMS(ABMS),U,5)
+69 SET ABMCORDX=$PIECE(ABMCORDX,",",1,4)
+70 ;for flat rate; doesn't set corr. dx
IF +$GET(ABMCORDX)=0
SET ABMCORDX=1
+71 FOR ABMTMP=1:1:$LENGTH(ABMCORDX,",")
Begin DoDot:1
+72 SET $PIECE(ABMCORDX,",",ABMTMP)=$PIECE("A^B^C^D^E^F^G^H^I^J^K^L^","^",$PIECE(ABMCORDX,",",ABMTMP))
End DoDot:1
+73 SET $PIECE(ABMR(ABMS,ABMLN),U,6)=$TRANSLATE(ABMCORDX,",")
+74 ; Charges Form locator 24F
+75 SET $PIECE(ABMR(ABMS,ABMLN),U,7)=$PIECE(ABMS(ABMS),U)
+76 ; Days or units Form locator 24G
+77 SET $PIECE(ABMR(ABMS,ABMLN),U,8)=$PIECE(ABMS(ABMS),U,6)
+78 ; Reserved for local use Form locator 24K (1)
+79 IF $PIECE(ABMS(ABMS),"^",9)'=""
Begin DoDot:1
+80 SET ABMLOCAL=$PIECE(ABMS(ABMS),"^",9)
+81 IF $PIECE($GET(^ABMNINS(DUZ(2),ABMP("INS"),1,ABMP("VTYP"),0)),"^",15)="MD"
Begin DoDot:2
+82 SET $PIECE(ABMR(ABMS,ABMLN-1),U,3)=ABMLOCAL
End DoDot:2
+83 KILL ABMLOCAL
End DoDot:1
+84 IF $GET(ABMP("EXP"))=35
Begin DoDot:1
+85 IF +$GET(ABMDUZ2)=0
SET ABMDUZ2=DUZ(2)
+86 SET ABMPQ=$SELECT(ABMP("ITYPE")="R":"1C"_" ",ABMP("ITYPE")="D":"1D"_" ",$PIECE($GET(^ABMNINS(ABMDUZ2,ABMP("INS"),1,ABMP("VTYP"),1)),U)'="":$PIECE($GET(^ABMREFID($PIECE($GET(^ABMNINS(ABMDUZ2,ABMP("INS"),1,ABMP("VTYP"),1)),U),0)),U),1:"0B
"_" ")
End DoDot:1
+87 IF ($PIECE(ABMS(ABMS),U,11)&($GET(ABMP("NPIS"))'="")&(ABMP("NPIS")'="N"))
Begin DoDot:1
+88 SET $PIECE(ABMR(ABMS,ABMLN-1),U,2)=ABMPQ
+89 SET $PIECE(ABMR(ABMS,ABMLN-1),U,3)=$PIECE(ABMS(ABMS),U,9)
End DoDot:1
+90 IF $GET(ABMP("ITYPE"))="R"&($GET(ABMP("BTYP"))="831")
SET $PIECE(ABMR(ABMS,ABMLN-1),U,3)=""
+91 ;Form Locator 24K (2)
IF $PIECE(ABMS(ABMS),U,11)
SET $PIECE(ABMR(ABMS,ABMLN),U,11)=$PIECE(ABMS(ABMS),U,11)
+92 KILL ABMS(ABMS),ABMPTR,ABMCORDX
+93 QUIT
