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

IBOSCDC.m

Go to the documentation of this file. 
  1. IBOSCDC ;ALB/BNT - SERVICE CONNECTED DETERMINATION CHANGE REPORT ;10/04/07
  1.  ;;2.0;INTEGRATED BILLING;**384,435**;21-MAR-94;Build 27
  1.  ;;Per VHA Directive 2004-038, this routine should not be modified.
  1.  ;
  1. SCR ; -- Main Entry for report.
  1.  N IBCTY,IBPTY,IBSD,IBDFN,Y,DUOUT,DTOUT,DIC
  1.  S IBDFN=0
  1.  S IBCTY=$$CTYPE() Q:IBCTY=U  I IBCTY="S" S IBCTY="Y"
  1.  S IBSD=$$ATIME() Q:IBSD=U
  1. PTP S IBPTY=$$PTYPE() Q:IBPTY=U
  1.  I IBPTY="P" D
  1.  . S DIC="^DPT(",DIC(0)="AEMNQ",DIC("A")="Select Patient: " D ^DIC
  1.  . I (Y=-1)!$D(DUOUT)!$D(DTOUT) G PTP
  1.  . S IBDFN=$P(Y,U)
  1.  D DEV("RUN^IBOSCDC","      SERVICE CONNECTED STATUS CHANGES",IBDFN)
  1.  Q
  1.  ;
  1.  ;Process Report
  1. RUN ;
  1.  S REF=$NA(^TMP($J,"IBSCDC"))
  1.  K @REF
  1.  U IO
  1.  D REPORT
  1.  D ^%ZISC
  1.  S:$D(ZTQUEUED) ZTREQ="@" K @REF,REF
  1.  I $E(IOST,1,2)="C-" S DIR(0)="E" D ^DIR K DIR
  1.  Q
  1.  ;
  1. REPORT ;
  1.  N IBSCDFN,IBRXNUM,IBRXFIL,PTNM,PTLN1,PTLN2,IBQUIT,IBOSCNT,IBFRST,IBOSCDC,IBRXD,IBP
  1.  S (IBP,IBSCDFN,IBQUIT,IBOSCNT)=0,IBFRST=1
  1.  S IBN=IBN_" for period "_$$FMTE^XLFDT(IBSD,"2P")_" - "_$$FMTE^XLFDT(DT,"2P")
  1.  ; Write the Header
  1.  D HDR(IBN)
  1.  ; Get Data for specific patient
  1.  I IBPTY="P" D  Q:IBQUIT
  1.  . I '$$PTSRCH(IBDFN,IBSD,IBCTY,.IBOSCDC) W !,"No matching SC changes for patient "_$$PATINF^IBOSCDC1(IBDFN,30) S IBQUIT=1 Q
  1.  . D COLLECT^IBOSCDC1(IBDFN,IBSD)
  1.  . I '$D(@REF@(IBDFN)) W !,"No matching Prescriptions found for patient "_$$PATINF^IBOSCDC1(IBDFN,30) S IBQUIT=1 Q
  1.  ; Get Data for all patients
  1.  I IBPTY="A" D  Q:IBQUIT
  1.  . D GETALLPT(IBCTY,IBSD,.IBOSCDC)
  1.  . I '$D(IBOSCDC) W !,"No patients with SC changes found" S IBQUIT=1 Q
  1.  ; Check all patients for Pharmacy data
  1.  F  S IBSCDFN=$O(IBOSCDC(IBSCDFN)) Q:IBSCDFN=""  D  Q:IBQUIT
  1.  . D COLLECT^IBOSCDC1(IBSCDFN,IBSD)
  1.  . I '$D(@REF@(IBSCDFN)) Q
  1.  . ;Get Patient Name and last 4 SSN
  1.  . S PTNM=$$PATINF^IBOSCDC1(IBSCDFN,23)
  1.  . ;Get first line of Patient data
  1.  . S PTLN1=$$GETENRL($P($G(IBOSCDC(IBSCDFN)),U,1))
  1.  . ; Get second line of patient data
  1.  . S PTLN2=$$GETENRL($P($G(IBOSCDC(IBSCDFN)),U,2))
  1.  . I 'IBFRST W !!
  1.  . ;Write the first Patient line
  1.  . D WPTLINE(PTNM,$P(PTLN1,U),$P(PTLN1,U,2),$P(PTLN1,U,3),$P(PTLN1,U,4),$P(PTLN1,U,5)) Q:IBQUIT
  1.  . ;Write the second Patient line
  1.  . D WPTLINE("",$P(PTLN2,U),$P(PTLN2,U,2),$P(PTLN2,U,3),$P(PTLN2,U,4),$P(PTLN2,U,5))
  1.  . S (IBFRST)=0
  1.  . F  S IBOSCNT=$O(@REF@(IBSCDFN,IBOSCNT)) Q:IBOSCNT=""  D
  1.  . . S IBRXD=@REF@(IBSCDFN,IBOSCNT)
  1.  . . ;Write the RX data
  1.  . . D WRXLINE($P(IBRXD,U),$P(IBRXD,U,2),$P(IBRXD,U,3),$P(IBRXD,U,4),$P(IBRXD,U,5),$P(IBRXD,U,6),$P(IBRXD,U,7))
  1.  . . ;Increment counter
  1.  . . S IBFRST=1
  1.  I 'IBFRST W "No data available for report"
  1.  Q
  1.  ;
  1.  ;Get Service Connected Change type value
  1.  ;Returns:
  1.  ;(S = SC - NSC, N = NCS - SC, B = Both)
  1. CTYPE() ;
  1.  N DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
  1.  S DIR(0)="S^S:SC to NSC;N:NSC to SC;B:Both"
  1.  S DIR("A")="Select Change Type or (B)oth",DIR("B")="B"
  1.  D ^DIR
  1.  Q Y
  1.  ;
  1.  ;Get Activity Timeframe (Start date) for search
  1.  ;Returns:
  1.  ;Start date in FileMan format
  1. ATIME() ;
  1.  N DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
  1.  W !
  1.  S DIR(0)="N^1:999"
  1.  S DIR("A")="     Select Activity Timeframe Days",DIR("B")=30
  1.  D ^DIR
  1.  Q $$FMADD^XLFDT(DT\1,-$G(Y))
  1.  ;
  1.  ;Get Patient Type value
  1.  ;Returns (P = Patient, A = All)
  1. PTYPE() ;
  1.  N DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
  1.  S DIR(0)="S^P:ONE PATIENT;A:ALL"
  1.  S DIR("A")="Display One (P)atient or (A)ll",DIR("B")="A"
  1.  D ^DIR
  1.  Q Y
  1.  ;
  1.  ;Get All patients with SC Change
  1.  ;Input: 
  1.  ;IBSCDIR = Service Connected change direction
  1.  ;         (Y = SC to NSC, N = NSC to SC, B = Both)
  1.  ;IBSD = Start search date
  1.  ;IBSCARR = Return array passed by ref
  1.  ;Returns:
  1.  ;^TMP(IBSCARR,$J,0)=Number of records found
  1.  ;The first record found is in the 1 node
  1.  ;^TMP(IBSCARR,$J,IBDFN,1)=File 27.11 IEN
  1.  ;The last record found is in the 2 node
  1.  ;^TMP(IBSCARR,$J,IBDFN,2)=File 27.11 IEN
  1. GETALLPT(IBSCDIR,IBSD,IBSCARR) ;
  1.  N IBDFN,IBCNT,IBDGEN
  1.  ; Default start date -30 days
  1.  I IBSD="" S IBSD=$$FMADD^XLFDT(DT\1,-30)
  1.  S (IBDFN,IBCNT)=0
  1.  F  S IBDFN=$O(^DGEN(27.11,"C",IBDFN)) Q:IBDFN=""  D
  1.  . Q:'$D(^DPT(IBDFN,0))
  1.  . I $$PTSRCH(IBDFN,IBSD,IBSCDIR,.IBDGEN) D
  1.  . . S IBCNT=IBCNT+1,IBSCARR(0)=IBCNT
  1.  . . S IBSCARR(IBDFN)=IBDGEN(IBDFN)
  1.  Q
  1.  ;
  1.  ;This function searches for an SC change in Patient Enrollment for a patient
  1.  ;during a specified date range.
  1.  ;Input:
  1.  ;IBDFN = Patient DFN
  1.  ;IBSD  = Start date to begin search
  1.  ;IBSCDIR = Service Connected change direction
  1.  ;          (Y = SC to NSC, N = NSC to SC, B = Both)
  1.  ;IBSCARR = Return array passed by ref
  1.  ;Returns:
  1.  ;IBSCARR(DFN)=DGEN1^DGEN2
  1.  ;WHERE:
  1.  ; DGEN1 = The IEN of first record
  1.  ; DGEN2 = The IEN of second record where a SC change occurred.
  1. PTSRCH(IBDFN,IBSD,IBSCDIR,IBSCARR) ;
  1.  Q:IBDFN="" 0
  1.  N DGENIEN,IBSC,IBSCHNG,SCDIR,EFDT,IBDGEN1
  1.  S (DGENIEN,IBSCHNG)=0,(IBDGEN1,IBSC)=""
  1.  F  S DGENIEN=$O(^DGEN(27.11,"C",IBDFN,DGENIEN)) Q:DGENIEN=""  D 
  1.  . I $D(^DGEN(27.11,DGENIEN,"E")) D
  1.  . . ; Get SERVICE CONNECTED field
  1.  . . S IBSC=$P(^DGEN(27.11,DGENIEN,"E"),U,2) Q:IBSC=""
  1.  . . ; Get EFFECTIVE DATE field
  1.  . . S EFDT=$P(^DGEN(27.11,DGENIEN,0),U,8) Q:EFDT=""
  1.  . . ; Is EFFECTIVE DATE prior to search date? If yes, quit.
  1.  . . I EFDT<IBSD Q
  1.  . . ; First matching SC found
  1.  . . I IBDGEN1="" D  Q
  1.  . . . I (IBSC=IBSCDIR)!(IBSCDIR="B") S IBDGEN1=IBSC S IBSCARR(IBDFN)=DGENIEN Q
  1.  . . ; Matching SC change found. Overwrite previous with latest effective date.
  1.  . . I IBDGEN1'="",IBSC'=IBDGEN1 D  Q
  1.  . . . S $P(IBSCARR(IBDFN),U,2)=DGENIEN
  1.  . . . S IBSCHNG=1
  1.  ; If second match not found, kill the first since no change.
  1.  I 'IBSCHNG K IBSCARR Q 0
  1.  Q 1
  1.  ;
  1.  ;//TODO - Create IA for 27.11
  1.  ;Get Patient Enrollment data
  1.  ;Input: DGENINE = IEN of entry in file 27.11
  1.  ;Returns: EFFECTIVE DATE (.08)^SERVICE CONNECTED (50.02)^ELIGIBILITY CODE (50.01)^SC % (50.03)^ENROLLMENT PRIORITY (.07)
  1. GETENRL(DGENIEN) ;
  1.  N FILE,FIELDS,RETV,X
  1.  Q:'$D(^DGEN(27.11,DGENIEN)) 0
  1.  I $E($L(DGENIEN)+1)'="," S DGENIEN=DGENIEN_","
  1.  S RETV=""
  1.  S FILE=27.11,FIELDS=".08;50.01:50.03;.07"
  1.  D GETS^DIQ(FILE,DGENIEN_",",FIELDS,"IE","X")
  1.  I $D(X) D
  1.  . S RETV=$$FMTE^XLFDT($G(X(27.11,DGENIEN,.08,"I")),"2D")_U_$G(X(27.11,DGENIEN,50.02,"I"))_U_$E($G(X(27.11,DGENIEN,50.01,"E")),1,17)_U_$G(X(27.11,DGENIEN,50.03,"E"))_U_$G(X(27.11,DGENIEN,.07,"E"))
  1.  Q RETV
  1.  ;
  1.  ;Print the report Header
  1.  ;Input: IBX = Report Name
  1. HDR(IBX) ;
  1.  ; IBP is assumed for page #
  1.  Q:IBQUIT
  1.  N DIR,X,Y
  1.  I $E(IOST,1,2)="C-",IBP S DIR(0)="E" D ^DIR K DIR I $D(DIRUT)!($D(DUOUT)) S IBQUIT=1 K DIRUT,DTOUT,DUOUT Q
  1.  S IBP=IBP+1
  1.  W @IOF
  1.  F X=1:1:IOM W "="
  1.  W IBX,?IOM-10,"Page: ",IBP,!
  1.  F X=1:1:IOM W "="
  1.  W !,"Patient",?24,"Effective",?35,"Service",?46,"Eligibility",?65,"SC",?69,"Enrollment",!
  1.  W ?24,"Date",?35,"connected",?46,"code",?65,"%%",?69,"priority",!!
  1.  W ?2,"RX#",?10,"Fill#",?16,"DOS",?25,"Bill#/Status",?39,"ECME#",?52,"Copay/Insurance",?71,"Total Charge",!
  1.  F X=1:1:IOM W "-"
  1.  Q
  1.  ;
  1.  ;Write Patient Line
  1. WPTLINE(PT,EFDT,SC,ELIGCODE,SCPERCNT,ENRLPRIO) ;
  1.  I $Y>(IOSL-4) D HDR(IBN) Q:IBQUIT
  1.  W !,PT,?24,EFDT,?35,SC,?46,ELIGCODE,?65,SCPERCNT,?69,ENRLPRIO
  1.  Q
  1.  ;
  1.  ;Write Prescription Line
  1. WRXLINE(RX,FILL,DOS,BILL,ECME,COPAYINS,AMNT) ;
  1.  I $Y>(IOSL-4) D HDR(IBN) Q:IBQUIT
  1.  W !,?2,RX,?10,FILL,?16,$$FMTE^XLFDT(DOS,"2D"),?25,BILL,?39,ECME,?52,COPAYINS,?71,AMNT
  1.  Q
  1.  ;
  1.  ;Device Selection
  1.  ;Input: IBR = Routine
  1.  ;       IBN = Task name (only used if tasked)
  1.  ;       IBDFN = Patient DFN for single patient, if exists.
  1. DEV(IBR,IBN,IBDFN) ;
  1.  N %ZIS,ZTSK,ZTSAVE,POP,ZTRTN,ZTDESC
  1.  S %ZIS="MQ" D ^%ZIS Q:POP
  1.  I $D(IO("Q")) D  Q
  1.  . S ZTRTN=IBR,ZTDESC=IBN,ZTSAVE("IB*")="",ZTSAVE("IBPT(")=""
  1.  . D ^%ZTLOAD,HOME^%ZIS K IO("Q") W !,"QUEUED TASK #",ZTSK
  1.  U IO
  1.  D @IBR
  1.  Q