IBCNRPSM ;DAOU/CMW - Match Test Payer Sheet to a Pharmacy Plan ;10-DEC-2003
;;2.0;INTEGRATED BILLING;**251,435**;21-MAR-94;Build 27
;;Per VHA Directive 2004-038, this routine should not be modified.
;
EN(IBCNSP) ; Main entry point for IBCNR PAYERSHEET MATCH (LIST TEMPLATE)
D EN^VALM("IBCNR PAYERSHEET MATCH")
Q
;
HDR ; Header code
N IBCNS0,IBCNSID,IBCNSNM,IBCNS10,IBCNSPBM,IBCNSBIN,IBCNSPCN,IBCNS3
N IBCNSNST,IBCNSLST,IBCNSHDR,X
S IBCNS0=$G(^IBCNR(366.03,+IBCNSP,0))
S IBCNSID=$P(IBCNS0,"^",1) ;id
S IBCNSNM=$P(IBCNS0,"^",2) ;name
S IBCNS10=$G(^IBCNR(366.03,+IBCNSP,10))
S IBCNSPBM=$P(IBCNS10,"^",1) ;pbm
I IBCNSPBM S IBCNSPBM=$P($G(^IBCNR(366.02,+IBCNSPBM,0)),"^",1) ; pbm name
S IBCNSBIN=$P(IBCNS10,"^",2) ;bin
S IBCNSPCN=$P(IBCNS10,"^",3) ;pcn
S IBCNS3=$G(^IBCNR(366.03,+IBCNSP,3,1,0)) ; appl
S IBCNSNST=$S($P(IBCNS3,"^",2)=0:"Inactive",1:"Active")
S IBCNSLST=$S($P(IBCNS3,"^",3)=0:"Inactive",1:"Active")
; Header Line 1
S IBCNSHDR="PLAN: "
S X=IBCNSID_" - "_IBCNSNM
S VALMHDR(1)=$$SETSTR^VALM1(X,IBCNSHDR,$L(IBCNSHDR)+1,80)
; Header Line 2
S IBCNSHDR="PBM: "_IBCNSPBM
S X=" BIN: "_IBCNSBIN_" PCN: "_IBCNSPCN
S VALMHDR(2)=$$SETSTR^VALM1(X,IBCNSHDR,$L(IBCNSHDR)+1,80)
; Header Line 3
S IBCNSHDR="STATUS: "
S X="National "_IBCNSNST_"/Local "_IBCNSLST
S VALMHDR(3)=$$SETSTR^VALM1(X,IBCNSHDR,$L(IBCNSHDR)+1,80)
Q
;
INIT ; Init variables and list array
N TCODE,IBCNS10,I,TPS,X,NUMBER,PSN
K ^TMP("IBCNR",$J),TCODE
S VALMCNT=0,VALMBG=1
S TCODE(1)="BILLING (B1)"
S TCODE(2)="REVERSAL (B2)"
S TCODE(3)="REBILL (B3)"
S TCODE(4)="ELIGIBILITY (E1)"
S IBCNS10=$G(^IBCNR(366.03,IBCNSP,10))
F I=1:1:4 S TPS=$P(IBCNS10,"^",10+I) D
. ; Set up Index Number
. S VALMCNT=I
. S X=$$SETFLD^VALM1(VALMCNT,"","NUMBER")
. ; Set up Transaction code
. S X=$$SETFLD^VALM1(TCODE(I),X,"TCODE")
. ; Set up the payer sheet name
. I $G(TPS) S PSN=$G(^BPSF(9002313.92,TPS,0))
. I '$G(TPS) S PSN="NOT FOUND"
. S X=$$SETFLD^VALM1(PSN,X,"PSHEET")
. ; Set up temporary array
. S ^TMP("IBCNR",$J,VALMCNT,0)=X
. S ^TMP("IBCNR",$J,"IDX",VALMCNT,VALMCNT)=IBCNSP
Q
;
HELP ; Help code
I $D(X),X'["??" D
. W !,"Possible actions are the following:"
. S X="?" D DISP^XQORM1,PAUSE^VALM1
Q
;
EXIT ; Exit code
K ^TMP("IBCNR",$J),VALMY
D CLEAN^VALM10
Q
;
EXPND ; Expand code
Q
;
SEL ; Add Payer Sheet to Plan
; Get the transaction code
N IBX,IBSEL,IBDR
D S1
I 'IBX Q
; Get the Payer Sheet Name
N DIC,Y,X,DTOUT,DUOUT
N DA,DIE,DR
S DIC="^BPSF(9002313.92,",DIC(0)="AEMZ",DIC("S")="I $P(^(1),U,6)=2"
S DIC("B")=$$GET1^DIQ(366.03,IBSEL,IBDR)
D ^DIC
I +Y<1 W !!,"No Payer Sheet Selected!" D PAUSE^VALM1 Q
; Do the insert
S DA=IBSEL,DIE="^IBCNR(366.03,",DR=IBDR_"////^S X="_+Y
D ^DIE
; Rebuild ListMan screen data
D INIT
Q
;
DEL ; Delete Payer Sheet from Plan
; Get the transaction code
N IBX,IBSEL,IBDR
D S1
I 'IBX Q
; Do the deletion
N DA,DIE,DR
S DA=IBSEL,DIE="^IBCNR(366.03,",DR=IBDR_"///@"
D ^DIE
; Rebuild ListMan screen data
D INIT
Q
;
S1 ; Prompt for transaction code
N VALMY
D FULL^VALM1,EN^VALM2($G(XQORNOD(0)),"S")
; Store transaction code in IBX
S IBX=$O(VALMY(0))
; Set variable to refresh the screen when returning from the action
S VALMBCK="R"
; Display error if not transaction code was picked and exit
I 'IBX W !!,"No Transaction Code Selected!" D PAUSE^VALM1 Q
; Build variables needed for insert or deletion
S IBSEL=+$G(^TMP("IBCNR",$J,"IDX",IBX,IBX))
S IBDR=$S(IBX=1:10.11,IBX=2:10.12,IBX=3:10.13,1:10.14)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNRPSM 3611 printed Oct 16, 2024@18:17:09 Page 2
IBCNRPSM ;DAOU/CMW - Match Test Payer Sheet to a Pharmacy Plan ;10-DEC-2003
+1 ;;2.0;INTEGRATED BILLING;**251,435**;21-MAR-94;Build 27
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
EN(IBCNSP) ; Main entry point for IBCNR PAYERSHEET MATCH (LIST TEMPLATE)
+1 DO EN^VALM("IBCNR PAYERSHEET MATCH")
+2 QUIT
+3 ;
HDR ; Header code
+1 NEW IBCNS0,IBCNSID,IBCNSNM,IBCNS10,IBCNSPBM,IBCNSBIN,IBCNSPCN,IBCNS3
+2 NEW IBCNSNST,IBCNSLST,IBCNSHDR,X
+3 SET IBCNS0=$GET(^IBCNR(366.03,+IBCNSP,0))
+4 ;id
SET IBCNSID=$PIECE(IBCNS0,"^",1)
+5 ;name
SET IBCNSNM=$PIECE(IBCNS0,"^",2)
+6 SET IBCNS10=$GET(^IBCNR(366.03,+IBCNSP,10))
+7 ;pbm
SET IBCNSPBM=$PIECE(IBCNS10,"^",1)
+8 ; pbm name
IF IBCNSPBM
SET IBCNSPBM=$PIECE($GET(^IBCNR(366.02,+IBCNSPBM,0)),"^",1)
+9 ;bin
SET IBCNSBIN=$PIECE(IBCNS10,"^",2)
+10 ;pcn
SET IBCNSPCN=$PIECE(IBCNS10,"^",3)
+11 ; appl
SET IBCNS3=$GET(^IBCNR(366.03,+IBCNSP,3,1,0))
+12 SET IBCNSNST=$SELECT($PIECE(IBCNS3,"^",2)=0:"Inactive",1:"Active")
+13 SET IBCNSLST=$SELECT($PIECE(IBCNS3,"^",3)=0:"Inactive",1:"Active")
+14 ; Header Line 1
+15 SET IBCNSHDR="PLAN: "
+16 SET X=IBCNSID_" - "_IBCNSNM
+17 SET VALMHDR(1)=$$SETSTR^VALM1(X,IBCNSHDR,$LENGTH(IBCNSHDR)+1,80)
+18 ; Header Line 2
+19 SET IBCNSHDR="PBM: "_IBCNSPBM
+20 SET X=" BIN: "_IBCNSBIN_" PCN: "_IBCNSPCN
+21 SET VALMHDR(2)=$$SETSTR^VALM1(X,IBCNSHDR,$LENGTH(IBCNSHDR)+1,80)
+22 ; Header Line 3
+23 SET IBCNSHDR="STATUS: "
+24 SET X="National "_IBCNSNST_"/Local "_IBCNSLST
+25 SET VALMHDR(3)=$$SETSTR^VALM1(X,IBCNSHDR,$LENGTH(IBCNSHDR)+1,80)
+26 QUIT
+27 ;
INIT ; Init variables and list array
+1 NEW TCODE,IBCNS10,I,TPS,X,NUMBER,PSN
+2 KILL ^TMP("IBCNR",$JOB),TCODE
+3 SET VALMCNT=0
SET VALMBG=1
+4 SET TCODE(1)="BILLING (B1)"
+5 SET TCODE(2)="REVERSAL (B2)"
+6 SET TCODE(3)="REBILL (B3)"
+7 SET TCODE(4)="ELIGIBILITY (E1)"
+8 SET IBCNS10=$GET(^IBCNR(366.03,IBCNSP,10))
+9 FOR I=1:1:4
SET TPS=$PIECE(IBCNS10,"^",10+I)
Begin DoDot:1
+10 ; Set up Index Number
+11 SET VALMCNT=I
+12 SET X=$$SETFLD^VALM1(VALMCNT,"","NUMBER")
+13 ; Set up Transaction code
+14 SET X=$$SETFLD^VALM1(TCODE(I),X,"TCODE")
+15 ; Set up the payer sheet name
+16 IF $GET(TPS)
SET PSN=$GET(^BPSF(9002313.92,TPS,0))
+17 IF '$GET(TPS)
SET PSN="NOT FOUND"
+18 SET X=$$SETFLD^VALM1(PSN,X,"PSHEET")
+19 ; Set up temporary array
+20 SET ^TMP("IBCNR",$JOB,VALMCNT,0)=X
+21 SET ^TMP("IBCNR",$JOB,"IDX",VALMCNT,VALMCNT)=IBCNSP
End DoDot:1
+22 QUIT
+23 ;
HELP ; Help code
+1 IF $DATA(X)
IF X'["??"
Begin DoDot:1
+2 WRITE !,"Possible actions are the following:"
+3 SET X="?"
DO DISP^XQORM1
DO PAUSE^VALM1
End DoDot:1
+4 QUIT
+5 ;
EXIT ; Exit code
+1 KILL ^TMP("IBCNR",$JOB),VALMY
+2 DO CLEAN^VALM10
+3 QUIT
+4 ;
EXPND ; Expand code
+1 QUIT
+2 ;
SEL ; Add Payer Sheet to Plan
+1 ; Get the transaction code
+2 NEW IBX,IBSEL,IBDR
+3 DO S1
+4 IF 'IBX
QUIT
+5 ; Get the Payer Sheet Name
+6 NEW DIC,Y,X,DTOUT,DUOUT
+7 NEW DA,DIE,DR
+8 SET DIC="^BPSF(9002313.92,"
SET DIC(0)="AEMZ"
SET DIC("S")="I $P(^(1),U,6)=2"
+9 SET DIC("B")=$$GET1^DIQ(366.03,IBSEL,IBDR)
+10 DO ^DIC
+11 IF +Y<1
WRITE !!,"No Payer Sheet Selected!"
DO PAUSE^VALM1
QUIT
+12 ; Do the insert
+13 SET DA=IBSEL
SET DIE="^IBCNR(366.03,"
SET DR=IBDR_"////^S X="_+Y
+14 DO ^DIE
+15 ; Rebuild ListMan screen data
+16 DO INIT
+17 QUIT
+18 ;
DEL ; Delete Payer Sheet from Plan
+1 ; Get the transaction code
+2 NEW IBX,IBSEL,IBDR
+3 DO S1
+4 IF 'IBX
QUIT
+5 ; Do the deletion
+6 NEW DA,DIE,DR
+7 SET DA=IBSEL
SET DIE="^IBCNR(366.03,"
SET DR=IBDR_"///@"
+8 DO ^DIE
+9 ; Rebuild ListMan screen data
+10 DO INIT
+11 QUIT
+12 ;
S1 ; Prompt for transaction code
+1 NEW VALMY
+2 DO FULL^VALM1
DO EN^VALM2($GET(XQORNOD(0)),"S")
+3 ; Store transaction code in IBX
+4 SET IBX=$ORDER(VALMY(0))
+5 ; Set variable to refresh the screen when returning from the action
+6 SET VALMBCK="R"
+7 ; Display error if not transaction code was picked and exit
+8 IF 'IBX
WRITE !!,"No Transaction Code Selected!"
DO PAUSE^VALM1
QUIT
+9 ; Build variables needed for insert or deletion
+10 SET IBSEL=+$GET(^TMP("IBCNR",$JOB,"IDX",IBX,IBX))
+11 SET IBDR=$SELECT(IBX=1:10.11,IBX=2:10.12,IBX=3:10.13,1:10.14)
+12 QUIT
