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

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