source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBBACHRG.m@ 1464

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