ABMDE1X ; IHS/ASDST/DMJ - SCRN 1 - CLaim Iden Data Ck ;
;;2.6;IHS 3P BILLING SYSTEM;**10,11**;NOV 12, 2009;Build 133
;
;IHS/DSD/DMJ - 03/23/98 - Modified to clear an undef error.
;add $G around expression
;
; IHS/SD/SDR - 10/30/02 - V2.5 P2 - QXX-0402-130120
; Modified to make error codes 11 and 105 more specific when
; checking for data
;
; IHS/SD/SDR - v2.5 p11 - NPI
;
; *********************************************************************
;
K ABME
S ABME("CTR")=0
S (ABMV("X1"),ABMV("X2"),ABMV("X3"))=""
I '$D(ABMP("DERP OPT")) D
.I $P(^ABMDCLM(DUZ(2),ABMP("CDFN"),0),U,6)="" D
..S DIE="^ABMDCLM(DUZ(2),"
..S DA=ABMP("CDFN")
..S DR=".06////1"
..D ^DIE
.I $P(^ABMDCLM(DUZ(2),ABMP("CDFN"),0),"^",14)="" D
..S DIE="^ABMDCLM(DUZ(2),"
..S DA=ABMP("CDFN")
..S DR=".14////"_$G(ABMP("EXP"))
..D ^DIE
;
D ;EP
S ABMP("C0")=^ABMDCLM(DUZ(2),ABMP("CDFN"),0)
N I
F I=1:1:14 S ABM(I)=$P(ABMP("C0"),"^",I)
S ABMP("VTYP")=ABM(7)
S:ABMP("VTYP")]"" ABM(7)=$P($G(^ABMDVTYP(ABMP("VTYP"),0)),U)
S ABMP("LDFN")=ABM(3)
S ABM(71)=$P($G(^ABMDCLM(DUZ(2),ABMP("CDFN"),7)),U)
S ABM(72)=$P($G(^ABMDCLM(DUZ(2),ABMP("CDFN"),7)),U,2)
I $E(ABM(71),6,7)="00"!($E(ABM(72),6,7)="00") S ABME(242)="" ;abm*2.6*10 HEAT65628
S ABMP("VDT")=ABM(71)
I ABM(6)]"",$D(^DIC(40.7,ABM(6),0)) S ABM(6)=$P(^(0),U,1)
E S ABME(106)=""
S ABM("PN")=$P(^DPT(ABMP("PDFN"),0),U)
S ABMP("DOB")=$P(^DPT(ABMP("PDFN"),0),U,3)
I $G(^DPT(ABMP("PDFN"),.35)) S ABMP("DOD")=$P(^DPT(ABMP("PDFN"),.35),U)
;
EMODE ;
S ABMNPIUS=$$NPIUSAGE^ABMUTLF(ABMP("LDFN"),ABMP("INS"))
I ABMP("EXP")<21,(ABMNPIUS="B"!(ABMNPIUS="N")) S ABME(222)=""
DOB ;
S X2=ABMP("DOB")
S X1=DT
D ^%DTC
K DIC
;I (X\365)>100,'$D(^ABMDCLM(DUZ(2),ABMP("CDFN"),53,38,0)) D
;.S (DINUM,X)=38
;.S DA(1)=ABMP("CDFN")
;.S DIC="^ABMDCLM(DUZ(2),"_ABMP("CDFN")_",53,"
;.S DIC(0)="LE"
;.S DIC("P")=$P(^DD(9002274.3,53,0),U,2)
;.K DD,DO
;.D FILE^DICN
I ABM(71)]"" S ABM(71)=$$SDT^ABMDUTL(ABM(71))
I ABM(72)]"" S ABM(72)=$$SDT^ABMDUTL(ABM(72))
E S ABME(107)=""
S ABMP("VISTDT")=ABM(71)
D PAT
D REMPL^ABMDE1X1
D LOC^ABMDE1X1
G XIT
;
; X2=PDFN;NAME (HRN)^SEX^ADDR 1^ADDR 2^PHONE^DOB^MARTIAL STATUS
;
PAT ;EP - Entry Point for setting X2 array for Registered Patient
I '$D(^DPT(ABMP("PDFN"),0)) S ABME(10)="" Q
;
HRN ;
S ABMV("X2")=ABMP("PDFN")_";"_$P(^DPT(ABMP("PDFN"),0),U,1)
I ABMP("LDFN")]"" S ABMV("X2")=ABMV("X2")_$S($D(^AUPNPAT(ABMP("PDFN"),41,ABMP("LDFN"),0)):" ("_$P(^(0),U,2)_")",1:" (no HRN)")
S $P(ABMV("X2"),U,2)=$P(^DPT(ABMP("PDFN"),0),U,2)
S $P(ABMV("X2"),U,6)=$$HDT^ABMDUTL($P(^DPT(ABMP("PDFN"),0),U,3))
S $P(ABMV("X2"),U,7)=$S($P($G(^AUPNPAT(ABMP("PDFN"),2)),U,2):"M;MARRIED",1:"U;UNKNOWN")
;I $P(ABMV("X2"),U,2)="" S ABME(13)="" ;abm*2.6*11 MU2 gender
I $P(ABMV("X2"),U,2)=""!($P(ABMV("X2"),U,2)="U") S ABME(13)="" ;abm*2.6*11 MU2 gender
I $P(ABMV("X2"),U,6)="" S ABME(12)=""
I ABMP("VDT")]"" D
.I $G(^DPT(ABMP("PDFN"),.35)) D
..I ABMP("VDT")>$P(^DPT(ABMP("PDFN"),.35),U) D
...S ABME(102)=""
I '+$D(^DPT(ABMP("PDFN"),.11)) S ABME(11)="" Q
I +$D(^DPT(ABMP("PDFN"),.11)) D
.I '($P(^DPT(ABMP("PDFN"),.11),U)]"") S ABME(11)="" Q
.I '($P(^DPT(ABMP("PDFN"),.11),U,4)]"") S ABME(11)="" Q
.I '($P(^DPT(ABMP("PDFN"),.11),U,5)]"") S ABME(11)="" Q
.I '($P(^DPT(ABMP("PDFN"),.11),U,6)]"") S ABME(11)="" Q
.S $P(ABMV("X2"),U,3)=$P(^DPT(ABMP("PDFN"),.11),U)
.S $P(ABMV("X2"),U,4)=$P(^DPT(ABMP("PDFN"),.11),U,4)_", "
Q:$D(ABME(11))
I $P(^DPT(ABMP("PDFN"),.11),U,5)]"" D
. I $D(^DIC(5,$P(^DPT(ABMP("PDFN"),.11),U,5),0)) D Q
..S $P(ABMV("X2"),U,4)=$P(ABMV("X2"),U,4)_$P(^DIC(5,$P(^DPT(ABMP("PDFN"),.11),U,5),0),U,2)_" "_$P(^DPT(ABMP("PDFN"),.11),U,6)
..S:$D(^DPT(ABMP("PDFN"),.13)) $P(ABMV("X2"),U,5)=$P(^DPT(ABMP("PDFN"),.13),U)
.S ABME(11)=""
Q
;
; *********************************************************************
XIT ;
K ABMX
Q
;
; *********************************************************************
ERR ;
D ABMDE1X
S ABME("TITL")="PAGE 1 - CLAIM IDENTIFIERS"
K ABMV,ABMX,ABM
Q
ABMDE1X ; IHS/ASDST/DMJ - SCRN 1 - CLaim Iden Data Ck ;
+1 ;;2.6;IHS 3P BILLING SYSTEM;**10,11**;NOV 12, 2009;Build 133
+2 ;
+3 ;IHS/DSD/DMJ - 03/23/98 - Modified to clear an undef error.
+4 ;add $G around expression
+5 ;
+6 ; IHS/SD/SDR - 10/30/02 - V2.5 P2 - QXX-0402-130120
+7 ; Modified to make error codes 11 and 105 more specific when
+8 ; checking for data
+9 ;
+10 ; IHS/SD/SDR - v2.5 p11 - NPI
+11 ;
+12 ; *********************************************************************
+13 ;
+14 KILL ABME
+15 SET ABME("CTR")=0
+16 SET (ABMV("X1"),ABMV("X2"),ABMV("X3"))=""
+17 IF '$DATA(ABMP("DERP OPT"))
Begin DoDot:1
+18 IF $PIECE(^ABMDCLM(DUZ(2),ABMP("CDFN"),0),U,6)=""
Begin DoDot:2
+19 SET DIE="^ABMDCLM(DUZ(2),"
+20 SET DA=ABMP("CDFN")
+21 SET DR=".06////1"
+22 DO ^DIE
End DoDot:2
+23 IF $PIECE(^ABMDCLM(DUZ(2),ABMP("CDFN"),0),"^",14)=""
Begin DoDot:2
+24 SET DIE="^ABMDCLM(DUZ(2),"
+25 SET DA=ABMP("CDFN")
+26 SET DR=".14////"_$GET(ABMP("EXP"))
+27 DO ^DIE
End DoDot:2
End DoDot:1
+28 ;
D ;EP
+1 SET ABMP("C0")=^ABMDCLM(DUZ(2),ABMP("CDFN"),0)
+2 NEW I
+3 FOR I=1:1:14
SET ABM(I)=$PIECE(ABMP("C0"),"^",I)
+4 SET ABMP("VTYP")=ABM(7)
+5 IF ABMP("VTYP")]""
SET ABM(7)=$PIECE($GET(^ABMDVTYP(ABMP("VTYP"),0)),U)
+6 SET ABMP("LDFN")=ABM(3)
+7 SET ABM(71)=$PIECE($GET(^ABMDCLM(DUZ(2),ABMP("CDFN"),7)),U)
+8 SET ABM(72)=$PIECE($GET(^ABMDCLM(DUZ(2),ABMP("CDFN"),7)),U,2)
+9 ;abm*2.6*10 HEAT65628
IF $EXTRACT(ABM(71),6,7)="00"!($EXTRACT(ABM(72),6,7)="00")
SET ABME(242)=""
+10 SET ABMP("VDT")=ABM(71)
+11 IF ABM(6)]""
IF $DATA(^DIC(40.7,ABM(6),0))
SET ABM(6)=$PIECE(^(0),U,1)
+12 IF '$TEST
SET ABME(106)=""
+13 SET ABM("PN")=$PIECE(^DPT(ABMP("PDFN"),0),U)
+14 SET ABMP("DOB")=$PIECE(^DPT(ABMP("PDFN"),0),U,3)
+15 IF $GET(^DPT(ABMP("PDFN"),.35))
SET ABMP("DOD")=$PIECE(^DPT(ABMP("PDFN"),.35),U)
+16 ;
EMODE ;
+1 SET ABMNPIUS=$$NPIUSAGE^ABMUTLF(ABMP("LDFN"),ABMP("INS"))
+2 IF ABMP("EXP")<21
IF (ABMNPIUS="B"!(ABMNPIUS="N"))
SET ABME(222)=""
DOB ;
+1 SET X2=ABMP("DOB")
+2 SET X1=DT
+3 DO ^%DTC
+4 KILL DIC
+5 ;I (X\365)>100,'$D(^ABMDCLM(DUZ(2),ABMP("CDFN"),53,38,0)) D
+6 ;.S (DINUM,X)=38
+7 ;.S DA(1)=ABMP("CDFN")
+8 ;.S DIC="^ABMDCLM(DUZ(2),"_ABMP("CDFN")_",53,"
+9 ;.S DIC(0)="LE"
+10 ;.S DIC("P")=$P(^DD(9002274.3,53,0),U,2)
+11 ;.K DD,DO
+12 ;.D FILE^DICN
+13 IF ABM(71)]""
SET ABM(71)=$$SDT^ABMDUTL(ABM(71))
+14 IF ABM(72)]""
SET ABM(72)=$$SDT^ABMDUTL(ABM(72))
+15 IF '$TEST
SET ABME(107)=""
+16 SET ABMP("VISTDT")=ABM(71)
+17 DO PAT
+18 DO REMPL^ABMDE1X1
+19 DO LOC^ABMDE1X1
+20 GOTO XIT
+21 ;
+22 ; X2=PDFN;NAME (HRN)^SEX^ADDR 1^ADDR 2^PHONE^DOB^MARTIAL STATUS
+23 ;
PAT ;EP - Entry Point for setting X2 array for Registered Patient
+1 IF '$DATA(^DPT(ABMP("PDFN"),0))
SET ABME(10)=""
QUIT
+2 ;
HRN ;
+1 SET ABMV("X2")=ABMP("PDFN")_";"_$PIECE(^DPT(ABMP("PDFN"),0),U,1)
+2 IF ABMP("LDFN")]""
SET ABMV("X2")=ABMV("X2")_$SELECT($DATA(^AUPNPAT(ABMP("PDFN"),41,ABMP("LDFN"),0)):" ("_$PIECE(^(0),U,2)_")",1:" (no HRN)")
+3 SET $PIECE(ABMV("X2"),U,2)=$PIECE(^DPT(ABMP("PDFN"),0),U,2)
+4 SET $PIECE(ABMV("X2"),U,6)=$$HDT^ABMDUTL($PIECE(^DPT(ABMP("PDFN"),0),U,3))
+5 SET $PIECE(ABMV("X2"),U,7)=$SELECT($PIECE($GET(^AUPNPAT(ABMP("PDFN"),2)),U,2):"M;MARRIED",1:"U;UNKNOWN")
+6 ;I $P(ABMV("X2"),U,2)="" S ABME(13)="" ;abm*2.6*11 MU2 gender
+7 ;abm*2.6*11 MU2 gender
IF $PIECE(ABMV("X2"),U,2)=""!($PIECE(ABMV("X2"),U,2)="U")
SET ABME(13)=""
+8 IF $PIECE(ABMV("X2"),U,6)=""
SET ABME(12)=""
+9 IF ABMP("VDT")]""
Begin DoDot:1
+10 IF $GET(^DPT(ABMP("PDFN"),.35))
Begin DoDot:2
+11 IF ABMP("VDT")>$PIECE(^DPT(ABMP("PDFN"),.35),U)
Begin DoDot:3
+12 SET ABME(102)=""
End DoDot:3
End DoDot:2
End DoDot:1
+13 IF '+$DATA(^DPT(ABMP("PDFN"),.11))
SET ABME(11)=""
QUIT
+14 IF +$DATA(^DPT(ABMP("PDFN"),.11))
Begin DoDot:1
+15 IF '($PIECE(^DPT(ABMP("PDFN"),.11),U)]"")
SET ABME(11)=""
QUIT
+16 IF '($PIECE(^DPT(ABMP("PDFN"),.11),U,4)]"")
SET ABME(11)=""
QUIT
+17 IF '($PIECE(^DPT(ABMP("PDFN"),.11),U,5)]"")
SET ABME(11)=""
QUIT
+18 IF '($PIECE(^DPT(ABMP("PDFN"),.11),U,6)]"")
SET ABME(11)=""
QUIT
+19 SET $PIECE(ABMV("X2"),U,3)=$PIECE(^DPT(ABMP("PDFN"),.11),U)
+20 SET $PIECE(ABMV("X2"),U,4)=$PIECE(^DPT(ABMP("PDFN"),.11),U,4)_", "
End DoDot:1
+21 IF $DATA(ABME(11))
QUIT
+22 IF $PIECE(^DPT(ABMP("PDFN"),.11),U,5)]""
Begin DoDot:1
+23 IF $DATA(^DIC(5,$PIECE(^DPT(ABMP("PDFN"),.11),U,5),0))
Begin DoDot:2
+24 SET $PIECE(ABMV("X2"),U,4)=$PIECE(ABMV("X2"),U,4)_$PIECE(^DIC(5,$PIECE(^DPT(ABMP("PDFN"),.11),U,5),0),U,2)_" "_$PIECE(^DPT(ABMP("PDFN"),.11),U,6)
+25 IF $DATA(^DPT(ABMP("PDFN"),.13))
SET $PIECE(ABMV("X2"),U,5)=$PIECE(^DPT(ABMP("PDFN"),.13),U)
End DoDot:2
QUIT
+26 SET ABME(11)=""
End DoDot:1
+27 QUIT
+28 ;
+29 ; *********************************************************************
XIT ;
+1 KILL ABMX
+2 QUIT
+3 ;
+4 ; *********************************************************************
ERR ;
+1 DO ABMDE1X
+2 SET ABME("TITL")="PAGE 1 - CLAIM IDENTIFIERS"
+3 KILL ABMV,ABMX,ABM
+4 QUIT
