- 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
