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