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

ABME8TOO.m

Go to the documentation of this file.
  1. ABME8TOO ; IHS/ASDST/DMJ - 837 TOO Segment
  1. ;;2.6;IHS 3P BILLING SYSTEM;;NOV 12, 2009
  1. ;Tooth Identification
  1. ;
  1. ; IHS/SD/SDR - v2.5 p10 - IM20395
  1. ; Split out lines bundled by rev code
  1. ;
  1. ;EP - START HERE
  1. K ABMREC("TOO"),ABMR("TOO")
  1. S ABME("RTYPE")="TOO"
  1. D LOOP
  1. K ABME,ABM
  1. Q
  1. LOOP ;LOOP HERE
  1. F I=10:10:40 D
  1. .D @I
  1. .I $D(^ABMEXLM("AA",+$G(ABMP("INS")),+$G(ABMP("EXP")),ABME("RTYPE"),I)) D @(^(I))
  1. .I $G(ABMREC("TOO"))'="" S ABMREC("TOO")=ABMREC("TOO")_"*"
  1. .S ABMREC("TOO")=$G(ABMREC("TOO"))_ABMR("TOO",I)
  1. Q
  1. 10 ;segment
  1. S ABMR("TOO",10)="TOO"
  1. Q
  1. 20 ;TOO01 - Code List Qualifier Code
  1. S ABMR("TOO",20)="JP"
  1. Q
  1. 30 ;TOO02 - Tooth Number
  1. N I
  1. S I=$P(ABMRV(ABMI,ABMJ,ABMK),U,23)
  1. S ABMR("TOO",30)=$G(^ADEOPS(+I,88))
  1. Q
  1. 40 ;TOO03 - Tooth Surface
  1. N I,J
  1. S I=$P(ABMRV(ABMI,ABMJ,ABMK),U,24)
  1. I I="" S ABMR("TOO",40)="" Q
  1. F J=1:1:$L(I) D
  1. .S $P(ABMR("TOO",40),":",J)=$E(I,J)
  1. Q