IBBACHRG ;OAK/ELZ - PFSS CHARGE API ;15-MAR-2005
;;2.0;INTEGRATED BILLING;**286**;21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
CHARGE(IBBDFN,IBBARFN,IBBCTYPE,IBBUCID,IBBFT1,IBBPR1,IBBDG1,IBBZCL,IBBRXE,IBBORIEN,IBBPROS) ;
;add transaction to charge cache
N IBB,IBBIEN,IBBIENS,IBBERR,FDA,J,J1,X,XX
N IBBCPTC,IBBCPTDT,IBBCDM,IBBSECVN,IBBTEST
;required parameters
I ('$G(IBBDFN)!'$G(IBBARFN)!'$G(IBBUCID)!($G(IBBCTYPE)="")) D ERRMSG("MISSING DATA") Q 0
;add charge record
L +^IBBAD(373,0):5
I '$T D ERRMSG("LOCK FAILURE") Q 0
S IBBIEN=$P(^IBBAD(373,0),U,3)+1,$P(^IBBAD(373,0),U,3)=IBBIEN
L -^IBBAD(373,0)
S ^IBBAD(373,IBBIEN,0)=IBBIEN
S IBBIENS=IBBIEN_","
S IBBERR="IBB(""DIERR"")"
S FDA(373,IBBIENS,.02)=IBBARFN
S FDA(373,IBBIENS,.03)=IBBDFN
S FDA(373,IBBIENS,.04)=IBBUCID
S FDA(373,IBBIENS,.05)=IBBCTYPE
S FDA(373,IBBIENS,.1)=$$NOW^XLFDT()
D FILE^DIE("","FDA",IBBERR)
;exit on error
I $D(IBB("DIERR")) D ERRMSG("FILEMAN ERROR") Q 0
;get service charge code
S IBBCDM=$G(IBBFT1(7))
I $G(IBBFT1(13))'=160 D
.S IBBCPTC=+$G(IBBPR1(3))
.S IBBCPTDT=+$G(IBBPR1(5)) I 'IBBCPTDT S IBBCPTDT=+$G(IBBFT1(4))
.S IBBCDM=$P($$GETCODE^IBBACDM(IBBCPTC,IBBCPTDT),U,1)
;financial transaction
I $D(IBBFT1)>1 D
.S J=0,X="" F S J=$O(IBBFT1(J)) Q:'J S $P(X,U,J)=IBBFT1(J)
.S $P(X,U,2)="",$P(X,U,6)=IBBCTYPE
.S XX=+$G(IBBFT1(13)) S XX=$S('XX:999,$L(XX)'=3:999,1:XX)
.S $P(X,U,7)=XX_IBBCDM
.S ^IBBAD(373,IBBIEN,"FT1")=X
;update PV1.50 for radiology in file #375
I (",105,109,115,150,151,152,421,703,")[(","_IBBFT1(13)_",") D
.S XX="",IBBSECVN=""
.I $G(IBBORIEN) S X=$T(ORACTREF^ORWPFSS) I $E(X,9)="(" D
..D ORACTREF^ORWPFSS(.XX,IBBORIEN)
..S IBBSECVN=$$EXTNUM^IBBAACCT(IBBDFN,XX)
..I IBBSECVN'="" S $P(^IBBAA(375,IBBARFN,"PV1"),U,50)=IBBSECVN_";;;;RAD"
;procedure
I $D(IBBPR1)>1 D
.I '$G(IBBPR1(5)) S IBBPR1(5)=+$G(IBBFT1(4))
.S X="" F J=3,5,6,16 S $P(X,U,J)=$G(IBBPR1(J))
.;surgery-only
.I $D(IBBPR1(11))>1 D
..S $P(X,U,11)=$G(IBBPR1(11,1)),$P(X,U,12)=$G(IBBPR1(11,2))
.S ^IBBAD(373,IBBIEN,"PR1")=X
.I $G(IBBPR1(4))'="" S ^IBBAD(373,IBBIEN,11)=IBBPR1(4)
;diagnosis
I $D(IBBDG1)>1 D
.I $G(IBBDG1(1,3))=+$G(IBBDG1(1,3)) D DX^IBBACHRG(.IBBDG1,IBBIEN)
;classification
I $D(IBBZCL)>1 D
.S (J,J1)=0 F S J=$O(IBBZCL(J)) Q:'J S J1=J1+1,X=J1_U_$G(IBBZCL(J,2))_U_$G(IBBZCL(J,3)),^IBBAD(373,IBBIEN,"ZCL",J1,0)=X
.S ^IBBAD(373,IBBIEN,"ZCL",0)="^373.05A^"_J1_U_J1
;pharmacy-only
I $D(IBBRXE)>1 D
.S J=0,X="" F S J=$O(IBBRXE(J)) Q:'J S $P(X,U,J)=IBBRXE(J)
.S XX=$P(^IBBAA(375,IBBARFN,"PV1"),U,50) I $P(XX,";",5)="OPP" S XX=+XX,$P(X,U,15)=XX
.S ^IBBAD(373,IBBIEN,"RXE")=X
;prosthetics-only
I $D(IBBPROS)>1 D
.S X=$G(IBBPROS(1))_U_$G(IBBPROS(2))
.I X'=U S ^IBBAD(373,IBBIEN,23)=X
;add department, service code, order ien, clinical event id to 0-node
S X=^IBBAD(373,IBBIEN,0)
S $P(X,U,6)=$S($G(IBBFT1(13)):IBBFT1(13),1:999),$P(X,U,7)=$G(IBBCDM),$P(X,U,8)=$G(IBBORIEN),$P(X,U,9)=$G(IBBFT1(2))
S ^IBBAD(373,IBBIEN,0)=X
;set "AOX" xref
S IBBTEST="" D SAOX^IBBAADD(IBBIEN,IBBDFN,.IBBTEST)
I IBBTEST S $P(^IBBAD(373,IBBIEN,0),U,20)=1
;
Q 1
;
DX(DG1,IEN) ;file diagnosis on subfile #373.04
N J,IBB,IBBIEN,IBBIENS,IBBERR,FDA
S J=0 F S J=$O(DG1(J)) Q:'J Q:(DG1(J,3)'=+DG1(J,3)) D
.S IBBIEN(1)=J
.S IBBIENS="+1,"_IEN_","
.S IBBERR="IBB(""DIERR"")"
.S FDA(373.04,IBBIENS,.01)=J
.S FDA(373.04,IBBIENS,.03)=DG1(J,3)
.S FDA(373.04,IBBIENS,.06)=$G(DG1(J,6))
.D UPDATE^DIE("","FDA","IBBIEN",IBBERR)
Q
;
GETCHGID() ;
;get next unique charge identifier
N X
L +^IBBAS(372,1,2):5
Q:'$T 0
S X=1+$G(^IBBAS(372,1,2))
I X>99999999 S X=1
S ^IBBAS(372,1,2)=X
L -^IBBAS(372,1,2)
Q X
;
ERRMSG(MSG) ;generate error msg if charge failure
N LINE,J,X
S LINE=0,SETLN="S LINE=LINE+1,^TMP(""PFSS CHG ERROR"",$J,LINE,0)=X"
I MSG="MISSING DATA" D
.I '$G(IBBDFN) S MSG=MSG_": DFN" Q
.I '$G(IBBARFN) S MSG=MSG_": PFSS Account Reference" Q
.I '$G(IBBUCID) S MSG=MSG_": Unique Charge ID" Q
.I $G(IBBCTYPE)="" S MSG=MSG_": Charge Type" Q
I MSG="FILEMAN ERROR" D
.I $D(IBB("DIERR")) S MSG="FM ERROR: "_$G(IBB("DIERR","DIERR",1,"TEXT",1))
I MSG="LOCK FAILURE" S MSG="Lock request failure on ^IBBAD(373,0)"
S X=MSG X SETLN
S X=" " X SETLN
S X="Input Parameters" X SETLN
S X="----------------" X SETLN
S X="IBBDFN="_$G(IBBDFN) X SETLN
S X="IBBARFN="_$G(IBBARFN) X SETLN
S X="IBBCTYPE="_$G(IBBCTYPE) X SETLN
S X="IBBUCID="_$G(IBBUCID) X SETLN
I $D(IBBFT1)>1 D
.S J=0 F S J=$O(IBBFT1(J)) Q:'J S X="IBBFT1("_J_")="_IBBFT1(J) X SETLN
I $D(IBBPR1)>1 D
.S J=0 F S J=$O(IBBPR1(J)) Q:'J I J'=11 S X="IBBPR1("_J_")="_IBBPR1(J) X SETLN
.I $G(IBBPR1(11,1)) S X="IBBPR1(11,1)="_IBBPR1(11,1) X SETLN
.I $G(IBBPR1(11,2)) S X="IBBPR1(11,2)="_IBBPR1(11,2) X SETLN
I $D(IBBDG1)>1 D
.S J=0 F S J=$O(IBBDG1(J)) Q:'J S J1=0 F S J1=$O(IBBDG1(J,J1)) Q:'J1 S X="IBBDG1("_J_","_J1_")="_IBBDG1(J,J1) X SETLN
I $D(IBBZCL)>1 D
.S J=0 F S J=$O(IBBZCL(J)) Q:'J S J1=0 F S J1=$O(IBBZCL(J,J1)) Q:'J1 S X="IBBZCL("_J_","_J1_")="_IBBZCL(J,J1) X SETLN
I $D(IBBRXE)>1 D
.S J=0 F S J=$O(IBBRXE(J)) Q:'J S X="IBBRXE("_J_")="_IBBRXE(J) X SETLN
I $G(IBBORIEN) S X="IBBORIEN="_IBBORIEN X SETLN
I $D(IBBPROS)>1 D
.S J=0 F S J=$O(IBBPROS(J)) Q:'J S X="IBBPROS("_J_")="_IBBPROS(J) X SETLN
D MAIL
Q
;
MAIL ;send error message to mail group
N MMGROUP,IENS,XMY,XMSUB,XMDUZ,XMTEXT,XMZ
S XMSUB="IBB CHARGE FAILURE at "_$$NOW^XLFDT(),XMDUZ=.5
S MMGROUP=$P($G(^IBBAS(372,1,0)),U,6)
I MMGROUP D
.S IENS=MMGROUP_","
.S MMGROUP=$$GET1^DIQ(3.8,IENS,.01)
.S XMY("G."_MMGROUP_"@"_^XMB("NETNAME"))=""
S XMTEXT="^TMP(""PFSS CHG ERROR"",$J,"
D ^XMD
K ^TMP("PFSS CHG ERROR",$J)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBBACHRG 5791 printed Dec 13, 2024@02:08:20 Page 2
IBBACHRG ;OAK/ELZ - PFSS CHARGE API ;15-MAR-2005
+1 ;;2.0;INTEGRATED BILLING;**286**;21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
CHARGE(IBBDFN,IBBARFN,IBBCTYPE,IBBUCID,IBBFT1,IBBPR1,IBBDG1,IBBZCL,IBBRXE,IBBORIEN,IBBPROS) ;
+1 ;add transaction to charge cache
+2 NEW IBB,IBBIEN,IBBIENS,IBBERR,FDA,J,J1,X,XX
+3 NEW IBBCPTC,IBBCPTDT,IBBCDM,IBBSECVN,IBBTEST
+4 ;required parameters
+5 IF ('$GET(IBBDFN)!'$GET(IBBARFN)!'$GET(IBBUCID)!($GET(IBBCTYPE)=""))
DO ERRMSG("MISSING DATA")
QUIT 0
+6 ;add charge record
+7 LOCK +^IBBAD(373,0):5
+8 IF '$TEST
DO ERRMSG("LOCK FAILURE")
QUIT 0
+9 SET IBBIEN=$PIECE(^IBBAD(373,0),U,3)+1
SET $PIECE(^IBBAD(373,0),U,3)=IBBIEN
+10 LOCK -^IBBAD(373,0)
+11 SET ^IBBAD(373,IBBIEN,0)=IBBIEN
+12 SET IBBIENS=IBBIEN_","
+13 SET IBBERR="IBB(""DIERR"")"
+14 SET FDA(373,IBBIENS,.02)=IBBARFN
+15 SET FDA(373,IBBIENS,.03)=IBBDFN
+16 SET FDA(373,IBBIENS,.04)=IBBUCID
+17 SET FDA(373,IBBIENS,.05)=IBBCTYPE
+18 SET FDA(373,IBBIENS,.1)=$$NOW^XLFDT()
+19 DO FILE^DIE("","FDA",IBBERR)
+20 ;exit on error
+21 IF $DATA(IBB("DIERR"))
DO ERRMSG("FILEMAN ERROR")
QUIT 0
+22 ;get service charge code
+23 SET IBBCDM=$GET(IBBFT1(7))
+24 IF $GET(IBBFT1(13))'=160
Begin DoDot:1
+25 SET IBBCPTC=+$GET(IBBPR1(3))
+26 SET IBBCPTDT=+$GET(IBBPR1(5))
IF 'IBBCPTDT
SET IBBCPTDT=+$GET(IBBFT1(4))
+27 SET IBBCDM=$PIECE($$GETCODE^IBBACDM(IBBCPTC,IBBCPTDT),U,1)
End DoDot:1
+28 ;financial transaction
+29 IF $DATA(IBBFT1)>1
Begin DoDot:1
+30 SET J=0
SET X=""
FOR
SET J=$ORDER(IBBFT1(J))
if 'J
QUIT
SET $PIECE(X,U,J)=IBBFT1(J)
+31 SET $PIECE(X,U,2)=""
SET $PIECE(X,U,6)=IBBCTYPE
+32 SET XX=+$GET(IBBFT1(13))
SET XX=$SELECT('XX:999,$LENGTH(XX)'=3:999,1:XX)
+33 SET $PIECE(X,U,7)=XX_IBBCDM
+34 SET ^IBBAD(373,IBBIEN,"FT1")=X
End DoDot:1
+35 ;update PV1.50 for radiology in file #375
+36 IF (",105,109,115,150,151,152,421,703,")[(","_IBBFT1(13)_",")
Begin DoDot:1
+37 SET XX=""
SET IBBSECVN=""
+38 IF $GET(IBBORIEN)
SET X=$TEXT(ORACTREF^ORWPFSS)
IF $EXTRACT(X,9)="("
Begin DoDot:2
+39 DO ORACTREF^ORWPFSS(.XX,IBBORIEN)
+40 SET IBBSECVN=$$EXTNUM^IBBAACCT(IBBDFN,XX)
+41 IF IBBSECVN'=""
SET $PIECE(^IBBAA(375,IBBARFN,"PV1"),U,50)=IBBSECVN_";;;;RAD"
End DoDot:2
End DoDot:1
+42 ;procedure
+43 IF $DATA(IBBPR1)>1
Begin DoDot:1
+44 IF '$GET(IBBPR1(5))
SET IBBPR1(5)=+$GET(IBBFT1(4))
+45 SET X=""
FOR J=3,5,6,16
SET $PIECE(X,U,J)=$GET(IBBPR1(J))
+46 ;surgery-only
+47 IF $DATA(IBBPR1(11))>1
Begin DoDot:2
+48 SET $PIECE(X,U,11)=$GET(IBBPR1(11,1))
SET $PIECE(X,U,12)=$GET(IBBPR1(11,2))
End DoDot:2
+49 SET ^IBBAD(373,IBBIEN,"PR1")=X
+50 IF $GET(IBBPR1(4))'=""
SET ^IBBAD(373,IBBIEN,11)=IBBPR1(4)
End DoDot:1
+51 ;diagnosis
+52 IF $DATA(IBBDG1)>1
Begin DoDot:1
+53 IF $GET(IBBDG1(1,3))=+$GET(IBBDG1(1,3))
DO DX^IBBACHRG(.IBBDG1,IBBIEN)
End DoDot:1
+54 ;classification
+55 IF $DATA(IBBZCL)>1
Begin DoDot:1
+56 SET (J,J1)=0
FOR
SET J=$ORDER(IBBZCL(J))
if 'J
QUIT
SET J1=J1+1
SET X=J1_U_$GET(IBBZCL(J,2))_U_$GET(IBBZCL(J,3))
SET ^IBBAD(373,IBBIEN,"ZCL",J1,0)=X
+57 SET ^IBBAD(373,IBBIEN,"ZCL",0)="^373.05A^"_J1_U_J1
End DoDot:1
+58 ;pharmacy-only
+59 IF $DATA(IBBRXE)>1
Begin DoDot:1
+60 SET J=0
SET X=""
FOR
SET J=$ORDER(IBBRXE(J))
if 'J
QUIT
SET $PIECE(X,U,J)=IBBRXE(J)
+61 SET XX=$PIECE(^IBBAA(375,IBBARFN,"PV1"),U,50)
IF $PIECE(XX,";",5)="OPP"
SET XX=+XX
SET $PIECE(X,U,15)=XX
+62 SET ^IBBAD(373,IBBIEN,"RXE")=X
End DoDot:1
+63 ;prosthetics-only
+64 IF $DATA(IBBPROS)>1
Begin DoDot:1
+65 SET X=$GET(IBBPROS(1))_U_$GET(IBBPROS(2))
+66 IF X'=U
SET ^IBBAD(373,IBBIEN,23)=X
End DoDot:1
+67 ;add department, service code, order ien, clinical event id to 0-node
+68 SET X=^IBBAD(373,IBBIEN,0)
+69 SET $PIECE(X,U,6)=$SELECT($GET(IBBFT1(13)):IBBFT1(13),1:999)
SET $PIECE(X,U,7)=$GET(IBBCDM)
SET $PIECE(X,U,8)=$GET(IBBORIEN)
SET $PIECE(X,U,9)=$GET(IBBFT1(2))
+70 SET ^IBBAD(373,IBBIEN,0)=X
+71 ;set "AOX" xref
+72 SET IBBTEST=""
DO SAOX^IBBAADD(IBBIEN,IBBDFN,.IBBTEST)
+73 IF IBBTEST
SET $PIECE(^IBBAD(373,IBBIEN,0),U,20)=1
+74 ;
+75 QUIT 1
+76 ;
DX(DG1,IEN) ;file diagnosis on subfile #373.04
+1 NEW J,IBB,IBBIEN,IBBIENS,IBBERR,FDA
+2 SET J=0
FOR
SET J=$ORDER(DG1(J))
if 'J
QUIT
if (DG1(J,3)'=+DG1(J,3))
QUIT
Begin DoDot:1
+3 SET IBBIEN(1)=J
+4 SET IBBIENS="+1,"_IEN_","
+5 SET IBBERR="IBB(""DIERR"")"
+6 SET FDA(373.04,IBBIENS,.01)=J
+7 SET FDA(373.04,IBBIENS,.03)=DG1(J,3)
+8 SET FDA(373.04,IBBIENS,.06)=$GET(DG1(J,6))
+9 DO UPDATE^DIE("","FDA","IBBIEN",IBBERR)
End DoDot:1
+10 QUIT
+11 ;
GETCHGID() ;
+1 ;get next unique charge identifier
+2 NEW X
+3 LOCK +^IBBAS(372,1,2):5
+4 if '$TEST
QUIT 0
+5 SET X=1+$GET(^IBBAS(372,1,2))
+6 IF X>99999999
SET X=1
+7 SET ^IBBAS(372,1,2)=X
+8 LOCK -^IBBAS(372,1,2)
+9 QUIT X
+10 ;
ERRMSG(MSG) ;generate error msg if charge failure
+1 NEW LINE,J,X
+2 SET LINE=0
SET SETLN="S LINE=LINE+1,^TMP(""PFSS CHG ERROR"",$J,LINE,0)=X"
+3 IF MSG="MISSING DATA"
Begin DoDot:1
+4 IF '$GET(IBBDFN)
SET MSG=MSG_": DFN"
QUIT
+5 IF '$GET(IBBARFN)
SET MSG=MSG_": PFSS Account Reference"
QUIT
+6 IF '$GET(IBBUCID)
SET MSG=MSG_": Unique Charge ID"
QUIT
+7 IF $GET(IBBCTYPE)=""
SET MSG=MSG_": Charge Type"
QUIT
End DoDot:1
+8 IF MSG="FILEMAN ERROR"
Begin DoDot:1
+9 IF $DATA(IBB("DIERR"))
SET MSG="FM ERROR: "_$GET(IBB("DIERR","DIERR",1,"TEXT",1))
End DoDot:1
+10 IF MSG="LOCK FAILURE"
SET MSG="Lock request failure on ^IBBAD(373,0)"
+11 SET X=MSG
XECUTE SETLN
+12 SET X=" "
XECUTE SETLN
+13 SET X="Input Parameters"
XECUTE SETLN
+14 SET X="----------------"
XECUTE SETLN
+15 SET X="IBBDFN="_$GET(IBBDFN)
XECUTE SETLN
+16 SET X="IBBARFN="_$GET(IBBARFN)
XECUTE SETLN
+17 SET X="IBBCTYPE="_$GET(IBBCTYPE)
XECUTE SETLN
+18 SET X="IBBUCID="_$GET(IBBUCID)
XECUTE SETLN
+19 IF $DATA(IBBFT1)>1
Begin DoDot:1
+20 SET J=0
FOR
SET J=$ORDER(IBBFT1(J))
if 'J
QUIT
SET X="IBBFT1("_J_")="_IBBFT1(J)
XECUTE SETLN
End DoDot:1
+21 IF $DATA(IBBPR1)>1
Begin DoDot:1
+22 SET J=0
FOR
SET J=$ORDER(IBBPR1(J))
if 'J
QUIT
IF J'=11
SET X="IBBPR1("_J_")="_IBBPR1(J)
XECUTE SETLN
+23 IF $GET(IBBPR1(11,1))
SET X="IBBPR1(11,1)="_IBBPR1(11,1)
XECUTE SETLN
+24 IF $GET(IBBPR1(11,2))
SET X="IBBPR1(11,2)="_IBBPR1(11,2)
XECUTE SETLN
End DoDot:1
+25 IF $DATA(IBBDG1)>1
Begin DoDot:1
+26 SET J=0
FOR
SET J=$ORDER(IBBDG1(J))
if 'J
QUIT
SET J1=0
FOR
SET J1=$ORDER(IBBDG1(J,J1))
if 'J1
QUIT
SET X="IBBDG1("_J_","_J1_")="_IBBDG1(J,J1)
XECUTE SETLN
End DoDot:1
+27 IF $DATA(IBBZCL)>1
Begin DoDot:1
+28 SET J=0
FOR
SET J=$ORDER(IBBZCL(J))
if 'J
QUIT
SET J1=0
FOR
SET J1=$ORDER(IBBZCL(J,J1))
if 'J1
QUIT
SET X="IBBZCL("_J_","_J1_")="_IBBZCL(J,J1)
XECUTE SETLN
End DoDot:1
+29 IF $DATA(IBBRXE)>1
Begin DoDot:1
+30 SET J=0
FOR
SET J=$ORDER(IBBRXE(J))
if 'J
QUIT
SET X="IBBRXE("_J_")="_IBBRXE(J)
XECUTE SETLN
End DoDot:1
+31 IF $GET(IBBORIEN)
SET X="IBBORIEN="_IBBORIEN
XECUTE SETLN
+32 IF $DATA(IBBPROS)>1
Begin DoDot:1
+33 SET J=0
FOR
SET J=$ORDER(IBBPROS(J))
if 'J
QUIT
SET X="IBBPROS("_J_")="_IBBPROS(J)
XECUTE SETLN
End DoDot:1
+34 DO MAIL
+35 QUIT
+36 ;
MAIL ;send error message to mail group
+1 NEW MMGROUP,IENS,XMY,XMSUB,XMDUZ,XMTEXT,XMZ
+2 SET XMSUB="IBB CHARGE FAILURE at "_$$NOW^XLFDT()
SET XMDUZ=.5
+3 SET MMGROUP=$PIECE($GET(^IBBAS(372,1,0)),U,6)
+4 IF MMGROUP
Begin DoDot:1
+5 SET IENS=MMGROUP_","
+6 SET MMGROUP=$$GET1^DIQ(3.8,IENS,.01)
+7 SET XMY("G."_MMGROUP_"@"_^XMB("NETNAME"))=""
End DoDot:1
+8 SET XMTEXT="^TMP(""PFSS CHG ERROR"",$J,"
+9 DO ^XMD
+10 KILL ^TMP("PFSS CHG ERROR",$JOB)
+11 QUIT
