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

IBCIWK ;DSI/JSR - WORKSHEET UTILITY ;6-MAR-2001
 ;;2.0;INTEGRATED BILLING;**161**;21-MAR-94
 ;;Per VHA Directive 10-93-142, this routine should not be modified.
 ;; ** Program Description **
 ; This is the main routine that calls a  ListManager template.
 ; Prior to calling the LM template, data for a specific IBIFN is 
 ; extracted and formatted for LM to display.
 ; This routine is the main routine called  when the user is in
 ; the bill edit screen.  Irrespective of security access IBCIMG is
 ; always called either directly or in-directly.
 ; Parameters
 ;     Call = (0 or 1) This is a flag that determines which ListManager
 ;           Template to call.
 ;       0  indicates that the browse only template should be invoked
 ;       1  indicates that either a Manager or Clerk template will be invoked
 ;          based on security key access.
 ;
EN(CALL) ;enter set up data 
 ; 
 ;
 N DFN,DISYS,IBA2,IBAC,IBAC1,IBAD,IBADD1,IBBNO,IBDT
 N IBCSCPP,IBLINE,IBMO,IBPOPOUT,IBPREV,IBSCNN,IBSR,IBSR1,IBV
 N IBV1,IBVI,IBVO,IBVV,IBX,IBXERR,TYPE
 N IBCIASI,IBCIASN,IBCIBII,IBCIBIL,IBCIBIR,IBCICAR,IBCICLNO,IBCICM1
 N IBCICM2,IBCICMP,IBCICNM,IBCICOD,IBCIDAT,IBCIDOB,IBCIDPT,IBCIERL,IBCIERT,IBCIEVEN,IBCIEVV,IBCIINS
 N IBCILD1,IBCILD2,IBCILEV,IBCINAM,IBCIPAD,IBCIPTI,IBCISER,IBCISEX,IBCISRR,IBCIYYY
 N IBCIZZZ,IBCSCPP,LMBDATE,LMCHARG,LMCPT,LMEDATE,LMLINE,LMMOD,LMPOS,LMTOS,LMUNIT
 N QUITDP,I,X,Y,Z,YARR,DATA,VAERR,XMDUM,XMZ,IB,IBCCCC,IBCIPRV,IBCI345,IBCISSN
 ;
 S QUITDP=1
 F  D LOOP Q:QUITDP=0
 G XIT
 Q
LOOP ;
 K ^TMP("IBCILM",$J)
 S IBCI345=0  ;JSR 6/22/01 Flag to determine when to kill 3,4,5 node
 I CALL=0 D
 . I '$P($G(^IBA(351.9,IBIFN,3)),U,1) S IBCI345=1 D UPDT^IBCIADD1
 . I $G(IBCISNT)=3 M ^TMP("IBCILM",$J)=^TMP("IBCITST",$J)
 . E  M ^TMP("IBCILM",$J)=^IBA(351.9,IBIFN,1)
 . D GDATA
 . D EN^VALM("IBCI CLAIMSMANAGER WK BROWSE")
 I CALL=1 D
 . I '$P($G(^IBA(351.9,IBIFN,3)),U,1) S IBCI345=1 D UPDT^IBCIADD1
 . I '$D(IBCISNT)!($G(IBCISNT)'=3) M ^TMP("IBCILM",$J)=^IBA(351.9,IBIFN,1)
 . D GDATA
 . I '$D(^XUSEC("IBCI CLAIMSMANAGER OVERRIDE",DUZ)) D EN^VALM("IBCI CLAIMSMANAGER CLERK WK")
 . I $D(^XUSEC("IBCI CLAIMSMANAGER OVERRIDE",DUZ)) D EN^VALM("IBCI CLAIMSMANAGER MGR WK")
 I IBCI345 D DELTI^IBCIUT4   ; JSR 6/22/01
 Q
GDATA ; sets
 NEW X,X1,X2,X3,X4,Y
 K IBCIPAD S $P(IBCIPAD," ",79)=""
 S IBCIDAT=$G(^DGCR(399,IBIFN,0))
 S IBCICLNO=$P(IBCIDAT,U,1)_IBCIPAD
 S IBCIPTI=$P(IBCIDAT,U,2)
 I IBCIPTI S IBCIDPT=$G(^DPT(IBCIPTI,0))
 S IBCIDOB=$P(IBCIDPT,U,3)
 S IBCISSN=$P(IBCIDPT,U,9)   ;JSR 6/25/2001
 S Y=IBCIDOB X ^DD("DD")
 S IBCIBIR=Y_IBCIPAD
 S IBCISEX=$P(IBCIDPT,U,2)_IBCIPAD
 S IBCINAM=$P(IBCIDPT,U,1)
 S X=$E(IBCINAM,1,19)_" ("_$E(IBCISSN,6,9)_")",X1=27
 S IBCINAM=$$FILL^IBCIUT2     ; ESG 7/13/01
 S IBCIEVEN=$P(IBCIDAT,U,3)
 S Y=IBCIEVEN X ^DD("DD")
 S IBCIEVV=$E(Y,1,11)
 S IBCIEVV=$TR(IBCIEVV,"@","")
 S IBCIPRV=$P($$RPHY^IBCIUT1(IBIFN),U,1)_IBCIPAD
 S IBCICOD=$$CODER^IBCIUT5(IBIFN)
 S IBCICNM=$P(IBCICOD,U,3)
 S IBCICNM=IBCICNM_IBCIPAD
 S IBCISER=$P(IBCICOD,U,1)
 S IBCISRR=$S(IBCISER="O":"OP",IBCISER="I":"IP",1:"UK")
 S IBCIBII=$$BILLER^IBCIUT5(IBIFN)
 S IBCIBIL=$P(IBCIBII,U,2)
 S IBCIBIL=IBCIBIL_IBCIPAD
 S IBCIASI=$P($G(^IBA(351.9,IBIFN,0)),U,12)
 I IBCIASI S IBCIASN=$P($G(^VA(200,IBCIASI,0)),U,1)
 E  S IBCIASN=IBCIPAD
 S IBCIINS=$$FINDINS^IBCEF1(IBIFN)
 S IBCICAR=""
 S:IBCIINS IBCICAR=$P($G(^DIC(36,IBCIINS,0)),U,1)
 S IBCICAR=IBCICAR_IBCIPAD
 Q
XIT ;
 Q