ABMDF2D ; IHS/SD/SDR - Set HCFA1500 Print Array - Part 4 ;
;;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 line: PDT
;IHS/SD/SDR - 2.6*14 - updated DX^ABMCVAPI calls to be numeric
;
D53 ; Dental Diagnosis Info
I ABMP("VTYP")'=998 G DX
LOOP S ABM=0 F ABM("I")=31:1:34 D Q:'ABM D PC1
.I $D(ABM("X")),+ABM S ABM("X")=$O(^ABMDBILL(DUZ(2),ABMP("BDFN"),33,"C",ABM,ABM("X"))) I +ABM("X") S ABMZ("NUM")=ABM("I") Q
.S ABM=$O(^ABMDBILL(DUZ(2),ABMP("BDFN"),33,"C",ABM)) Q:'ABM S ABM("X")=$O(^(ABM,""))
.Q
G ST
;
PC1 S ABM("X0")=^ABMDBILL(DUZ(2),ABMP("BDFN"),33,ABM("X"),0)
I $P(^AUTTADA(+ABM("X0"),0),U,3)]"" S:'$D(ABM("DUP",$P(^(0),U,3))) ABM("DUP",$P(^(0),U,3))="",$P(ABMF(ABM("I")),U)=$P($$DX^ABMCVAPI($P(^AUTTADA(+ABM("X0"),0),U,3),ABMP("VDT")),U,2)_" "_$E($P(^(0),U,3),1,50),ABMD($P(^(0),U))=ABM("I") ;CSV-c
Q
;
DX ; Diagnosis Info
S ABM="" F ABM("I")=31:1:34 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 ABM(9)=$P(^AUTNPOV($P(^ABMDBILL(DUZ(2),ABMP("BDFN"),17,ABM("X"),0),U,3),0),U)
.S ABM(9)=$S(ABM(9)["*ICD*":$P(ABM(9)," "),1:ABM(9))
.;S $P(ABMF(ABM("I")),U)=$P($$DX^ABMCVAPI(ABM("X"),ABMP("VDT")),U,2)_" "_ABM(9) ;CSV-c ;abm*2.6*14 updated API call
.S $P(ABMF(ABM("I")),U)=$P($$DX^ABMCVAPI(+ABM("X"),ABMP("VDT")),U,2)_" "_ABM(9) ;CSV-c ;abm*2.6*14 updated API call
.S ABM("DX",$P(ABMF(ABM("I"))," "))=ABM("I")-30
;
ST ;
;S ABMF(36)=$S($P($G(^AUTNINS(ABMP("INS"),2)),U)="R":"CPT",$G(ABMP("PX"))="I":"ICD",ABMP("VTYP")=998:"ADA",1:"CPT") ;abm*2.6*10 HEAT73780
S ABMF(36)=$S($$GET1^DIQ(9999999.181,$$GET1^DIQ(9999999.18,ABMP("INS"),".211","I"),1,"I")="R":"CPT",$G(ABMP("PX"))="I":"ICD",ABMP("VTYP")=998:"ADA",1:"CPT") ;abm*2.6*10 HEAT73780
S ABMP("GL")="^ABMDBILL(DUZ(2),"_ABMP("BDFN")_","
D ^ABMDESM1
HCFA I $P(^ABMDBILL(DUZ(2),ABMP("BDFN"),2),U)=0 S ABMS("TOT")=0
S ABMS="" F ABMS("I")=37:2:47 S ABMS=$O(ABMS(ABMS)) Q:'ABMS D
.S ABMF(ABMS("I"))=$P(ABMS(ABMS),U,2)_U_$S(ABMP("VTYP")=111!($G(ABMP("BTYP"))=111):1,ABMP("VTYP")=831:"B",1:3)_U_$P(ABMS(ABMS),U,4)_U_U_U_$P(ABMS(ABMS),U)_U_$P(ABMS(ABMS),U,6)_U_$P(ABMS(ABMS),U,7)
.S $P(ABMF(ABMS("I")),U,5)=$S($P(ABMS(ABMS),U,5)="":"",$D(ABM("DX",$P(ABMS(ABMS),U,5))):ABM("DX",$P(ABMS(ABMS),U,5)),1:$P(ABMS(ABMS),U,5))
.I $P(ABMS(ABMS),U,3)'=$P(ABMS(ABMS),U,2) S ABMF(ABMS("I")+1)=$P(ABMS(ABMS),U,3)
.I $L($P(ABMS(ABMS),U,8))>19 S ABMU("LNG")=19,ABMU("TXT")=$P(ABMS(ABMS),U,8),ABMU=2 D LNG^ABMDWRAP S $P(ABMF(ABMS("I")),U,4)=ABMU(1),$P(ABMF(ABMS("I")+1),U,4)=$G(ABMU(2)) K ABMU I 1
.E S $P(ABMF(ABMS("I")),U,4)=$P(ABMS(ABMS),U,8)
.K ABMS(ABMS)
K ABMR I ABMS("I")=47,+$O(ABMS("")) K ABMF("C") F ABMS("I")=48:1 S ABMS=$O(ABMS(ABMS)) Q:'ABMS D
.S ABMR(ABMS("I"))=ABMS(ABMS)
.K ABMS(ABMS)
;
D PREV^ABMDFUTL
S ABM("RATIO")=+^ABMDBILL(DUZ(2),ABMP("BDFN"),2)/$S($P(^(2),U,3):$P(^(2),U,3),1:1)
S:ABM("RATIO")>1 ABM("RATIO")=1
S ABM("P")=+$FN(ABMP("PD")*ABM("RATIO"),"",2)
S ABM("W")=+$FN(ABMP("WO")*ABM("RATIO"),"",2)
S $P(ABMF(50),U,3)=ABM("P")+ABM("W")
S ABM("OB")=ABMS("TOT")-$P(ABMF(50),U,3)
S:ABM("OB")<0 ABM("OB")=0
S ABM("YTOT")=ABM("OB") D YTOT^ABMDFUTL
I '$D(ABMR) S $P(ABMF(50),U,2)=ABMS("TOT"),$P(ABMF(50),U,4)=$S(ABM("OB")>999:$FN(ABM("OB"),",",0),1:$FN(ABM("OB"),",",2))
E S ABMR("TOT")=U_ABMS("TOT")_U_$P(ABMF(50),U,3)_U_($S(ABM("OB")>999:$FN(ABM("OB"),",",0),1:$FN(ABM("OB"),",",2))) K ABMF(50) I $P(ABMR("TOT"),U,3)<0 S $P(ABMR("TOT"),U,3)=0
I S $P(ABMF(50),U,3)=$S($P(ABMF(50),U,3)>999:$FN($P(ABMF(50),U,3),",",0),1:$FN($P(ABMF(50),U,3),",",2))
K ABMS
;
57 ; Provider Info
I $P($G(^ABMDPARM(DUZ(2),1,0)),U,17)=2 D G PDT
.S $P(ABMF(51),U)=$P($G(^VA(200,$P(^ABMDBILL(DUZ(2),ABMP("BDFN"),1),U,4),0)),U)
.I $P($G(^VA(200,$P(^ABMDBILL(DUZ(2),ABMP("BDFN"),1),U,4),0)),U,9),$D(^VA(200.1,$P(^(0),U,9),0)) S $P(ABMF(52),U)=$P(^(0),U)
S ABM="",ABM("OLD")="" F ABM("I")=51:1:52 S ABM=$O(^ABMDBILL(DUZ(2),ABMP("BDFN"),41,"C",ABM)) Q:ABM="" S ABM("X")=$O(^(ABM,"")) D
.Q:ABM("OLD")=$P(^ABMDBILL(DUZ(2),ABMP("BDFN"),41,ABM("X"),0),U) S ABM("OLD")=$P(^(0),U)
.D SELBILL^ABMDE4X I ABM("I")=52,$P(ABM(ABM),U)=$P(ABMF(51)," ") Q
.I $L($P(ABM(ABM),U)_" "_ABM("PNUM"))<30 S $P(ABMF(ABM("I")),U)=$P(ABM(ABM),U)_" "_ABM("PNUM") Q
.S $P(ABMF($S(ABM("I")=51:50,1:52)),U)=$P(ABM(ABM),U)
.S $P(ABMF($S(ABM("I")=51:51,1:53)),U)=" "_ABM("PNUM")
PDT S $P(ABMF(54),U)=$$HDTO^ABMDUTL(DT)
S $P(ABMF(51),U,2)="X"
;
XIT K ABM,ABMV,ABMX
Q
ABMDF2D ; IHS/SD/SDR - Set HCFA1500 Print Array - Part 4 ;
+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 line: PDT
+7 ;IHS/SD/SDR - 2.6*14 - updated DX^ABMCVAPI calls to be numeric
+8 ;
D53 ; Dental Diagnosis Info
+1 IF ABMP("VTYP")'=998
GOTO DX
LOOP SET ABM=0
FOR ABM("I")=31:1:34
Begin DoDot:1
+1 IF $DATA(ABM("X"))
IF +ABM
SET ABM("X")=$ORDER(^ABMDBILL(DUZ(2),ABMP("BDFN"),33,"C",ABM,ABM("X")))
IF +ABM("X")
SET ABMZ("NUM")=ABM("I")
QUIT
+2 SET ABM=$ORDER(^ABMDBILL(DUZ(2),ABMP("BDFN"),33,"C",ABM))
IF 'ABM
QUIT
SET ABM("X")=$ORDER(^(ABM,""))
+3 QUIT
End DoDot:1
IF 'ABM
QUIT
DO PC1
+4 GOTO ST
+5 ;
PC1 SET ABM("X0")=^ABMDBILL(DUZ(2),ABMP("BDFN"),33,ABM("X"),0)
+1 ;CSV-c
IF $PIECE(^AUTTADA(+ABM("X0"),0),U,3)]""
IF '$DATA(ABM("DUP",$PIECE(^(0),U,3)))
SET ABM("DUP",$PIECE(^(0),U,3))=""
SET $PIECE(ABMF(ABM("I")),U)=$PIECE($$DX^ABMCVAPI($PIECE(^AUTTADA(+ABM("X0"),0),U,3),ABMP("VDT")),U,2)_" "_$EXTRACT($PIECE(^(0),U,3),1,50)
SET ABMD($PIECE(^(0),U))=ABM("I")
+2 QUIT
+3 ;
DX ; Diagnosis Info
+1 SET ABM=""
FOR ABM("I")=31:1:34
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 SET ABM(9)=$PIECE(^AUTNPOV($PIECE(^ABMDBILL(DUZ(2),ABMP("BDFN"),17,ABM("X"),0),U,3),0),U)
+4 SET ABM(9)=$SELECT(ABM(9)["*ICD*":$PIECE(ABM(9)," "),1:ABM(9))
+5 ;S $P(ABMF(ABM("I")),U)=$P($$DX^ABMCVAPI(ABM("X"),ABMP("VDT")),U,2)_" "_ABM(9) ;CSV-c ;abm*2.6*14 updated API call
+6 ;CSV-c ;abm*2.6*14 updated API call
SET $PIECE(ABMF(ABM("I")),U)=$PIECE($$DX^ABMCVAPI(+ABM("X"),ABMP("VDT")),U,2)_" "_ABM(9)
+7 SET ABM("DX",$PIECE(ABMF(ABM("I"))," "))=ABM("I")-30
End DoDot:1
+8 ;
ST ;
+1 ;S ABMF(36)=$S($P($G(^AUTNINS(ABMP("INS"),2)),U)="R":"CPT",$G(ABMP("PX"))="I":"ICD",ABMP("VTYP")=998:"ADA",1:"CPT") ;abm*2.6*10 HEAT73780
+2 ;abm*2.6*10 HEAT73780
SET ABMF(36)=$SELECT($$GET1^DIQ(9999999.181,$$GET1^DIQ(9999999.18,ABMP("INS"),".211","I"),1,"I")="R":"CPT",$GET(ABMP("PX"))="I":"ICD",ABMP("VTYP")=998:"ADA",1:"CPT")
+3 SET ABMP("GL")="^ABMDBILL(DUZ(2),"_ABMP("BDFN")_","
+4 DO ^ABMDESM1
HCFA IF $PIECE(^ABMDBILL(DUZ(2),ABMP("BDFN"),2),U)=0
SET ABMS("TOT")=0
+1 SET ABMS=""
FOR ABMS("I")=37:2:47
SET ABMS=$ORDER(ABMS(ABMS))
IF 'ABMS
QUIT
Begin DoDot:1
+2 SET ABMF(ABMS("I"))=$PIECE(ABMS(ABMS),U,2)_U_$SELECT(ABMP("VTYP")=111!($GET(ABMP("BTYP"))=111):1,ABMP("VTYP")=831:"B",1:3)_U_$PIECE(ABMS(ABMS),U,4)_U_U_U_$PIECE(ABMS(ABMS),U)_U_$PIECE(ABMS(ABMS),U,6)_U_$PIECE(ABMS(ABMS),U,7)
+3 SET $PIECE(ABMF(ABMS("I")),U,5)=$SELECT($PIECE(ABMS(ABMS),U,5)="":"",$DATA(ABM("DX",$PIECE(ABMS(ABMS),U,5))):ABM("DX",$PIECE(ABMS(ABMS),U,5)),1:$PIECE(ABMS(ABMS),U,5))
+4 IF $PIECE(ABMS(ABMS),U,3)'=$PIECE(ABMS(ABMS),U,2)
SET ABMF(ABMS("I")+1)=$PIECE(ABMS(ABMS),U,3)
+5 IF $LENGTH($PIECE(ABMS(ABMS),U,8))>19
SET ABMU("LNG")=19
SET ABMU("TXT")=$PIECE(ABMS(ABMS),U,8)
SET ABMU=2
DO LNG^ABMDWRAP
SET $PIECE(ABMF(ABMS("I")),U,4)=ABMU(1)
SET $PIECE(ABMF(ABMS("I")+1),U,4)=$GET(ABMU(2))
KILL ABMU
IF 1
+6 IF '$TEST
SET $PIECE(ABMF(ABMS("I")),U,4)=$PIECE(ABMS(ABMS),U,8)
+7 KILL ABMS(ABMS)
End DoDot:1
+8 KILL ABMR
IF ABMS("I")=47
IF +$ORDER(ABMS(""))
KILL ABMF("C")
FOR ABMS("I")=48:1
SET ABMS=$ORDER(ABMS(ABMS))
IF 'ABMS
QUIT
Begin DoDot:1
+9 SET ABMR(ABMS("I"))=ABMS(ABMS)
+10 KILL ABMS(ABMS)
End DoDot:1
+11 ;
+12 DO PREV^ABMDFUTL
+13 SET ABM("RATIO")=+^ABMDBILL(DUZ(2),ABMP("BDFN"),2)/$SELECT($PIECE(^(2),U,3):$PIECE(^(2),U,3),1:1)
+14 IF ABM("RATIO")>1
SET ABM("RATIO")=1
+15 SET ABM("P")=+$FNUMBER(ABMP("PD")*ABM("RATIO"),"",2)
+16 SET ABM("W")=+$FNUMBER(ABMP("WO")*ABM("RATIO"),"",2)
+17 SET $PIECE(ABMF(50),U,3)=ABM("P")+ABM("W")
+18 SET ABM("OB")=ABMS("TOT")-$PIECE(ABMF(50),U,3)
+19 IF ABM("OB")<0
SET ABM("OB")=0
+20 SET ABM("YTOT")=ABM("OB")
DO YTOT^ABMDFUTL
+21 IF '$DATA(ABMR)
SET $PIECE(ABMF(50),U,2)=ABMS("TOT")
SET $PIECE(ABMF(50),U,4)=$SELECT(ABM("OB")>999:$FNUMBER(ABM("OB"),",",0),1:$FNUMBER(ABM("OB"),",",2))
+22 IF '$TEST
SET ABMR("TOT")=U_ABMS("TOT")_U_$PIECE(ABMF(50),U,3)_U_($SELECT(ABM("OB")>999:$FNUMBER(ABM("OB"),",",0),1:$FNUMBER(ABM("OB"),",",2)))
KILL ABMF(50)
IF $PIECE(ABMR("TOT"),U,3)<0
SET $PIECE(ABMR("TOT"),U,3)=0
+23 IF $TEST
SET $PIECE(ABMF(50),U,3)=$SELECT($PIECE(ABMF(50),U,3)>999:$FNUMBER($PIECE(ABMF(50),U,3),",",0),1:$FNUMBER($PIECE(ABMF(50),U,3),",",2))
+24 KILL ABMS
+25 ;
57 ; Provider Info
+1 IF $PIECE($GET(^ABMDPARM(DUZ(2),1,0)),U,17)=2
Begin DoDot:1
+2 SET $PIECE(ABMF(51),U)=$PIECE($GET(^VA(200,$PIECE(^ABMDBILL(DUZ(2),ABMP("BDFN"),1),U,4),0)),U)
+3 IF $PIECE($GET(^VA(200,$PIECE(^ABMDBILL(DUZ(2),ABMP("BDFN"),1),U,4),0)),U,9)
IF $DATA(^VA(200.1,$PIECE(^(0),U,9),0))
SET $PIECE(ABMF(52),U)=$PIECE(^(0),U)
End DoDot:1
GOTO PDT
+4 SET ABM=""
SET ABM("OLD")=""
FOR ABM("I")=51:1:52
SET ABM=$ORDER(^ABMDBILL(DUZ(2),ABMP("BDFN"),41,"C",ABM))
IF ABM=""
QUIT
SET ABM("X")=$ORDER(^(ABM,""))
Begin DoDot:1
+5 IF ABM("OLD")=$PIECE(^ABMDBILL(DUZ(2),ABMP("BDFN"),41,ABM("X"),0),U)
QUIT
SET ABM("OLD")=$PIECE(^(0),U)
+6 DO SELBILL^ABMDE4X
IF ABM("I")=52
IF $PIECE(ABM(ABM),U)=$PIECE(ABMF(51)," ")
QUIT
+7 IF $LENGTH($PIECE(ABM(ABM),U)_" "_ABM("PNUM"))<30
SET $PIECE(ABMF(ABM("I")),U)=$PIECE(ABM(ABM),U)_" "_ABM("PNUM")
QUIT
+8 SET $PIECE(ABMF($SELECT(ABM("I")=51:50,1:52)),U)=$PIECE(ABM(ABM),U)
+9 SET $PIECE(ABMF($SELECT(ABM("I")=51:51,1:53)),U)=" "_ABM("PNUM")
End DoDot:1
PDT SET $PIECE(ABMF(54),U)=$$HDTO^ABMDUTL(DT)
+1 SET $PIECE(ABMF(51),U,2)="X"
+2 ;
XIT KILL ABM,ABMV,ABMX
+1 QUIT
