- BPSRPAY ;BHAM ISC/BEE - ECME REPORTS ;11/15/07 14:13
- ;;1.0;E CLAIMS MGMT ENGINE;**1,7,10,15,19**;JUN 2004;Build 18
- ;;Per VA Directive 6402, this routine should not be modified.
- ;
- Q
- ;
- ; Payer Sheet Display Report
- ;
- ;User Prompts
- EN N BPFILE,BPIEN,BPSCR,BPQ
- S BPFILE=9002313.92
- ;
- ;Select Payer Sheet
- I $D(IOF) W @IOF
- W !,"Payer Sheet Detail Report",!!
- S BPIEN=$$BPIEN(BPFILE)
- ;
- ;Check for Valid Entry
- I BPIEN=-1 G EXIT
- ;
- ;Select Device
- I $$DEVICE=-1 G EXIT
- ;
- ;Display Data
- D RUN(BPFILE,BPIEN)
- ;
- ;Exit
- EXIT Q
- ;
- ;Display the Payer Sheet Info
- ;
- RUN(BPFILE,BPIEN) N BPQ
- D PSPRNT(BPFILE,BPIEN)
- Q
- ;
- ; Select a payer sheet
- BPIEN(BPFILE) N DIC,DIRUT,DTOUT,DUOUT,X,Y
- S DIC=$$ROOT^DILFD(BPFILE),DIC(0)="AEMQ"
- S DIC("A")="Select Payer Sheet: "
- D ^DIC
- Q +Y
- ;
- ;Select the output Device
- DEVICE() N %ZIS,ZTSK,ZTRTN,ZTIO,ZTSAVE,ZTDESC,POP,BPQ
- S BPQ=0
- S %ZIS="QM"
- W ! D ^%ZIS
- I POP Q -1
- S BPSCR=$S($E($G(IOST),1,2)="C-":1,1:0)
- I $D(IO("Q")) D S BPQ=-1
- . S ZTRTN="RUN^BPSRPAY(BPFILE,BPIEN)"
- . S ZTIO=ION
- . S ZTSAVE("*")=""
- . S ZTDESC="PAYER SHEET DETAIL REPORT"
- . D ^%ZTLOAD
- . W !,$S($D(ZTSK):"REQUEST QUEUED TASK="_ZTSK,1:"REQUEST CANCELLED")
- . D HOME^%ZIS
- U IO
- Q BPQ
- ;
- ; Payer Sheet Display
- PSPRNT(BPFILE,EN) N BPSHDR,BPIEN,BPPAGE,BPQ,CD,L,N,N1,N2,NAME,NM,NUM,SEG,SP
- N SEGNM,TB,WP,X,X0,X5,ZTREQ
- ;
- ; Build List of Segment Header Names
- D INIT
- ;
- ; Get header information
- S BPIEN=EN_","
- D GETS^DIQ(BPFILE,EN,".01;1.02;1.06;1.14","","BPSHDR")
- ;
- ; Display Header Information
- S BPQ=0,BPPAGE=0,SEGNM=""
- D HDR
- ;
- ; Field Detail Information
- ; Loop through Segments
- S SEG=99 F S SEG=$O(^BPSF(BPFILE,EN,SEG)) Q:+SEG=0!(SEG>300) D I BPQ Q
- . ;
- . ;Make sure there are entries for the segment
- . I $P($G(^BPSF(BPFILE,EN,SEG,0)),U,4)<1 Q
- . ;
- . ; Get and display Segment Name
- . S SEGNM=$G(NAME(SEG))
- . ; Check that we can display the Segment Name and at least one additional field
- . D CHKP(2) I BPQ Q
- . I BPPAGE=1!($Y>5) W !,?((60-$L(SEGNM)+8)/2),"*** ",SEGNM," ***"
- . ; Loop through the Field via the Sequence Number
- . S N=0 F S N=$O(^BPSF(BPFILE,EN,SEG,"B",N)) Q:N="" D I BPQ Q
- .. S N1=0 F S N1=$O(^BPSF(BPFILE,EN,SEG,"B",N,N1)) Q:N1="" D I BPQ Q
- ... ;
- ... ; Get Field Data and Format the Field Number
- ... S X=$G(^BPSF(BPFILE,EN,SEG,N1,0))
- ... S NUM=$P(X,U,2),SP=$P(X,U,3)
- ... I NUM S X0=$G(^BPSF(9002313.91,NUM,0)),X5=$G(^BPSF(9002313.91,NUM,5))
- ... E S (X0,X5)=""
- ... S NUM=$P(X0,U,1)_"-"_$P(X5,U,1),NM=$P(X0,U,3)
- ... ;
- ... ; Display the field information
- ... D CHKP(1) I BPQ Q
- ... W !,N,?5,NUM,?17,NM,?71,$J(SP,9)
- ... ;
- ... ; If there is special code, display it
- ... I SP="X" S N2=0 F S N2=$O(^BPSF(BPFILE,EN,SEG,N1,1,N2)) Q:N2="" D I BPQ Q
- .... S CD=$G(^BPSF(BPFILE,EN,SEG,N1,1,N2,0))
- .... S TB=19,L=61,WP=0
- .... F D CHKP(1) Q:BPQ W ! D Q:CD=""
- ..... W:N2=1 ?5,"Special Code: "
- ..... W:WP=1 ?12,"<cont>"
- ..... W ?19,$E(CD,1,L)
- ..... S CD=$E(CD,L+1,200) Q:CD=""
- ..... S WP=1
- . I BPQ Q
- .D CHKP(1) Q:BPQ W !
- I 'BPSCR W !,@IOF
- E I 'BPQ D PAUSE2
- I $D(ZTQUEUED) S ZTREQ="@" Q
- D ^%ZISC
- XPRT Q
- ;
- ;Display Report Header
- ;
- HDR S BPPAGE=$G(BPPAGE)+1
- W @IOF
- W "Payer Sheet Detail Report"
- W ?48,"Print Date: "_$E(DT,4,5)_"/"_$E(DT,6,7)_"/"_$E(DT,2,3)
- W " Page:",$J(BPPAGE,3)
- W !,$J("Payer Sheet Name: ",20),$G(BPSHDR(BPFILE,BPIEN,.01))
- W ?40,$J("Version Number: ",20),$G(BPSHDR(BPFILE,BPIEN,1.14))
- I BPPAGE=1 D
- . W !,$J("Status: ",20),$G(BPSHDR(BPFILE,BPIEN,1.06))
- . W ?40,$J("NCPDP Version: ",20),$G(BPSHDR(BPFILE,BPIEN,1.02))
- ;
- ; Display subheader
- W !!,"Seq",?5,"Field",?17,"Field Name",?71,"Proc Mode"
- W !,"---",?5,"-----",?17,"----------",?71,"---------"
- I $G(SEGNM)]"" W !,?((60-$L(SEGNM)+8)/2),"*** ",SEGNM," ***"
- Q
- ;
- ;Check for End of Page
- ;
- ; Input variable -> BPLINES - Number of lines from bottom
- ; CONT - 0 = New Entry, 1 = Continue Entry
- ;
- CHKP(BPLINES) S BPLINES=BPLINES+1
- I $G(BPSCR) S BPLINES=BPLINES+3
- I $Y>(IOSL-BPLINES) D:$G(BPSCR) PAUSE Q:$G(BPQ) 0 D HDR Q 1
- Q 0
- ;
- PAUSE ;
- N X
- U IO(0)
- R !!,"Press RETURN to continue, '^' to exit: ",X:DTIME
- I '$T S X="^"
- I X["^" S BPQ=1
- U IO
- Q
- ;
- PAUSE2 ;
- N X
- U IO(0)
- R !,"Press RETURN to continue: ",X:DTIME
- U IO
- Q
- ;
- INIT ; Create local array of segment header names
- S NAME(100)="Transaction Header Segment",NAME(110)="Patient Segment"
- S NAME(120)="Insurance Segment",NAME(130)="Claim Segment"
- S NAME(140)="Pharmacy Provider Segment",NAME(150)="Prescriber Segment"
- S NAME(160)="COB/Other Payments Segment",NAME(170)="Workers' Compensation Segment"
- S NAME(180)="DUR/PPS Segment",NAME(190)="Pricing Segment"
- S NAME(200)="Coupon Segment",NAME(210)="Compound Segment"
- S NAME(220)="Prior Authorization Segment",NAME(230)="Clinical Segment"
- S NAME(240)="Additional Documentation Segment",NAME(250)="Facility Segment"
- S NAME(260)="Narrative Segment"
- ; New segments added - BPS*1*15
- S NAME(270)="Purchaser Segment"
- S NAME(280)="Service Provider Segment"
- ; New segments added - BPS*1*19
- S NAME(290)="Intermediary Segment"
- S NAME(300)="Last Known 4Rx Segment"
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HBPSRPAY 5254 printed Feb 18, 2025@23:18:57 Page 2
- BPSRPAY ;BHAM ISC/BEE - ECME REPORTS ;11/15/07 14:13
- +1 ;;1.0;E CLAIMS MGMT ENGINE;**1,7,10,15,19**;JUN 2004;Build 18
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ;
- +4 QUIT
- +5 ;
- +6 ; Payer Sheet Display Report
- +7 ;
- +8 ;User Prompts
- EN NEW BPFILE,BPIEN,BPSCR,BPQ
- +1 SET BPFILE=9002313.92
- +2 ;
- +3 ;Select Payer Sheet
- +4 IF $DATA(IOF)
- WRITE @IOF
- +5 WRITE !,"Payer Sheet Detail Report",!!
- +6 SET BPIEN=$$BPIEN(BPFILE)
- +7 ;
- +8 ;Check for Valid Entry
- +9 IF BPIEN=-1
- GOTO EXIT
- +10 ;
- +11 ;Select Device
- +12 IF $$DEVICE=-1
- GOTO EXIT
- +13 ;
- +14 ;Display Data
- +15 DO RUN(BPFILE,BPIEN)
- +16 ;
- +17 ;Exit
- EXIT QUIT
- +1 ;
- +2 ;Display the Payer Sheet Info
- +3 ;
- RUN(BPFILE,BPIEN) NEW BPQ
- +1 DO PSPRNT(BPFILE,BPIEN)
- +2 QUIT
- +3 ;
- +4 ; Select a payer sheet
- BPIEN(BPFILE) NEW DIC,DIRUT,DTOUT,DUOUT,X,Y
- +1 SET DIC=$$ROOT^DILFD(BPFILE)
- SET DIC(0)="AEMQ"
- +2 SET DIC("A")="Select Payer Sheet: "
- +3 DO ^DIC
- +4 QUIT +Y
- +5 ;
- +6 ;Select the output Device
- DEVICE() NEW %ZIS,ZTSK,ZTRTN,ZTIO,ZTSAVE,ZTDESC,POP,BPQ
- +1 SET BPQ=0
- +2 SET %ZIS="QM"
- +3 WRITE !
- DO ^%ZIS
- +4 IF POP
- QUIT -1
- +5 SET BPSCR=$SELECT($EXTRACT($GET(IOST),1,2)="C-":1,1:0)
- +6 IF $DATA(IO("Q"))
- Begin DoDot:1
- +7 SET ZTRTN="RUN^BPSRPAY(BPFILE,BPIEN)"
- +8 SET ZTIO=ION
- +9 SET ZTSAVE("*")=""
- +10 SET ZTDESC="PAYER SHEET DETAIL REPORT"
- +11 DO ^%ZTLOAD
- +12 WRITE !,$SELECT($DATA(ZTSK):"REQUEST QUEUED TASK="_ZTSK,1:"REQUEST CANCELLED")
- +13 DO HOME^%ZIS
- End DoDot:1
- SET BPQ=-1
- +14 USE IO
- +15 QUIT BPQ
- +16 ;
- +17 ; Payer Sheet Display
- PSPRNT(BPFILE,EN) NEW BPSHDR,BPIEN,BPPAGE,BPQ,CD,L,N,N1,N2,NAME,NM,NUM,SEG,SP
- +1 NEW SEGNM,TB,WP,X,X0,X5,ZTREQ
- +2 ;
- +3 ; Build List of Segment Header Names
- +4 DO INIT
- +5 ;
- +6 ; Get header information
- +7 SET BPIEN=EN_","
- +8 DO GETS^DIQ(BPFILE,EN,".01;1.02;1.06;1.14","","BPSHDR")
- +9 ;
- +10 ; Display Header Information
- +11 SET BPQ=0
- SET BPPAGE=0
- SET SEGNM=""
- +12 DO HDR
- +13 ;
- +14 ; Field Detail Information
- +15 ; Loop through Segments
- +16 SET SEG=99
- FOR
- SET SEG=$ORDER(^BPSF(BPFILE,EN,SEG))
- if +SEG=0!(SEG>300)
- QUIT
- Begin DoDot:1
- +17 ;
- +18 ;Make sure there are entries for the segment
- +19 IF $PIECE($GET(^BPSF(BPFILE,EN,SEG,0)),U,4)<1
- QUIT
- +20 ;
- +21 ; Get and display Segment Name
- +22 SET SEGNM=$GET(NAME(SEG))
- +23 ; Check that we can display the Segment Name and at least one additional field
- +24 DO CHKP(2)
- IF BPQ
- QUIT
- +25 IF BPPAGE=1!($Y>5)
- WRITE !,?((60-$LENGTH(SEGNM)+8)/2),"*** ",SEGNM," ***"
- +26 ; Loop through the Field via the Sequence Number
- +27 SET N=0
- FOR
- SET N=$ORDER(^BPSF(BPFILE,EN,SEG,"B",N))
- if N=""
- QUIT
- Begin DoDot:2
- +28 SET N1=0
- FOR
- SET N1=$ORDER(^BPSF(BPFILE,EN,SEG,"B",N,N1))
- if N1=""
- QUIT
- Begin DoDot:3
- +29 ;
- +30 ; Get Field Data and Format the Field Number
- +31 SET X=$GET(^BPSF(BPFILE,EN,SEG,N1,0))
- +32 SET NUM=$PIECE(X,U,2)
- SET SP=$PIECE(X,U,3)
- +33 IF NUM
- SET X0=$GET(^BPSF(9002313.91,NUM,0))
- SET X5=$GET(^BPSF(9002313.91,NUM,5))
- +34 IF '$TEST
- SET (X0,X5)=""
- +35 SET NUM=$PIECE(X0,U,1)_"-"_$PIECE(X5,U,1)
- SET NM=$PIECE(X0,U,3)
- +36 ;
- +37 ; Display the field information
- +38 DO CHKP(1)
- IF BPQ
- QUIT
- +39 WRITE !,N,?5,NUM,?17,NM,?71,$JUSTIFY(SP,9)
- +40 ;
- +41 ; If there is special code, display it
- +42 IF SP="X"
- SET N2=0
- FOR
- SET N2=$ORDER(^BPSF(BPFILE,EN,SEG,N1,1,N2))
- if N2=""
- QUIT
- Begin DoDot:4
- +43 SET CD=$GET(^BPSF(BPFILE,EN,SEG,N1,1,N2,0))
- +44 SET TB=19
- SET L=61
- SET WP=0
- +45 FOR
- DO CHKP(1)
- if BPQ
- QUIT
- WRITE !
- Begin DoDot:5
- +46 if N2=1
- WRITE ?5,"Special Code: "
- +47 if WP=1
- WRITE ?12,"<cont>"
- +48 WRITE ?19,$EXTRACT(CD,1,L)
- +49 SET CD=$EXTRACT(CD,L+1,200)
- if CD=""
- QUIT
- +50 SET WP=1
- End DoDot:5
- if CD=""
- QUIT
- End DoDot:4
- IF BPQ
- QUIT
- End DoDot:3
- IF BPQ
- QUIT
- End DoDot:2
- IF BPQ
- QUIT
- +51 IF BPQ
- QUIT
- +52 DO CHKP(1)
- if BPQ
- QUIT
- WRITE !
- End DoDot:1
- IF BPQ
- QUIT
- +53 IF 'BPSCR
- WRITE !,@IOF
- +54 IF '$TEST
- IF 'BPQ
- DO PAUSE2
- +55 IF $DATA(ZTQUEUED)
- SET ZTREQ="@"
- QUIT
- +56 DO ^%ZISC
- XPRT QUIT
- +1 ;
- +2 ;Display Report Header
- +3 ;
- HDR SET BPPAGE=$GET(BPPAGE)+1
- +1 WRITE @IOF
- +2 WRITE "Payer Sheet Detail Report"
- +3 WRITE ?48,"Print Date: "_$EXTRACT(DT,4,5)_"/"_$EXTRACT(DT,6,7)_"/"_$EXTRACT(DT,2,3)
- +4 WRITE " Page:",$JUSTIFY(BPPAGE,3)
- +5 WRITE !,$JUSTIFY("Payer Sheet Name: ",20),$GET(BPSHDR(BPFILE,BPIEN,.01))
- +6 WRITE ?40,$JUSTIFY("Version Number: ",20),$GET(BPSHDR(BPFILE,BPIEN,1.14))
- +7 IF BPPAGE=1
- Begin DoDot:1
- +8 WRITE !,$JUSTIFY("Status: ",20),$GET(BPSHDR(BPFILE,BPIEN,1.06))
- +9 WRITE ?40,$JUSTIFY("NCPDP Version: ",20),$GET(BPSHDR(BPFILE,BPIEN,1.02))
- End DoDot:1
- +10 ;
- +11 ; Display subheader
- +12 WRITE !!,"Seq",?5,"Field",?17,"Field Name",?71,"Proc Mode"
- +13 WRITE !,"---",?5,"-----",?17,"----------",?71,"---------"
- +14 IF $GET(SEGNM)]""
- WRITE !,?((60-$LENGTH(SEGNM)+8)/2),"*** ",SEGNM," ***"
- +15 QUIT
- +16 ;
- +17 ;Check for End of Page
- +18 ;
- +19 ; Input variable -> BPLINES - Number of lines from bottom
- +20 ; CONT - 0 = New Entry, 1 = Continue Entry
- +21 ;
- CHKP(BPLINES) SET BPLINES=BPLINES+1
- +1 IF $GET(BPSCR)
- SET BPLINES=BPLINES+3
- +2 IF $Y>(IOSL-BPLINES)
- if $GET(BPSCR)
- DO PAUSE
- if $GET(BPQ)
- QUIT 0
- DO HDR
- QUIT 1
- +3 QUIT 0
- +4 ;
- PAUSE ;
- +1 NEW X
- +2 USE IO(0)
- +3 READ !!,"Press RETURN to continue, '^' to exit: ",X:DTIME
- +4 IF '$TEST
- SET X="^"
- +5 IF X["^"
- SET BPQ=1
- +6 USE IO
- +7 QUIT
- +8 ;
- PAUSE2 ;
- +1 NEW X
- +2 USE IO(0)
- +3 READ !,"Press RETURN to continue: ",X:DTIME
- +4 USE IO
- +5 QUIT
- +6 ;
- INIT ; Create local array of segment header names
- +1 SET NAME(100)="Transaction Header Segment"
- SET NAME(110)="Patient Segment"
- +2 SET NAME(120)="Insurance Segment"
- SET NAME(130)="Claim Segment"
- +3 SET NAME(140)="Pharmacy Provider Segment"
- SET NAME(150)="Prescriber Segment"
- +4 SET NAME(160)="COB/Other Payments Segment"
- SET NAME(170)="Workers' Compensation Segment"
- +5 SET NAME(180)="DUR/PPS Segment"
- SET NAME(190)="Pricing Segment"
- +6 SET NAME(200)="Coupon Segment"
- SET NAME(210)="Compound Segment"
- +7 SET NAME(220)="Prior Authorization Segment"
- SET NAME(230)="Clinical Segment"
- +8 SET NAME(240)="Additional Documentation Segment"
- SET NAME(250)="Facility Segment"
- +9 SET NAME(260)="Narrative Segment"
- +10 ; New segments added - BPS*1*15
- +11 SET NAME(270)="Purchaser Segment"
- +12 SET NAME(280)="Service Provider Segment"
- +13 ; New segments added - BPS*1*19
- +14 SET NAME(290)="Intermediary Segment"
- +15 SET NAME(300)="Last Known 4Rx Segment"
- +16 QUIT