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

ABMER70.m

Go to the documentation of this file. 
  1. ABMER70 ; IHS/ASDST/DMJ - UB92 EMC RECORD 70-1 (Medical) ;    
  1.  ;;2.6;IHS 3P BILLING SYSTEM;**3,17**;NOV 12, 2009;Build 272
  1.  ;Original;DMJ;08/18/95 10:07 AM
  1.  ;
  1.  ; IHS/ASDS/DMJ - 11/17/00 - V2.4 Patch 3 - NOIS NDA-0500-180002
  1.  ;     Modified code to allow printing of E-codes if exist.
  1.  ;
  1.  ; IHS/SD/SDR - v2.5 p10 - IM20338 - Fix check for ICDs
  1.  ; IHS/SD/SDR - v2.5 p13 - POA changes
  1.  ;
  1.  ; IHS/SD/SDR - v2.6 CSV
  1.  ; IHS/SD/SDR - abm*2.6*3 - HEAT11931 - fix for INVALI displaying in box 72
  1.  ;IHS/SD/SDR - 2.6*17 - HEAT238640 - Updated all DX fields to hold 7 characters instead of 6.
  1.  ;
  1. START ;START HERE
  1.  K ABMR(70),ABMREC(70)
  1.  S ABME("RTYPE")=70
  1.  D SET^ABMERUTL,LOOP
  1.  D S90^ABMERUTL
  1.  K ABM,ABME
  1.  Q
  1.  ;
  1. LOOP ;LOOP HERE
  1.  D ^ABMER70A
  1.  F I=130:10:300 D
  1.  .D @I
  1.  .I $D(^ABMEXLM("AA",+$G(ABMP("INS")),+$G(ABMP("EXP")),70,I)) D @(^(I))
  1.  .I '$G(ABMP("NOFMT")) S ABMREC(70)=$G(ABMREC(70))_ABMR(70,I)
  1.  Q
  1.  ;
  1. 130 ;Principle Surgical Procedure Code (SOURCE: FILE=9002274.4 FIELD=)
  1.  ; form locator #80
  1.  D SCODE
  1.  S ABMR(70,130)=$P(ABM("SC",1),U)
  1.  S ABMR(70,130)=$$FMT^ABMERUTL(ABMR(70,130),7)
  1.  Q
  1.  ;
  1. 140 ;Principle Surgical Procedure Date (SOURCE: FILE=9002274.4 FIELD=)
  1.  ; form locator #80
  1.  D SCODE
  1.  S Y=$P(ABM("SC",1),"^",2) D DFMT^ABMERUTL S ABMR(70,140)=Y
  1.  S ABMR(70,140)=$$FMT^ABMERUTL(ABMR(70,140),6)
  1.  Q
  1.  ;
  1. 150 ;Other Surgical Procedure Code #1 (SOURCE: FILE=9002274.4)
  1.  ; form locator #81
  1.  D SCODE
  1.  S ABMR(70,150)=$P(ABM("SC",2),U)
  1.  S ABMR(70,150)=$$FMT^ABMERUTL(ABMR(70,150),7)
  1.  Q
  1.  ;
  1. 160 ;Other Surgical Procedure Date #1 (SOURCE: FILE=9002274.4)
  1.  ; form locator #81
  1.  D SCODE
  1.  S Y=$P(ABM("SC",2),"^",2)
  1.  D DFMT^ABMERUTL
  1.  S ABMR(70,160)=Y
  1.  S ABMR(70,160)=$$FMT^ABMERUTL(ABMR(70,160),6)
  1.  Q
  1.  ;
  1. 170 ;Other Surgical Procedure Code #2 (SOURCE: FILE=9002274.4)
  1.  ; form locator #81
  1.  D SCODE
  1.  S ABMR(70,170)=$P(ABM("SC",3),U)
  1.  S ABMR(70,170)=$$FMT^ABMERUTL(ABMR(70,170),7)
  1.  Q
  1. 180 ;Other Surgical Procedure Date #2 (SOURCE: FILE=9002274.4)
  1.  ; form locator #81
  1.  D SCODE
  1.  S Y=$P(ABM("SC",3),"^",2)
  1.  D DFMT^ABMERUTL
  1.  S ABMR(70,180)=Y
  1.  S ABMR(70,180)=$$FMT^ABMERUTL(ABMR(70,180),6)
  1.  Q
  1.  ;
  1. 190 ;Other Surgical Procedure Code #3 (SOURCE: FILE=9002274.4)
  1.  ; form locator #81
  1.  D SCODE
  1.  S ABMR(70,190)=$P(ABM("SC",4),U)
  1.  S ABMR(70,190)=$$FMT^ABMERUTL(ABMR(70,190),7)
  1.  Q
  1.  ;
  1. 200 ;Other Surgical Procedure Date #3 (SOURCE: FILE=9002274.4)
  1.  ; form locator #81
  1.  D SCODE
  1.  S Y=$P(ABM("SC",4),"^",2)
  1.  D DFMT^ABMERUTL
  1.  S ABMR(70,200)=Y
  1.  S ABMR(70,200)=$$FMT^ABMERUTL(ABMR(70,200),6)
  1.  Q
  1.  ;
  1. 210 ;Other Surgical Procedure Code #4 (SOURCE: FILE=9002274.4)
  1.  ; form locator #81
  1.  D SCODE
  1.  S ABMR(70,210)=$P(ABM("SC",5),U)
  1.  S ABMR(70,210)=$$FMT^ABMERUTL(ABMR(70,210),7)
  1.  Q
  1.  ;
  1. 220 ;Other Surgical Procedure Date #4 (SOURCE: FILE=9002274.4)
  1.  ; form locator #81
  1.  D SCODE
  1.  S Y=$P(ABM("SC",5),"^",2)
  1.  D DFMT^ABMERUTL
  1.  S ABMR(70,220)=Y
  1.  S ABMR(70,220)=$$FMT^ABMERUTL(ABMR(70,220),6)
  1.  Q
  1.  ;
  1. 230 ;Other Surgical Procedure Code #5 (SOURCE: FILE=9002274.4)
  1.  ; form locator #81
  1.  D SCODE
  1.  S ABMR(70,230)=$P(ABM("SC",6),U)
  1.  S ABMR(70,230)=$$FMT^ABMERUTL(ABMR(70,230),7)
  1.  Q
  1.  ;
  1. 240 ;Other Surgical Procedure Date #5 (SOURCE: FILE=9002274.4)
  1.  ; form locator #81
  1.  D SCODE
  1.  S Y=$P(ABM("SC",6),"^",2)
  1.  D DFMT^ABMERUTL
  1.  S ABMR(70,240)=Y
  1.  S ABMR(70,240)=$$FMT^ABMERUTL(ABMR(70,240),6)
  1.  Q
  1.  ;
  1. 250 ;Admitting Diagnosis (SOURCE: FILE=9002274.4, FIELD=.59)
  1.  ; form locator #76
  1.  D:'$D(ABM(9002274.4,ABMP("BDFN"),.59)) DIQ1
  1.  S ABMR(70,250)=ABM(9002274.4,ABMP("BDFN"),.59,"E")
  1.  S ABMR(70,250)=$TR(ABMR(70,250),".")
  1.  ;S ABMR(70,250)=$$FMT^ABMERUTL(ABMR(70,250),6)  ;abm*2.6*17 IHS/SD/SDR HEAT238640
  1.  S ABMR(70,250)=$$FMT^ABMERUTL(ABMR(70,250),7)  ;abm*2.6*17 IHS/SD/SDR HEAT238640
  1.  Q
  1.  ;
  1. 260 ;External Cause of Injury (SOURCE: FILE=9002274.4, FIELD=)
  1.  ; form locator #77
  1.  S ABMR(70,260)=$P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),8)),"^",12)
  1.  ;S ABMR(70,260)=$P($$DX^ABMCVAPI(+ABMR(70,260),ABMP("VDT")),U,2)  ;CSV-c  ;abm*2.6*3 HEAT11931
  1.  S:(+ABMR(70,260)) ABMR(70,260)=$P($$DX^ABMCVAPI(+ABMR(70,260),ABMP("VDT")),U,2)  ;CSV-c  ;abm*2.6*3 HEAT11931
  1.  S ABMR(70,260,"POA")=$$POA(ABMR(70,260))
  1.  S ABMR(70,260)=$TR($G(ABMR(70,260)),".")
  1.  ;S ABMR(70,260)=$$FMT^ABMERUTL(ABMR(70,260),6)  ;abm*2.6*17 IHS/SD/SDR HEAT238640
  1.  S ABMR(70,260)=$$FMT^ABMERUTL(ABMR(70,260),7)  ;abm*2.6*17 IHS/SD/SDR HEAT238640
  1.  Q
  1.  ;
  1. 270 ;Procedure Coding Method Used (SOURCE: FILE=9999999.18, FIELD=)
  1.  ; form locator #79
  1.  I +$O(^ABMDBILL(DUZ(2),ABMP("BDFN"),19,0))'=0 S ABMR(70,270)=9
  1.  E  S ABMR(70,270)=$S($P($G(^ABMNINS(DUZ(2),+ABMP("INS"),1,+ABMP("VTYP"),0)),U,2)="I":9,1:4)
  1.  S ABMR(70,270)=$$FMT^ABMERUTL(ABMR(70,270),"1N")
  1.  Q
  1.  ;
  1. 280 ;Filler
  1.  S ABMR(70,280)=""
  1.  S ABMR(70,280)=$$FMT^ABMERUTL(ABMR(70,280),23)
  1.  Q
  1. 290 ;External Cause of Injury (2) (SOURCE: FILE=9002274.4, FIELD=)
  1.  ; form locator #77
  1.  S ABMR(70,290)=$P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),8)),U,19)
  1.  ;S ABMR(70,290)=$P($$DX^ABMCVAPI(+ABMR(70,290),ABMP("VDT")),U,2)  ;CSV-c  ;abm*2.6*3 HEAT11931
  1.  S:(+ABMR(70,290)) ABMR(70,290)=$P($$DX^ABMCVAPI(+ABMR(70,290),ABMP("VDT")),U,2)  ;CSV-c  ;abm*2.6*3 HEAT11931
  1.  S ABMR(70,290,"POA")=$$POA(ABMR(70,290))
  1.  S ABMR(70,290)=$TR($G(ABMR(70,290)),".")
  1.  ;S ABMR(70,290)=$$FMT^ABMERUTL(ABMR(70,290),6)  ;abm*2.6*17 IHS/SD/SDR HEAT238640
  1.  S ABMR(70,290)=$$FMT^ABMERUTL(ABMR(70,290),7)  ;abm*2.6*17 IHS/SD/SDR HEAT238640
  1.  Q
  1. 300 ;External Cause of Injury (3) (SOURCE: FILE=9002274.4, FIELD=)
  1.  ; form locator #77
  1.  S ABMR(70,300)=$P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),8)),U,20)
  1.  ;S ABMR(70,300)=$P($$DX^ABMCVAPI(+ABMR(70,300),ABMP("VDT")),U,2)  ;CSV-c  ;abm*2.6*3 HEAT11931
  1.  S:(+ABMR(70,300)) ABMR(70,300)=$P($$DX^ABMCVAPI(+ABMR(70,300),ABMP("VDT")),U,2)  ;CSV-c  ;abm*2.6*3 HEAT11931
  1.  S ABMR(70,300,"POA")=$$POA(ABMR(70,300))
  1.  S ABMR(70,300)=$TR($G(ABMR(70,300)),".")
  1.  ;S ABMR(70,300)=$$FMT^ABMERUTL(ABMR(70,300),6)  ;abm*2.6*17 IHS/SD/SDR HEAT238640
  1.  S ABMR(70,300)=$$FMT^ABMERUTL(ABMR(70,300),7)  ;abm*2.6*17 IHS/SD/SDR HEAT238640
  1.  Q
  1.  ;
  1. SCODE ;SURGICAL PROCEDURE CODES
  1.  Q:$D(ABM("SC"))   ; Quit if already done
  1.  N I
  1.  S I=0,CNT=0
  1.  F  S I=$O(^ABMDBILL(DUZ(2),ABMP("BDFN"),19,"C",I)) Q:+I=0  D
  1.  .S J=0
  1.  .F  S J=$O(^ABMDBILL(DUZ(2),ABMP("BDFN"),19,"C",I,J)) Q:+J=0  D
  1.  ..S CNT=CNT+1
  1.  ..S ABM("ZERO")=$G(^ABMDBILL(DUZ(2),ABMP("BDFN"),19,J,0))
  1.  ..S ABM("SC",CNT)=$P($$ICDOP^ABMCVAPI(+ABM("ZERO"),ABMP("VDT")),U,2)_"^"_$P(ABM("ZERO"),U,3)  ;CSV-c
  1.  ..Q:$P($G(^ABMDEXP(ABMP("EXP"),1)),U,5)'="E"
  1.  ..S ABM("SC",CNT)=$TR(ABM("SC",CNT),".")
  1.  I $D(ABM("SC")) F I=1:1:6 S:'$D(ABM("SC",I)) ABM("SC",I)=""
  1.  Q:$D(ABM("SC"))
  1.  ; if procedure coding method used is ICD use node 19,
  1.  ;   else use node 21 (Med/Surg)
  1.  S ABM("SUB")=$S($P($G(^ABMNINS(DUZ(2),+ABMP("INS"),1,+ABMP("VTYP"),0)),"^",2)="I":19,1:21)
  1.  N I
  1.  S I=0,CNT=0
  1.  ; loop INS priority order
  1.  F  S I=$O(^ABMDBILL(DUZ(2),ABMP("BDFN"),ABM("SUB"),"C",I)) Q:'I  D
  1.  .N J
  1.  .S J=0
  1.  .; Loop IEN to multiple
  1.  .F  S J=$O(^ABMDBILL(DUZ(2),ABMP("BDFN"),ABM("SUB"),"C",I,J)) Q:'J  D
  1.  ..S CNT=CNT+1  ; increment counter
  1.  ..S ABM("ZERO")=^ABMDBILL(DUZ(2),ABMP("BDFN"),ABM("SUB"),J,0)
  1.  ..I ABM("SUB")=19 D   ; ICD procedure code ^ date of service
  1.  ...S ABM("SC",CNT)=$P($$ICDOP^ABMCVAPI(+ABM("ZERO"),ABMP("VDT")),U,2)_"^"_$P(ABM("ZERO"),U,3)  ;CSV-c
  1.  ...Q:$P($G(^ABMDEXP(ABMP("EXP"),1)),"^",5)'="E"
  1.  ...S ABM("SC",CNT)=$TR(ABM("SC",CNT),".")
  1.  ..; CPT code ^ date/time
  1.  ..I ABM("SUB")=21 S ABM("SC",CNT)=$P($$CPT^ABMCVAPI(+ABM("ZERO"),ABMP("VDT")),U,2)_"^"_$P(ABM("ZERO"),U,5)  ;CSV-c
  1.  F I=1:1:6 S:'$D(ABM("SC",I)) ABM("SC",I)=""
  1.  Q
  1.  ;
  1. DIQ1 ;GET INFO FROM FILE 9002274.4
  1.  N I
  1.  S DA=ABMP("BDFN")
  1.  S DR=".59;.857"
  1.  S DIQ="ABM"
  1.  S DIQ(0)="E"
  1.  S DIC="^ABMDBILL(DUZ(2),"
  1.  D EN^DIQ1
  1.  K DIQ
  1.  Q
  1.  ;
  1. EX(ABMX,ABMY) ;EXTRINSIC FUNCTION HERE
  1.  ;
  1.  ;  INPUT: ABMX = data element
  1.  ;            Y = bill internal entry number
  1.  ;
  1.  ; OUTPUT:    Y = bill internal entry number
  1.  ;         
  1.  I '$G(ABMP("NOFMT")) S ABMP("FMT")=0
  1.  D @ABMX
  1.  S Y=ABMR(70,ABMX)
  1.  I $D(ABMP("FMT")) S ABMP("FMT")=1
  1.  K ABMR(70,ABMX),ABMX,ABMY
  1.  Q Y
  1. POA(ABMDX) ;EP
  1.  N I
  1.  S I=0
  1.  S ABMRPOA=""
  1.  F  S I=$O(^ABMDBILL(DUZ(2),ABMP("BDFN"),17,I)) Q:'I  D
  1.  .I ABMDX=$P($G(^ICD9($P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),17,I,0)),U),0)),U) S ABMRPOA=$P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),17,I,0)),U,5)
  1.  Q ABMRPOA