Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBBAACCT

IBBAACCT.m

Go to the documentation of this file. 
  1. IBBAACCT ;OAK/ELZ - PFSS ACCOUNT API ;15-MAR-2005
  1.  ;;2.0;INTEGRATED BILLING;**286**;21-MAR-94
  1.  ;;Per VHA Directive 10-93-142, this routine should not be modified.
  1.  ;
  1. GET(IBBDFN,IBBARFN,IBBEVENT,IBBAPLR,IBBPV1,IBBPV2,IBBPR1,IBBDG1,IBBZCL,IBBDIV,IBBRAIEN,IBBSURG) ;
  1.  ;
  1.  N IBB,IBBIEN,IBBIENS,IBBERR,IBBVERR,IBBSUBTY,IBBVDEF,FDA,OUT,J,J1,X,Y,X1,X2,X3
  1.  I '$G(IBBDFN)!($G(IBBEVENT)="") Q 0
  1.  I $D(IBBPV1)<10 Q 0
  1.  ;
  1.  ;update account record
  1.  S OUT=0
  1.  I IBBARFN'="" D
  1.  .S IBBIEN=IBBARFN
  1.  .I IBBDFN'=$P($G(^IBBAA(375,IBBIEN,0)),U,3) S OUT=1 Q
  1.  .;visit data
  1.  .I $D(IBBPV1)>1 D
  1.  ..I $G(IBBPV1(44))="" S IBBPV1(44)=$G(IBBPV2(8))
  1.  ..I $P($G(^IBBAA(375,IBBIEN,"PV1")),U,44),$G(IBBPV1(44))'=$P($G(^IBBAA(375,IBBIEN,"PV1")),U,44),$P(^IBBAA(375,IBBIEN,0),U,2) D KAC144^IBBAADD(IBBIEN)
  1.  ..S J=0 F  S J=$O(IBBPV1(J)) Q:'J  S $P(^IBBAA(375,IBBIEN,"PV1"),U,J)=IBBPV1(J)
  1.  ..I $G(IBBPV1(50)) S $P(^IBBAA(375,IBBIEN,"PV1"),U,50)=IBBPV1(50)_";;;;OPP"
  1.  .I $D(IBBPV2)>1 D
  1.  ..S J=0 F  S J=$O(IBBPV2(J)) Q:'J  S $P(^IBBAA(375,IBBIEN,"PV2"),U,J)=IBBPV2(J)
  1.  .;procedure
  1.  .I $D(IBBPR1)>1 D
  1.  ..S J=0,X="" F  S J=$O(IBBPR1(J)) Q:'J  I J'=4 S $P(X,U,J)=IBBPR1(J)
  1.  ..S ^IBBAA(375,IBBIEN,"PR1")=X
  1.  ..I $G(IBBPR1(4))'="" S ^IBBAA(375,IBBIEN,11)=IBBPR1(4)
  1.  .;diagnosis
  1.  .;if any dx sent, remove existing dx
  1.  .I $D(IBBDG1)>1,$G(IBBDG1(1,3))=+$G(IBBDG1(1,3)) K ^IBBAA(375,IBBIEN,"DG1") D DX^IBBAACCT(.IBBDG1,IBBIEN)
  1.  .I $G(IBBDG1(1,4)) S ^IBBAA(375,IBBIEN,12)=IBBDG1(1,4)
  1.  .;classification
  1.  .;if any classification sent, remove existing classification
  1.  .I $D(IBBZCL)>1 D
  1.  ..K ^IBBAA(375,IBBIEN,"ZCL")
  1.  ..S (J,J1)=0 F  S J=$O(IBBZCL(J)) Q:'J  S J1=J1+1,X=J1_U_IBBZCL(J,2)_U_IBBZCL(J,3),^IBBAA(375,IBBIEN,"ZCL",J1,0)=X
  1.  ..S ^IBBAA(375,IBBIEN,"ZCL",0)="^375.05A^"_J1_U_J1
  1.  .;miscellaneous
  1.  .I $G(IBBDIV) S ^IBBAA(375,IBBIEN,13)=IBBDIV
  1.  .I $D(IBBSURG)>1 S ^IBBAA(375,IBBIEN,14)=$G(IBBSURG(1))_U_$G(IBBSURG(2))
  1.  .I $G(IBBRAIEN) S ^IBBAA(375,IBBIEN,15)=$G(IBBRAIEN)
  1.  .I $G(IBBSURG(1)) S $P(^IBBAA(375,IBBIEN,"PV1"),U,50)=IBBSURG(1)_";;;;SUR"
  1.  I OUT Q 0
  1.  ;
  1.  ;request account reference number
  1.  I IBBARFN="" D
  1.  .I $G(IBBAPLR)'="" D
  1.  ..S IBBAPLR=$E($TR(IBBAPLR,U,";"),1,25)
  1.  ..I IBBAPLR'[";" S IBBAPLR=";"_IBBAPLR
  1.  .L +^IBBAA(375,0):5
  1.  .Q:'$T
  1.  .S IBBIEN=$P(^IBBAA(375,0),U,3)+1,$P(^IBBAA(375,0),U,3)=IBBIEN
  1.  .L -^IBBAA(375,0)
  1.  .S ^IBBAA(375,IBBIEN,0)=IBBIEN
  1.  .S IBBIENS=IBBIEN_","
  1.  .S IBBERR="IBB(""DIERR"")"
  1.  .S FDA(375,IBBIENS,.02)="G"
  1.  .S FDA(375,IBBIENS,.03)=IBBDFN
  1.  .S FDA(375,IBBIENS,.04)=$G(IBBAPLR)
  1.  .D FILE^DIE("","FDA",IBBERR)
  1.  .Q:$D(IBB("DIERR"))
  1.  .S IBBARFN=IBBIEN
  1.  .;visit data
  1.  .I $D(IBBPV1)>1 D
  1.  ..I $G(IBBPV1(44))="" S IBBPV1(44)=$G(IBBPV2(8))
  1.  ..S J=0,X="" F  S J=$O(IBBPV1(J)) Q:'J  S $P(X,U,J)=IBBPV1(J)
  1.  ..S ^IBBAA(375,IBBIEN,"PV1")=X
  1.  ..I $G(IBBPV1(50)) S $P(^IBBAA(375,IBBIEN,"PV1"),U,50)=IBBPV1(50)_";;;;OPP"
  1.  ..I $G(IBBPV1(3))="FEE BASIS" D
  1.  ...S IBBPV1(44)=$P($G(IBBPV1(44)),".",1)
  1.  ...S $P(^IBBAA(375,IBBIEN,"PV1"),U,3)="",$P(^("PV1"),U,44)=IBBPV1(44)
  1.  ...S ^IBBAA(375,IBBIEN,16)=IBBPV1(3)
  1.  .I $D(IBBPV2)>1 D
  1.  ..S J=0,X="" F  S J=$O(IBBPV2(J)) Q:'J  S $P(X,U,J)=IBBPV2(J)
  1.  ..S ^IBBAA(375,IBBIEN,"PV2")=X
  1.  .;procedure
  1.  .I $D(IBBPR1)>1 D
  1.  ..I $D(IBBPR1(4)) S ^IBBAA(375,IBBIEN,11)=IBBPR1(4)
  1.  ..S J=0,X="" F  S J=$O(IBBPR1(J)) Q:'J  I J'=4 S $P(X,U,J)=IBBPR1(J)
  1.  ..S ^IBBAA(375,IBBIEN,"PR1")=X
  1.  .;diagnosis
  1.  .I $D(IBBDG1)>1 D
  1.  ..I $D(IBBDG1(1,4)) S ^IBBAA(375,IBBIEN,12)=IBBDG1(1,4)
  1.  ..I $G(IBBDG1(1,3))=+$G(IBBDG1(1,3)) D DX^IBBAACCT(.IBBDG1,IBBIEN)
  1.  .;classification
  1.  .I $D(IBBZCL)>1 D
  1.  ..S (J,J1)=0 F  S J=$O(IBBZCL(J)) Q:'J  S J1=J1+1,X=J1_U_IBBZCL(J,2)_U_IBBZCL(J,3),^IBBAA(375,IBBIEN,"ZCL",J1,0)=X
  1.  ..S ^IBBAA(375,IBBIEN,"ZCL",0)="^375.05A^"_J1_U_J1
  1.  .;miscellaneous
  1.  .I $G(IBBDIV) S ^IBBAA(375,IBBIEN,13)=IBBDIV
  1.  .I $D(IBBSURG)>1 S ^IBBAA(375,IBBIEN,14)=$G(IBBSURG(1))_U_$G(IBBSURG(2))
  1.  .I $G(IBBRAIEN) S ^IBBAA(375,IBBIEN,15)=$G(IBBRAIEN)
  1.  .I $G(IBBSURG(1)) S $P(^IBBAA(375,IBBIEN,"PV1"),U,50)=IBBSURG(1)_";;;;SUR"
  1.  ;
  1.  ;exit here if lock failed or FM error (??)
  1.  I 'IBBARFN Q +IBBARFN
  1.  ;
  1.  ;update event history
  1.  I $L(IBBEVENT)=3 D EVENT^IBBAACCT(IBBARFN,IBBEVENT,"R")
  1.  ;
  1.  ;set xref
  1.  S X1=IBBDFN,X2=$G(IBBPV1(3)),X3=$G(IBBPV1(44)) I X3 D
  1.  .I X2'=+X2 S ^IBBAA(375,"AF",X1,X3,X2,IBBARFN)=""
  1.  .I X2=+X2 S ^IBBAA(375,"AC",X1,X3,X2,IBBARFN)=""
  1.  ;
  1.  ;quit if test patient
  1.  I $$TESTPAT^VADPT(IBBDFN) S $P(^IBBAA(375,IBBIEN,0),U,20)=1 Q IBBARFN
  1.  ;
  1.  ;call VDEF
  1.  S IBBVDEF=0,X=IBBEVENT
  1.  S IBBSUBTY=$S(X="A01":"PFAN",X="A03":"PFDE",X="A04":"PFOA",X="A05":"PFPA",X="A08":"PFUPI",X="A11":"PFCAN",X="A13":"PFCDE",X="A38":"PFCPA",1:"")
  1.  I IBBSUBTY'="" S X=$T(QUEUE^VDEFQM) I X'="" S IBBVDEF=$$QUEUE^VDEFQM("ADT^"_IBBEVENT,"SUBTYPE="_IBBSUBTY_"^IEN="_IBBARFN,.IBBVERR,"PFSS OUTBOUND")
  1.  ;
  1.  Q +IBBARFN
  1.  ;
  1. DX(DG1,IEN) ;file diagnosis on subfile #375.04
  1.  N J,IBB,IBBIEN,IBBIENS,IBBERR,FDA
  1.  S J=0 F  S J=$O(DG1(J)) Q:'J  Q:(DG1(J,3)'=+DG1(J,3))  D
  1.  .S IBBIEN(1)=J
  1.  .S IBBIENS="+1,"_IEN_","
  1.  .S IBBERR="IBB(""DIERR"")"
  1.  .S FDA(375.04,IBBIENS,.01)=J
  1.  .S FDA(375.04,IBBIENS,.03)=DG1(J,3)
  1.  .S FDA(375.04,IBBIENS,.06)=$G(DG1(J,6))
  1.  .D UPDATE^DIE("","FDA","IBBIEN",IBBERR)
  1.  Q
  1.  ;
  1. EVENT(IBBARFN,IBBEVENT,IBBREAS,IBBHLMSG) ;update the event history subfile #375.099
  1.  ;
  1.  ;update event history
  1.  N IBB,IBBIEN,IBBIENS,IBBERR,FDA
  1.  Q:'$G(IBBARFN)  Q:$G(IBBEVENT)=""
  1.  S IBBIEN(1)=""
  1.  S IBBIENS="+1,"_IBBARFN_","
  1.  S IBBERR="IBB(""DIERR"")"
  1.  S FDA(375.099,IBBIENS,.01)=$$NOW^XLFDT()
  1.  S FDA(375.099,IBBIENS,.02)=IBBEVENT
  1.  S FDA(375.099,IBBIENS,.03)=$G(IBBREAS)
  1.  S FDA(375.099,IBBIENS,.04)=$G(IBBHLMSG)
  1.  D UPDATE^DIE("","FDA","IBBIEN",IBBERR)
  1.  Q
  1.  ;
  1. EXTNUM(IBBDFN,IBBARFN) ;find external visit number
  1.  N IBBIEN,IBBEXVN,IBBARRY,IBBERR
  1.  S IBBEXVN="",IBBIEN=IBBARFN
  1.  D GETS^DIQ(375,IBBIEN_",",".02;.03","I","IBBARRY","IBBERR")
  1.  I $D(IBBERR("DIERR")) Q IBBEXVN
  1.  I IBBARRY(375,IBBIEN_",",.03,"I")=IBBDFN S IBBEXVN=IBBARRY(375,IBBIEN_",",.02,"I")
  1.  Q IBBEXVN