- 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 Jan 18, 2025@03:17:41 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