ABMDF14E ; IHS/ASDST/DMJ - Set HCFA1500 Print Array - Part 5 ;
;;2.6;IHS 3P BILLING SYSTEM;;NOV 12, 2009
;Original;TMD;02/26/96 3:55 PM
;
; IHS/DSD/LSL - 05/20/98 - NOIS XIA-0398-200180
; Can't get the right dental charges on bill with 00099
; HCPCS code. Answer CPT code question in table
; maintenance with CPT code and will print before any
; other
; IHS/DSD/LSL - 05/22/98 - NOIS NCA-0598-180077
; If flat rate, corresponding dx should print all DX
; in order ie 1,2,3....
; IHS/ASDS/DMJ - 05/16/00 - V2.4 Patch 1 - NOIS HQW-0500-100040
; Modified location code to check for satellite first. If no
; satellite, use parent.
; IHS/ASDS/LSL - 11/20/01 - V2.4 Patch 10 - NOIS PAB-1001-90056
; Allow local HCPCS codes to print in 24D
; IHS/ASDS/LSL - 11/21/01 - V2.4 Patch 10 - NOIS OLC-1101-190067
; When putting the dental prefix on dental codes, still need
; to see tooth surface and op site.
;
; IHS/SD/SDR - v2.5 p5 - 5/18/04 - Modified to put POS and TOS by line item
; IHS/SD/SDR - v2.5 p8 - task 57
; Added code for MD and Rx number
; IHS/SD/SDR - v2.5 p10 - IM20197
; Don't allow 2-line item to print on two pages
; IHS/SD/SDR - v2.5 p11 - IM22467
; Removed splitting of block 24K (was printing provider number
; one two lines)
;
; IHS/SD/SDR - v2.6 CSV
;
; *********************************************************************
;
EMG ;EP for setting Emerg or Special Prog variable
S (ABM,ABM("EPSDT"))=0
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
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 X=$P(ABMS(ABMS),U,2) ; Service date from
D ^%DT
S $P(ABMS(ABMS),U,2)=Y ; Service date from in FM Format
S X=$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
; 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("VTYP")=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 Type of service ; Form locator 24C
S $P(ABMR(ABMS,ABMLN),U,4)=$P(ABMS(ABMS),U,7)
; Set CPT/HCPCS ; Form locator 24D
I $P($G(^ABMNINS(DUZ(2),ABMP("INS"),1,ABMP("VTYP"),0)),U,16)]"" D
.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
.S:$G(ABM("EMG")) $P(ABMR(ABMS,ABMLN),U,10)="X" ; Form locator 24I
E D
.I $L($P(ABMS(ABMS),U,8))>16 D Q
..S ABMU("LNG")=16
..S ABMU("TXT")=$P(ABMS(ABMS),U,8)
..S ABMU=4
..D LNG^ABMDWRAP
..S ABMLND=ABMLN-1,J=0
..F S J=$O(ABMU(J)) Q:+J=0!(+J>3) D
...I J=2 S $P(ABMR(ABMS,ABMLND),U,5)=$G(ABMU(J))
...E S $P(ABMR(ABMS,ABMLND),U)=$G(ABMU(J))
...S ABMLND=ABMLND+1
..K ABMU
.S $P(ABMR(ABMS,ABMLN),U,5)=$P(ABMS(ABMS),U,8)
S ABMCORDX=$P(ABMS(ABMS),U,5)
I +ABMCORDX>4,$G(ABMP("BDFN")) D
.S ABMCORDX=$P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),17,ABMCORDX,0)),"^",2)
I $D(ABMP("FLAT")),$G(ABMP("BDFN")) D
.N ABMDXCNT,ABMTMP
.S ABMDXCNT=$P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),17,0)),U,4)
.S:+ABMDXCNT>4 ABMDXCNT=4
.F ABMTMP=1:1:ABMDXCNT S $P(ABMCORDX,",",ABMTMP)=ABMTMP
; Diagnosis code Form locator 24E
S $P(ABMR(ABMS,ABMLN),U,6)=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
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)="RX" D
..S $P(ABMR(ABMS,ABMLN),U,12)=$P(ABMLOCAL,";;") ;Prescription#
.I $P($G(^ABMNINS(DUZ(2),ABMP("INS"),1,ABMP("VTYP"),0)),"^",15)="MD" D
..S $P(ABMR(ABMS,ABMLN),U,12)=ABMLOCAL
.K ABMLOCAL
K ABMS(ABMS),ABMPTR,ABMCORDX
Q
ABMDF14E ; IHS/ASDST/DMJ - Set HCFA1500 Print Array - Part 5 ;
+1 ;;2.6;IHS 3P BILLING SYSTEM;;NOV 12, 2009
+2 ;Original;TMD;02/26/96 3:55 PM
+3 ;
+4 ; IHS/DSD/LSL - 05/20/98 - NOIS XIA-0398-200180
+5 ; Can't get the right dental charges on bill with 00099
+6 ; HCPCS code. Answer CPT code question in table
+7 ; maintenance with CPT code and will print before any
+8 ; other
+9 ; IHS/DSD/LSL - 05/22/98 - NOIS NCA-0598-180077
+10 ; If flat rate, corresponding dx should print all DX
+11 ; in order ie 1,2,3....
+12 ; IHS/ASDS/DMJ - 05/16/00 - V2.4 Patch 1 - NOIS HQW-0500-100040
+13 ; Modified location code to check for satellite first. If no
+14 ; satellite, use parent.
+15 ; IHS/ASDS/LSL - 11/20/01 - V2.4 Patch 10 - NOIS PAB-1001-90056
+16 ; Allow local HCPCS codes to print in 24D
+17 ; IHS/ASDS/LSL - 11/21/01 - V2.4 Patch 10 - NOIS OLC-1101-190067
+18 ; When putting the dental prefix on dental codes, still need
+19 ; to see tooth surface and op site.
+20 ;
+21 ; IHS/SD/SDR - v2.5 p5 - 5/18/04 - Modified to put POS and TOS by line item
+22 ; IHS/SD/SDR - v2.5 p8 - task 57
+23 ; Added code for MD and Rx number
+24 ; IHS/SD/SDR - v2.5 p10 - IM20197
+25 ; Don't allow 2-line item to print on two pages
+26 ; IHS/SD/SDR - v2.5 p11 - IM22467
+27 ; Removed splitting of block 24K (was printing provider number
+28 ; one two lines)
+29 ;
+30 ; IHS/SD/SDR - v2.6 CSV
+31 ;
+32 ; *********************************************************************
+33 ;
EMG ;EP for setting Emerg or Special Prog variable
+1 SET (ABM,ABM("EPSDT"))=0
+2 FOR
SET ABM=$ORDER(^ABMDBILL(DUZ(2),ABMP("BDFN"),59,ABM))
IF 'ABM
QUIT
Begin DoDot:1
+3 SET ABM("X")=$PIECE(^ABMDBILL(DUZ(2),ABMP("BDFN"),59,ABM,0),U)
+4 IF ABM("X")=""
QUIT
+5 IF $PIECE(^ABMDCODE(ABM("X"),0),U)["EPSDT"!($PIECE(^(0),U))["FAMILY"
SET ABM("EPSDT")=1
End DoDot:1
+6 SET ABM("EMG")=$SELECT($PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),8)),U,5)="Y":1,1:0)
+7 QUIT
+8 ;
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 X=$PIECE(ABMS(ABMS),U,2)
+9 DO ^%DT
+10 ; Service date from in FM Format
SET $PIECE(ABMS(ABMS),U,2)=Y
+11 ; Service date to
SET X=$PIECE(ABMS(ABMS),U,3)
+12 DO ^%DT
+13 ; Service date to in FM format
SET $PIECE(ABMS(ABMS),U,3)=Y
+14 SET ABMR(ABMS,ABMLN)=""
+15 ; Form locator 24A
SET ABMR(ABMS,ABMLN)=$PIECE(ABMS(ABMS),U,2,3)
+16 ; Set Place of service ; Form locator 24B
+17 ; 21 if visit type is inpatient
+18 ; 24 if visit type is ambulatory surgery
+19 ; 23 if clinic is emergency medicine (code 30)
+20 ; 11 for all other cases
+21 IF $PIECE(ABMS(ABMS),U,10)
SET $PIECE(ABMR(ABMS,ABMLN),U,3)=$PIECE($GET(^ABMDCODE($PIECE(ABMS(ABMS),U,10),0)),U)
+22 IF '$TEST
Begin DoDot:1
+23 SET $PIECE(ABMR(ABMS,ABMLN),U,3)=$SELECT(ABMP("VTYP")=111!($GET(ABMP("BTYP"))=111):21,ABMP("VTYP")=831:24,1:11)
+24 ; if Place of service set to 11 check to see if pointer exists
+25 ; in Parameter file to Code file and use it
+26 IF $PIECE(ABMR(ABMS,ABMLN),U,3)=11
Begin DoDot:2
+27 SET ABMPTR=$PIECE($GET(^ABMDPARM(ABMP("LDFN"),1,3)),"^",6)
+28 IF ABMPTR=""
SET ABMPTR=$PIECE($GET(^ABMDPARM(DUZ(2),1,3)),"^",6)
IF 'ABMPTR
QUIT
+29 IF '$DATA(^ABMDCODE(ABMPTR,0))
QUIT
+30 SET $PIECE(ABMR(ABMS,ABMLN),U,3)=$PIECE(^ABMDCODE(ABMPTR,0),U)
End DoDot:2
+31 IF $PIECE($GET(^DIC(40.7,+ABMP("CLN"),0)),"^",2)=30
Begin DoDot:2
+32 SET $PIECE(ABMR(ABMS,ABMLN),U,3)=23
End DoDot:2
End DoDot:1
+33 ;
+34 ; Set Type of service ; Form locator 24C
+35 SET $PIECE(ABMR(ABMS,ABMLN),U,4)=$PIECE(ABMS(ABMS),U,7)
+36 ; Set CPT/HCPCS ; Form locator 24D
+37 IF $PIECE($GET(^ABMNINS(DUZ(2),ABMP("INS"),1,ABMP("VTYP"),0)),U,16)]""
Begin DoDot:1
+38 ;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
+39 IF '$TEST
IF $PIECE($GET(ABMS(ABMS)),U,4)]""
Begin DoDot:1
+40 SET $PIECE(ABMR(ABMS,ABMLN),U,5)=" "_$PIECE(ABMS(ABMS),U,4)
+41 ; If CPT code, and modifier exists, add it
+42 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:"")
+43 ; Form locator 24H
IF $GET(ABM("EPSDT"))
SET $PIECE(ABMR(ABMS,ABMLN),U,9)="X"
+44 ; Form locator 24I
IF $GET(ABM("EMG"))
SET $PIECE(ABMR(ABMS,ABMLN),U,10)="X"
End DoDot:1
IF 1
+45 IF '$TEST
Begin DoDot:1
+46 IF $LENGTH($PIECE(ABMS(ABMS),U,8))>16
Begin DoDot:2
+47 SET ABMU("LNG")=16
+48 SET ABMU("TXT")=$PIECE(ABMS(ABMS),U,8)
+49 SET ABMU=4
+50 DO LNG^ABMDWRAP
+51 SET ABMLND=ABMLN-1
SET J=0
+52 FOR
SET J=$ORDER(ABMU(J))
IF +J=0!(+J>3)
QUIT
Begin DoDot:3
+53 IF J=2
SET $PIECE(ABMR(ABMS,ABMLND),U,5)=$GET(ABMU(J))
+54 IF '$TEST
SET $PIECE(ABMR(ABMS,ABMLND),U)=$GET(ABMU(J))
+55 SET ABMLND=ABMLND+1
End DoDot:3
+56 KILL ABMU
End DoDot:2
QUIT
+57 SET $PIECE(ABMR(ABMS,ABMLN),U,5)=$PIECE(ABMS(ABMS),U,8)
End DoDot:1
+58 SET ABMCORDX=$PIECE(ABMS(ABMS),U,5)
+59 IF +ABMCORDX>4
IF $GET(ABMP("BDFN"))
Begin DoDot:1
+60 SET ABMCORDX=$PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),17,ABMCORDX,0)),"^",2)
End DoDot:1
+61 IF $DATA(ABMP("FLAT"))
IF $GET(ABMP("BDFN"))
Begin DoDot:1
+62 NEW ABMDXCNT,ABMTMP
+63 SET ABMDXCNT=$PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),17,0)),U,4)
+64 IF +ABMDXCNT>4
SET ABMDXCNT=4
+65 FOR ABMTMP=1:1:ABMDXCNT
SET $PIECE(ABMCORDX,",",ABMTMP)=ABMTMP
End DoDot:1
+66 ; Diagnosis code Form locator 24E
+67 SET $PIECE(ABMR(ABMS,ABMLN),U,6)=ABMCORDX
+68 ; Charges Form locator 24F
+69 SET $PIECE(ABMR(ABMS,ABMLN),U,7)=$PIECE(ABMS(ABMS),U)
+70 ; Days or units Form locator 24G
+71 SET $PIECE(ABMR(ABMS,ABMLN),U,8)=$PIECE(ABMS(ABMS),U,6)
+72 ; Reserved for local use Form locator 24K
+73 IF $PIECE(ABMS(ABMS),"^",9)'=""
Begin DoDot:1
+74 SET ABMLOCAL=$PIECE(ABMS(ABMS),"^",9)
+75 IF $PIECE($GET(^ABMNINS(DUZ(2),ABMP("INS"),1,ABMP("VTYP"),0)),"^",15)="RX"
Begin DoDot:2
+76 ;Prescription#
SET $PIECE(ABMR(ABMS,ABMLN),U,12)=$PIECE(ABMLOCAL,";;")
End DoDot:2
+77 IF $PIECE($GET(^ABMNINS(DUZ(2),ABMP("INS"),1,ABMP("VTYP"),0)),"^",15)="MD"
Begin DoDot:2
+78 SET $PIECE(ABMR(ABMS,ABMLN),U,12)=ABMLOCAL
End DoDot:2
+79 KILL ABMLOCAL
End DoDot:1
+80 KILL ABMS(ABMS),ABMPTR,ABMCORDX
+81 QUIT
