ABMDF27E ; IHS/ASDST/DMJ - Set HCFA1500 Print Array - Part 5 ;
;;2.6;IHS 3P BILLING SYSTEM;**3,4,8,9,11,21**;NOV 12, 2009;Build 379
;
;IHS/SD/SDR - v2.5 p12 - IM25331 - Put taxonomy code if NPI ONLY
;IHS/SD/SDR - v2.5 p12 - IM25352 - Included fix supplied by Walt Reich (PIMC)
; Put space between anes. data for readability
;IHS/SD/SDR - v2.5 p13 - IM25899 - Alignment changes
;IHS/SD/SDR,AML - v2.5 p13 - NO IM - Change for satellite prov# in 24k
;IHS/SD/SDR,AML - abm*2.6*3 - NOHEAT - Correction to box 24K when NPI or not
;IHS/SD/SDR - abm*2.6*4 - HEAT12115 - Allow 5+ DX codes
;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
;
; *********************************************************************
;
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 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"),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,4)="X" ; Form locator 24C
E D ;abm*2.6*11 HEAT30524
.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
S:$P(ABMR(ABMS,ABMLN),U,5)["NO CODE SELECTED" $P(ABMR(ABMS,ABMLN),U,5)="" ;abm*2.6*11 HEAT91425
;E D ;abm*2.6*7 HEAT30524
;start old code abm*2.6*8
;I $P($G(^ABMNINS(DUZ(2),ABMP("INS"),1,ABMP("VTYP"),0)),U,16)]"" D ;abm*2.6*7 HEAT30524
;.I $L($P(ABMS(ABMS),U,8))>16 D Q
;..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
;.S $P(ABMR(ABMS,ABMLN),U,5)=$P(ABMS(ABMS),U,8)
;end old code start new code
;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
I ($E($P(ABMS(ABMS),U,8),1,2)="N4") D ;abm*2.6*21 IHS/SD/SDR HEAT168435
.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)
;end new code abm*2.6*8
S ABMCORDX=$P(ABMS(ABMS),U,5)
;I +ABMCORDX>4,$G(ABMP("BDFN")) D ;abm*2.6*4 HEAT12115
I +ABMCORDX>8,$G(ABMP("BDFN")) D ;abm*2.6*4 HEAT12115
.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)=$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
;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
;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
;start new code abm*2.6*8 HEAT31586
I $G(ABMP("EXP"))=27 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)
;end new code HEAT31586
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
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
+2 ;
+3 ;IHS/SD/SDR - v2.5 p12 - IM25331 - Put taxonomy code if NPI ONLY
+4 ;IHS/SD/SDR - v2.5 p12 - IM25352 - Included fix supplied by Walt Reich (PIMC)
+5 ; Put space between anes. data for readability
+6 ;IHS/SD/SDR - v2.5 p13 - IM25899 - Alignment changes
+7 ;IHS/SD/SDR,AML - v2.5 p13 - NO IM - Change for satellite prov# in 24k
+8 ;IHS/SD/SDR,AML - abm*2.6*3 - NOHEAT - Correction to box 24K when NPI or not
+9 ;IHS/SD/SDR - abm*2.6*4 - HEAT12115 - Allow 5+ DX codes
+10 ;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
+11 ;
+12 ; *********************************************************************
+13 ;
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 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 IF $PIECE($GET(^ABMNINS(DUZ(2),ABMP("INS"),1,ABMP("VTYP"),0)),U,16)]""
Begin DoDot:1
+43 ;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
+44 IF '$TEST
IF $PIECE($GET(ABMS(ABMS)),U,4)]""
Begin DoDot:1
+45 SET $PIECE(ABMR(ABMS,ABMLN),U,5)=" "_$PIECE(ABMS(ABMS),U,4)
+46 ; If CPT code, and modifier exists, add it
+47 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:"")
+48 ; Form locator 24H
IF $GET(ABM("EPSDT"))
SET $PIECE(ABMR(ABMS,ABMLN),U,9)="X"
+49 ; Form locator 24C
IF $GET(ABM("EMG"))
SET $PIECE(ABMR(ABMS,ABMLN),U,4)="X"
End DoDot:1
IF 1
+50 ;abm*2.6*11 HEAT30524
IF '$TEST
Begin DoDot:1
+51 ;abm*2.6*11 HEAT30524
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
+52 ;abm*2.6*11 HEAT91425
IF $PIECE(ABMR(ABMS,ABMLN),U,5)["NO CODE SELECTED"
SET $PIECE(ABMR(ABMS,ABMLN),U,5)=""
+53 ;E D ;abm*2.6*7 HEAT30524
+54 ;start old code abm*2.6*8
+55 ;I $P($G(^ABMNINS(DUZ(2),ABMP("INS"),1,ABMP("VTYP"),0)),U,16)]"" D ;abm*2.6*7 HEAT30524
+56 ;.I $L($P(ABMS(ABMS),U,8))>16 D Q
+57 ;..S ABMU("LNG")=60
+58 ;..S ABMU("TXT")=$P(ABMS(ABMS),U,8)
+59 ;..S ABMU=3
+60 ;..D LNG^ABMDWRAP
+61 ;..S ABMLND=ABMLN-1,J=0
+62 ;..F S J=$O(ABMU(J)) Q:+J=0!(+J>2) D
+63 ;...S $P(ABMR(ABMS,ABMLND),U)=$G(ABMU(J))
+64 ;...S ABMLND=ABMLND+1
+65 ;.K ABMU
+66 ;.S $P(ABMR(ABMS,ABMLN),U,5)=$P(ABMS(ABMS),U,8)
+67 ;end old code start new code
+68 ;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
+69 ;abm*2.6*21 IHS/SD/SDR HEAT168435
IF ($EXTRACT($PIECE(ABMS(ABMS),U,8),1,2)="N4")
Begin DoDot:1
+70 SET ABMU("LNG")=60
+71 SET ABMU("TXT")=$PIECE(ABMS(ABMS),U,8)
+72 SET ABMU=3
+73 DO LNG^ABMDWRAP
+74 SET ABMLND=ABMLN-1
SET J=0
+75 FOR
SET J=$ORDER(ABMU(J))
IF +J=0!(+J>2)
QUIT
Begin DoDot:2
+76 SET $PIECE(ABMR(ABMS,ABMLND),U)=$GET(ABMU(J))
+77 SET ABMLND=ABMLND+1
End DoDot:2
+78 KILL ABMU
End DoDot:1
+79 IF '$TEST
IF ($EXTRACT($PIECE(ABMS(ABMS),U,8),1,2)="N4")
SET $PIECE(ABMR(ABMS,ABMLN),U,5)=$PIECE(ABMS(ABMS),U,8)
+80 ;end new code abm*2.6*8
+81 SET ABMCORDX=$PIECE(ABMS(ABMS),U,5)
+82 ;I +ABMCORDX>4,$G(ABMP("BDFN")) D ;abm*2.6*4 HEAT12115
+83 ;abm*2.6*4 HEAT12115
IF +ABMCORDX>8
IF $GET(ABMP("BDFN"))
Begin DoDot:1
+84 SET ABMCORDX=$PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),17,ABMCORDX,0)),"^",2)
End DoDot:1
+85 IF $DATA(ABMP("FLAT"))
IF $GET(ABMP("BDFN"))
Begin DoDot:1
+86 NEW ABMDXCNT,ABMTMP
+87 SET ABMDXCNT=$PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),17,0)),U,4)
+88 IF +ABMDXCNT>4
SET ABMDXCNT=4
+89 FOR ABMTMP=1:1:ABMDXCNT
SET $PIECE(ABMCORDX,",",ABMTMP)=ABMTMP
End DoDot:1
+90 ; Diagnosis code Form locator 24E
+91 SET $PIECE(ABMR(ABMS,ABMLN),U,6)=$TRANSLATE(ABMCORDX,",")
+92 ; Charges Form locator 24F
+93 SET $PIECE(ABMR(ABMS,ABMLN),U,7)=$PIECE(ABMS(ABMS),U)
+94 ; Days or units Form locator 24G
+95 SET $PIECE(ABMR(ABMS,ABMLN),U,8)=$PIECE(ABMS(ABMS),U,6)
+96 ; Reserved for local use Form locator 24K (1)
+97 IF $PIECE(ABMS(ABMS),"^",9)'=""
Begin DoDot:1
+98 SET ABMLOCAL=$PIECE(ABMS(ABMS),"^",9)
+99 IF $PIECE($GET(^ABMNINS(DUZ(2),ABMP("INS"),1,ABMP("VTYP"),0)),"^",15)="MD"
Begin DoDot:2
+100 SET $PIECE(ABMR(ABMS,ABMLN-1),U,3)=ABMLOCAL
End DoDot:2
+101 KILL ABMLOCAL
End DoDot:1
+102 ;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
+103 ;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
+104 ;start new code abm*2.6*8 HEAT31586
+105 IF $GET(ABMP("EXP"))=27
Begin DoDot:1
+106 IF +$GET(ABMDUZ2)=0
SET ABMDUZ2=DUZ(2)
+107 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
+108 IF ($PIECE(ABMS(ABMS),U,11)&($GET(ABMP("NPIS"))'="")&(ABMP("NPIS")'="N"))
Begin DoDot:1
+109 SET $PIECE(ABMR(ABMS,ABMLN-1),U,2)=ABMPQ
+110 SET $PIECE(ABMR(ABMS,ABMLN-1),U,3)=$PIECE(ABMS(ABMS),U,9)
End DoDot:1
+111 ;end new code HEAT31586
+112 IF $GET(ABMP("ITYPE"))="R"&($GET(ABMP("BTYP"))="831")
SET $PIECE(ABMR(ABMS,ABMLN-1),U,3)=""
+113 ;Form Locator 24K (2)
IF $PIECE(ABMS(ABMS),U,11)
SET $PIECE(ABMR(ABMS,ABMLN),U,11)=$PIECE(ABMS(ABMS),U,11)
+114 KILL ABMS(ABMS),ABMPTR,ABMCORDX
+115 QUIT
