ABMDF1E ; IHS/SD/SDR - Set UB82 Print Array - Part 5 ;
;;2.6;IHS 3P BILLING SYSTEM;**10,14**;NOV 12, 2009;Build 238
;Original;TMD;
;
;IHS/DSD/DMJ - 5/14/1999 - NOIS HQW-0599-100027 Patch 2
; Y2K IV&V issues, all $$HDT^ABMDUTL changed to $$HDTO^ABMDUTL
; in lines: 55+5,CPT55+4,MED+4
;
; IHS/SD/SDR - v2.6 CSV
;IHS/SD/SDR - 2.6*14 - Updated DX^ABMCVAPI call to be numeric
;
53 ; Diagnosis Info
S (ABMU("TXT"),ABMF(53),ABM)="" F ABM("I")=1:1:5 S ABM=$O(^ABMDBILL(DUZ(2),ABMP("BDFN"),17,"C",ABM)) Q:'ABM D
.S ABM("X")=$O(^ABMDBILL(DUZ(2),ABMP("BDFN"),17,"C",ABM,""))
.;S ABMF(53)=ABMF(53)_U_$P($$DX^ABMCVAPI(ABM("X"),ABMP("VDT")),U,2) ;CSV-c ;abm*2.6*14 update API call
.S ABMF(53)=ABMF(53)_U_$P($$DX^ABMCVAPI(+ABM("X"),ABMP("VDT")),U,2) ;CSV-c ;abm*2.6*14 update API call
.S ABM("PRVN")=$P(^ABMDBILL(DUZ(2),ABMP("BDFN"),17,ABM("X"),0),U,3)
.S ABM(9)=$P($G(^AUTNPOV(+ABM("PRVN"),0)),U)
.;I ABM(9)=$P($$DX^ABMCVAPI(ABM("X"),ABMP("VDT")),U,2) S ABM(9)=$P($$DX^ABMCVAPI(ABM("X"),ABMP("VDT")),U,4) ;CSV-c ;abm*2.6*14 update API call
.I ABM(9)=$P($$DX^ABMCVAPI(+ABM("X"),ABMP("VDT")),U,2) S ABM(9)=$P($$DX^ABMCVAPI(+ABM("X"),ABMP("VDT")),U,4) ;CSV-c ;abm*2.6*14 update API call
.S ABMU("TXT")=ABMU("TXT")_", "_$S(ABM(9)["*ICD*":$P(ABM(9)," "),1:ABM(9))
S ABMU("TXT")=$P(ABMU("TXT"),", ",2,99)
I $L(ABMU("TXT"))>45 S ABMU("LNG")=26,ABMU("TAB")=19,ABMU=2 D LNG^ABMDWRAP S $P(ABMF(52),U)=ABMU(1),$P(ABMF(53),U)=ABMU(2) K ABMU I 1
E S $P(ABMF(53),U)=ABMU("TXT")
G 55
;
55 ; ICD Procedure Info
S ABMU("TXT")=""
I ABMP("PX")="C" G CPT55
S ABMF(55)="",ABM="" F S ABM=$O(^ABMDBILL(DUZ(2),ABMP("BDFN"),19,"C",ABM)) Q:ABM="" S ABM("X0")=$O(^ABMDBILL(DUZ(2),ABMP("BDFN"),19,"C",ABM,"")) D
.S ABMF(55)=ABMF(55)_"^"_$P($$ICDOP^ABMCVAPI($P(ABM("X0"),U),ABMP("VDT")),U,2) ;CSV-c
.S ABMF(55)=ABMF(55)_"^"_$$HDTO^ABMDUTL($P(^ABMDBILL(DUZ(2),ABMP("BDFN"),19,ABM("X0"),0),U,3))
.S ABM(9)=$P(^AUTNPOV($P(^ABMDBILL(DUZ(2),ABMP("BDFN"),19,ABM("X0"),0),U,4),0),U)
.S ABMU("TXT")=ABMU("TXT")_", "_$S(ABM(9)["*ICD*":$P(ABM(9)," "),1:ABM(9))
S:ABMF(55)]"" ABMF(55)="9^"_ABMF(55)
D:ABMU("TXT")]"" PXTXT
G 57
;
CPT55 ; CPT Procedure Info
S ABMF(55)="",ABM="" F S ABM=$O(^ABMDBILL(DUZ(2),ABMP("BDFN"),21,"C",ABM)) Q:ABM="" S ABM("X1")=$O(^(ABM,"")) D
.S ABM("X0")=^ABMDBILL(DUZ(2),ABMP("BDFN"),21,ABM("X1"),0)
.S ABMF(55)=ABMF(55)_"^"_$P($$CPT^ABMCVAPI($P(ABM("X0"),U),ABMP("VDT")),U,2) ;CSV-c
.S ABMF(55)=ABMF(55)_"^"_$$HDTO^ABMDUTL($P(ABM("X0"),U,5))
.S ABMU("TXT")=ABMU("TXT")_", "_$P($G(^AUTNPOV($P(ABM("X0"),U,6),0)),U)
I $L(ABMF(55),"^")<6 D MED
S:ABMF(55)]"" ABMF(55)="4^"_ABMF(55)
D:ABMU("TXT")]"" PXTXT
G 57
;
MED S ABM=0 F S ABM=$O(^ABMDBILL(DUZ(2),ABMP("BDFN"),27,ABM)) Q:'ABM D
.I $P($$CPT^ABMCVAPI(ABM,ABMP("VDT")),U,4)>22,$P($$CPT^ABMCVAPI(ABM,ABMP("VDT")),U,4)<33,$P($$CPT^ABMCVAPI(ABM,ABMP("VDT")),U,4)'=31 Q ;CSV-c
.S ABM("X0")=^ABMDBILL(DUZ(2),ABMP("BDFN"),27,ABM,0)
.S ABMF(55)=ABMF(55)_"^"_$P($$CPT^ABMCVAPI($P(ABM("X0"),U),ABMP("VDT")),U,2) ;CSV-c
.S ABMF(55)=ABMF(55)_"^"_$$HDTO^ABMDUTL(+^ABMDBILL(DUZ(2),ABMP("BDFN"),7))
.S ABMU("TXT")=ABMU("TXT")_", "_$P($$CPT^ABMCVAPI($P(ABM("X0"),U),ABMP("VDT")),U,3) ;CSV-c
Q
;
57 ; Provider Info
S ABM="" F ABM("I")=6:1:7 S ABM=$O(^ABMDBILL(DUZ(2),ABMP("BDFN"),41,"C",ABM)) Q:ABM="" S ABM("X")=$O(^(ABM,"")) D
.D SELBILL^ABMDE4X
.I $L(ABM("PNUM")_" "_$P(ABM(ABM),U))<23 S $P(ABMF(57),U,ABM("I"))=ABM("PNUM")_" "_$P(ABM(ABM),U) Q
.S $P(ABMF(57),U,ABM("I"))=$P(ABM(ABM),U)
.S $P(ABMF(56),U,ABM("I")-5)=ABM("PNUM")
;
RACE ;BLOCK #27
;S ABM("INSTYP")=$P($G(^AUTNINS(ABMP("INS"),2)),U) I ABM("INSTYP")]"","RD"[ABM("INSTYP") D ;abm*2.6*10 HEAT73780
S ABM("INSTYP")=$$GET1^DIQ(9999999.181,$$GET1^DIQ(9999999.18,ABMP("INS"),".211","I"),1,"I") ;abm*2.6*10 HEAT73780
I ABM("INSTYP")]"","RD"[ABM("INSTYP") D ;abm*2.6*10 HEAT73780
.S ABM("RACE")=$S($P(^AUPNPAT(ABMP("PDFN"),11),U,11)=1:"I",1:"U")
.S (ABM("COM"),ABM("RES"))=0 F S ABM("RES")=$O(^AUPNPAT(ABMP("PDFN"),51,ABM("RES"))) Q:'ABM("RES") S ABM("COM")=$P(^(ABM("RES"),0),U,3)
.G XIT:'ABM("COM") S ABM("COM")=$P($G(^AUTTCOM(ABM("COM"),0)),U,2) G XIT:'ABM("COM") S ABM("COM")=$P(^AUTTCTY(ABM("COM"),0),U,3)
.S $P(ABMF(8),U,17)=ABM("RACE")_"/"_ABM("COM")
.I ABM("INSTYP")="D" D
..S ABM("MCDFN")=$O(^AUPNMCD("B",ABMP("PDFN"),0)) Q:'ABM("MCDFN")
..Q:$P($G(^AUPNMCD(ABM("MCDFN"),0)),"^",4)'=6
..S $P(ABMF(8),"^",17)=$P(^AUPNMCD(ABM("MCDFN"),0),"^",3)
;
XIT K ABM,ABMV,ABMX
Q
;
PXTXT S ABMU("TXT")=$P(ABMU("TXT"),", ",2,99)
I $L(ABMU("TXT"))>41 S ABMU("LNG")=22,ABMU("TAB")=19,ABMU=2 D LNG^ABMDWRAP S $P(ABMF(54),U)=ABMU(1),$P(ABMF(55),U,2)=ABMU(2) K ABMU I 1
E S $P(ABMF(55),U,2)=ABMU("TXT")
Q
ABMDF1E ; IHS/SD/SDR - Set UB82 Print Array - Part 5 ;
+1 ;;2.6;IHS 3P BILLING SYSTEM;**10,14**;NOV 12, 2009;Build 238
+2 ;Original;TMD;
+3 ;
+4 ;IHS/DSD/DMJ - 5/14/1999 - NOIS HQW-0599-100027 Patch 2
+5 ; Y2K IV&V issues, all $$HDT^ABMDUTL changed to $$HDTO^ABMDUTL
+6 ; in lines: 55+5,CPT55+4,MED+4
+7 ;
+8 ; IHS/SD/SDR - v2.6 CSV
+9 ;IHS/SD/SDR - 2.6*14 - Updated DX^ABMCVAPI call to be numeric
+10 ;
53 ; Diagnosis Info
+1 SET (ABMU("TXT"),ABMF(53),ABM)=""
FOR ABM("I")=1:1:5
SET ABM=$ORDER(^ABMDBILL(DUZ(2),ABMP("BDFN"),17,"C",ABM))
IF 'ABM
QUIT
Begin DoDot:1
+2 SET ABM("X")=$ORDER(^ABMDBILL(DUZ(2),ABMP("BDFN"),17,"C",ABM,""))
+3 ;S ABMF(53)=ABMF(53)_U_$P($$DX^ABMCVAPI(ABM("X"),ABMP("VDT")),U,2) ;CSV-c ;abm*2.6*14 update API call
+4 ;CSV-c ;abm*2.6*14 update API call
SET ABMF(53)=ABMF(53)_U_$PIECE($$DX^ABMCVAPI(+ABM("X"),ABMP("VDT")),U,2)
+5 SET ABM("PRVN")=$PIECE(^ABMDBILL(DUZ(2),ABMP("BDFN"),17,ABM("X"),0),U,3)
+6 SET ABM(9)=$PIECE($GET(^AUTNPOV(+ABM("PRVN"),0)),U)
+7 ;I ABM(9)=$P($$DX^ABMCVAPI(ABM("X"),ABMP("VDT")),U,2) S ABM(9)=$P($$DX^ABMCVAPI(ABM("X"),ABMP("VDT")),U,4) ;CSV-c ;abm*2.6*14 update API call
+8 ;CSV-c ;abm*2.6*14 update API call
IF ABM(9)=$PIECE($$DX^ABMCVAPI(+ABM("X"),ABMP("VDT")),U,2)
SET ABM(9)=$PIECE($$DX^ABMCVAPI(+ABM("X"),ABMP("VDT")),U,4)
+9 SET ABMU("TXT")=ABMU("TXT")_", "_$SELECT(ABM(9)["*ICD*":$PIECE(ABM(9)," "),1:ABM(9))
End DoDot:1
+10 SET ABMU("TXT")=$PIECE(ABMU("TXT"),", ",2,99)
+11 IF $LENGTH(ABMU("TXT"))>45
SET ABMU("LNG")=26
SET ABMU("TAB")=19
SET ABMU=2
DO LNG^ABMDWRAP
SET $PIECE(ABMF(52),U)=ABMU(1)
SET $PIECE(ABMF(53),U)=ABMU(2)
KILL ABMU
IF 1
+12 IF '$TEST
SET $PIECE(ABMF(53),U)=ABMU("TXT")
+13 GOTO 55
+14 ;
55 ; ICD Procedure Info
+1 SET ABMU("TXT")=""
+2 IF ABMP("PX")="C"
GOTO CPT55
+3 SET ABMF(55)=""
SET ABM=""
FOR
SET ABM=$ORDER(^ABMDBILL(DUZ(2),ABMP("BDFN"),19,"C",ABM))
IF ABM=""
QUIT
SET ABM("X0")=$ORDER(^ABMDBILL(DUZ(2),ABMP("BDFN"),19,"C",ABM,""))
Begin DoDot:1
+4 ;CSV-c
SET ABMF(55)=ABMF(55)_"^"_$PIECE($$ICDOP^ABMCVAPI($PIECE(ABM("X0"),U),ABMP("VDT")),U,2)
+5 SET ABMF(55)=ABMF(55)_"^"_$$HDTO^ABMDUTL($PIECE(^ABMDBILL(DUZ(2),ABMP("BDFN"),19,ABM("X0"),0),U,3))
+6 SET ABM(9)=$PIECE(^AUTNPOV($PIECE(^ABMDBILL(DUZ(2),ABMP("BDFN"),19,ABM("X0"),0),U,4),0),U)
+7 SET ABMU("TXT")=ABMU("TXT")_", "_$SELECT(ABM(9)["*ICD*":$PIECE(ABM(9)," "),1:ABM(9))
End DoDot:1
+8 IF ABMF(55)]""
SET ABMF(55)="9^"_ABMF(55)
+9 IF ABMU("TXT")]""
DO PXTXT
+10 GOTO 57
+11 ;
CPT55 ; CPT Procedure Info
+1 SET ABMF(55)=""
SET ABM=""
FOR
SET ABM=$ORDER(^ABMDBILL(DUZ(2),ABMP("BDFN"),21,"C",ABM))
IF ABM=""
QUIT
SET ABM("X1")=$ORDER(^(ABM,""))
Begin DoDot:1
+2 SET ABM("X0")=^ABMDBILL(DUZ(2),ABMP("BDFN"),21,ABM("X1"),0)
+3 ;CSV-c
SET ABMF(55)=ABMF(55)_"^"_$PIECE($$CPT^ABMCVAPI($PIECE(ABM("X0"),U),ABMP("VDT")),U,2)
+4 SET ABMF(55)=ABMF(55)_"^"_$$HDTO^ABMDUTL($PIECE(ABM("X0"),U,5))
+5 SET ABMU("TXT")=ABMU("TXT")_", "_$PIECE($GET(^AUTNPOV($PIECE(ABM("X0"),U,6),0)),U)
End DoDot:1
+6 IF $LENGTH(ABMF(55),"^")<6
DO MED
+7 IF ABMF(55)]""
SET ABMF(55)="4^"_ABMF(55)
+8 IF ABMU("TXT")]""
DO PXTXT
+9 GOTO 57
+10 ;
MED SET ABM=0
FOR
SET ABM=$ORDER(^ABMDBILL(DUZ(2),ABMP("BDFN"),27,ABM))
IF 'ABM
QUIT
Begin DoDot:1
+1 ;CSV-c
IF $PIECE($$CPT^ABMCVAPI(ABM,ABMP("VDT")),U,4)>22
IF $PIECE($$CPT^ABMCVAPI(ABM,ABMP("VDT")),U,4)<33
IF $PIECE($$CPT^ABMCVAPI(ABM,ABMP("VDT")),U,4)'=31
QUIT
+2 SET ABM("X0")=^ABMDBILL(DUZ(2),ABMP("BDFN"),27,ABM,0)
+3 ;CSV-c
SET ABMF(55)=ABMF(55)_"^"_$PIECE($$CPT^ABMCVAPI($PIECE(ABM("X0"),U),ABMP("VDT")),U,2)
+4 SET ABMF(55)=ABMF(55)_"^"_$$HDTO^ABMDUTL(+^ABMDBILL(DUZ(2),ABMP("BDFN"),7))
+5 ;CSV-c
SET ABMU("TXT")=ABMU("TXT")_", "_$PIECE($$CPT^ABMCVAPI($PIECE(ABM("X0"),U),ABMP("VDT")),U,3)
End DoDot:1
+6 QUIT
+7 ;
57 ; Provider Info
+1 SET ABM=""
FOR ABM("I")=6:1:7
SET ABM=$ORDER(^ABMDBILL(DUZ(2),ABMP("BDFN"),41,"C",ABM))
IF ABM=""
QUIT
SET ABM("X")=$ORDER(^(ABM,""))
Begin DoDot:1
+2 DO SELBILL^ABMDE4X
+3 IF $LENGTH(ABM("PNUM")_" "_$PIECE(ABM(ABM),U))<23
SET $PIECE(ABMF(57),U,ABM("I"))=ABM("PNUM")_" "_$PIECE(ABM(ABM),U)
QUIT
+4 SET $PIECE(ABMF(57),U,ABM("I"))=$PIECE(ABM(ABM),U)
+5 SET $PIECE(ABMF(56),U,ABM("I")-5)=ABM("PNUM")
End DoDot:1
+6 ;
RACE ;BLOCK #27
+1 ;S ABM("INSTYP")=$P($G(^AUTNINS(ABMP("INS"),2)),U) I ABM("INSTYP")]"","RD"[ABM("INSTYP") D ;abm*2.6*10 HEAT73780
+2 ;abm*2.6*10 HEAT73780
SET ABM("INSTYP")=$$GET1^DIQ(9999999.181,$$GET1^DIQ(9999999.18,ABMP("INS"),".211","I"),1,"I")
+3 ;abm*2.6*10 HEAT73780
IF ABM("INSTYP")]""
IF "RD"[ABM("INSTYP")
Begin DoDot:1
+4 SET ABM("RACE")=$SELECT($PIECE(^AUPNPAT(ABMP("PDFN"),11),U,11)=1:"I",1:"U")
+5 SET (ABM("COM"),ABM("RES"))=0
FOR
SET ABM("RES")=$ORDER(^AUPNPAT(ABMP("PDFN"),51,ABM("RES")))
IF 'ABM("RES")
QUIT
SET ABM("COM")=$PIECE(^(ABM("RES"),0),U,3)
+6 IF 'ABM("COM")
GOTO XIT
SET ABM("COM")=$PIECE($GET(^AUTTCOM(ABM("COM"),0)),U,2)
IF 'ABM("COM")
GOTO XIT
SET ABM("COM")=$PIECE(^AUTTCTY(ABM("COM"),0),U,3)
+7 SET $PIECE(ABMF(8),U,17)=ABM("RACE")_"/"_ABM("COM")
+8 IF ABM("INSTYP")="D"
Begin DoDot:2
+9 SET ABM("MCDFN")=$ORDER(^AUPNMCD("B",ABMP("PDFN"),0))
IF 'ABM("MCDFN")
QUIT
+10 IF $PIECE($GET(^AUPNMCD(ABM("MCDFN"),0)),"^",4)'=6
QUIT
+11 SET $PIECE(ABMF(8),"^",17)=$PIECE(^AUPNMCD(ABM("MCDFN"),0),"^",3)
End DoDot:2
End DoDot:1
+12 ;
XIT KILL ABM,ABMV,ABMX
+1 QUIT
+2 ;
PXTXT SET ABMU("TXT")=$PIECE(ABMU("TXT"),", ",2,99)
+1 IF $LENGTH(ABMU("TXT"))>41
SET ABMU("LNG")=22
SET ABMU("TAB")=19
SET ABMU=2
DO LNG^ABMDWRAP
SET $PIECE(ABMF(54),U)=ABMU(1)
SET $PIECE(ABMF(55),U,2)=ABMU(2)
KILL ABMU
IF 1
+2 IF '$TEST
SET $PIECE(ABMF(55),U,2)=ABMU("TXT")
+3 QUIT
