Ignore:
Timestamp:
Dec 4, 2009, 12:11:15 AM (15 years ago)
Author:
George Lilly
Message:

revised back to 6/30/08 version

Location:
WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS
Files:
210 edited

Legend:

Unmodified
Added
Removed

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBATER.m

    r613 r623  
    1 IBATER  ;LL/ELZ - TRANSFER PRICING PROSTHETICS DRIVER ; 7-APR-2000
    2         ;;2.0;INTEGRATED BILLING;**115,389**;21-MAR-94;Build 6
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5         ; This routine is called by the nightly back ground job.  It will go
    6         ; through the prosthetics file (660) and look for transfer pricing
    7         ; transactions that it has not previously found.  It looks for T-30
    8         ; through T based upon the delivery date. File 660 - dbia #373
    9         ;
    10 EN      ;
    11         I '$P($G(^IBE(350.9,1,10)),"^",5) Q  ; transfer pricing turned off
    12         ;
    13         N IBDT,IBDA
    14         ;
    15         ; date range t-30 to t
    16         S IBDT=$$FMADD^XLFDT(DT,-30)
    17         ;
    18         F  S IBDT=$O(^RMPR(660,"CT",IBDT)) Q:'IBDT!(IBDT>DT)  S IBDA="" F  S IBDA=$O(^RMPR(660,"CT",IBDT,IBDA)) Q:'IBDA  D CHECK
    19         ;
    20         Q
    21         ;
    22 CHECK   ; check if transfer pricing and not already added
    23         ;
    24         N IBDATA,IBDATA1,IBDFN
    25         ;
    26         ; already in file
    27         I $O(^IBAT(351.61,"AD",(IBDA_";RMPR(660,"),0)) Q
    28         ;
    29         ; valid tp patient
    30         S IBDATA=$G(^RMPR(660,+IBDA,0)) Q:IBDATA=""  S IBDATA1=$G(^RMPR(660,+IBDA,1))
    31         S IBDFN=$P(IBDATA,"^",2) Q:'IBDFN  Q:'$$TPP^IBATUTL(IBDFN)
    32         ;
    33         ; checks from RMPRBIL copied 4/7/2000 with mod for patient type removed
    34         I $S('$D(^RMPR(660,IBDA,"AM")):1,$P(IBDATA,"^",9)="":1,$P(IBDATA,"^",12)="":1,$P(IBDATA1,"^",4)="":1,$P(IBDATA,"^",14)="V":1,$P(IBDATA,"^",15)="*":1,1:0) Q
    35         ;
    36         ; now if inpt, must be in 351.67
    37         I $P(^RMPR(660,IBDA,"AM"),"^",3)'=1,$P(^("AM"),"^",3)'=4,'$D(^IBAT(351.67,"B",$P(IBDATA1,"^",4))) Q
    38         ;
    39         Q:'$P(IBDATA,"^",16)  ; no total cost, at least yet
    40         ;
    41 FILE    ; ok transaction needs to be filled in tp files
    42         ;
    43         S IBDATA=$$RMPR^IBATFILE(IBDFN,IBDT,$$PPF^IBATUTL(IBDFN),(IBDA_";RMPR(660,"),,$P(IBDATA,"^",16))
    44         ;
    45         Q
     1IBATER ;LL/ELZ - TRANSFER PRICING PROSTHETICS DRIVER ; 7-APR-2000
     2 ;;2.0;INTEGRATED BILLING;**115**;21-MAR-94
     3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
     4 ;
     5 ; This routine is called by the nightly back ground job.  It will go
     6 ; through the prosthetics file (660) and look for transfer pricing
     7 ; transactions that it has not previously found.  It looks for T-30
     8 ; through T based upon the delivery date. File 660 - dbia #373
     9 ;
     10EN ;
     11 I '$P($G(^IBE(350.9,1,10)),"^",5) Q  ; transfer pricing turned off
     12 ;
     13 N IBDT,IBDA
     14 ;
     15 ; date range t-30 to t
     16 S IBDT=$$FMADD^XLFDT(DT,-30)
     17 ;
     18 F  S IBDT=$O(^RMPR(660,"CT",IBDT)) Q:'IBDT!(IBDT>DT)  S IBDA="" F  S IBDA=$O(^RMPR(660,"CT",IBDT,IBDA)) Q:'IBDA  D CHECK
     19 ;
     20 Q
     21 ;
     22CHECK ; check if transfer pricing and not already added
     23 ;
     24 N IBDATA,IBDFN
     25 ;
     26 ; already in file
     27 I $O(^IBAT(351.61,"AD",(IBDA_";RMPR(660,"),0)) Q
     28 ;
     29 ; valid tp patient
     30 S IBDATA=$G(^RMPR(660,+IBDA,0)) Q:IBDATA=""
     31 S IBDFN=$P(IBDATA,"^",2) Q:'IBDFN  Q:'$$TPP^IBATUTL(IBDFN)
     32 ;
     33 ; checks from RMPRBIL copied 4/7/2000 with mod for patient type removed
     34 I $S('$D(^RMPR(660,IBDA,"AM")):1,$P(IBDATA,"^",9)="":1,$P(IBDATA,"^",12)="":1,$P(IBDATA,"^",6)="":1,$P(IBDATA,"^",14)="V":1,$P(IBDATA,"^",15)="*":1,1:0) Q
     35 ;
     36 ; now if inpt, must be in 351.67
     37 I $P(^RMPR(660,IBDA,"AM"),"^",3)'=1,$P(^("AM"),"^",3)'=4,'$D(^IBAT(351.67,"B",$P(IBDATA,"^",6))) Q
     38 ;
     39 Q:'$P(IBDATA,"^",16)  ; no total cost, at least yet
     40 ;
     41FILE ; ok transaction needs to be filled in tp files
     42 ;
     43 S IBDATA=$$RMPR^IBATFILE(IBDFN,IBDT,$$PPF^IBATUTL(IBDFN),(IBDA_";RMPR(660,"),$P(IBDATA,"^",6),$P(IBDATA,"^",16))
     44 ;
     45 Q

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBATFILE.m

    r613 r623  
    1 IBATFILE        ;LL/ELZ - TRANSFER PRICING FILLING  ; 22-JAN-1999
    2         ;;2.0;INTEGRATED BILLING;**115,389**;21-MAR-94;Build 6
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4 PAT(DA,IBFAC,IBOVER)    ; files patient in transfer pricing returns dfn
    5         Q:'$G(DA) 0
    6         I $D(^IBAT(351.6,DA,0)) Q DA
    7         N DO,DD,DIC,X,DINUM
    8         S DIC="^IBAT(351.6,",DIC(0)="",X=DA,DINUM=DA
    9         S DIC("DR")=".02///"_$$NOW^XLFDT_";.03////"_+$S($G(IBFAC):IBFAC,1:$$PPF^IBATUTL(DA))_";.04///1"_$S($D(IBOVER):";.1////"_+IBOVER,1:"")
    10         D FILE^DICN
    11         Q $S(Y>0:Y,1:0)
    12 UPPPF(DA,PPF)   ; updates a patient's enrolled facility
    13         I '$G(DA)!('$G(PPF))!('$D(^IBAT(351.6,DA))) Q
    14         N DIE,DR
    15         S DIE="^IBAT(351.6,",DR=".03////"_+PPF D ^DIE
    16         Q
    17 ADM(DFN,IBADMDT,IBPREF,IBSOURCE)        ; - files admissions
    18         ; IBADMDT=admission date, IBPREF=enrolled facility
    19         ; IBSOURCE=source (movement ien;DGPM(
    20         I '$G(DFN)!('$G(IBADMDT))!('$G(IBPREF))!($G(IBSOURCE)="") Q 0
    21         Q $$NEW(DFN,IBADMDT,IBPREF,IBSOURCE)
    22 DIS(DA,IBDISDT,IBPTF,IBDISM)    ; - files discharges
    23         ; DA=transaction ien in 351.61, IBDISDT=discharge date
    24         ; IBPTF=ptf pointer, IBDISM=discharge movement pointer
    25         I '$G(DA)!('$G(IBDISDT))!('$G(IBPTF))!('$G(IBDISM)) Q 0
    26         N DIE,DR
    27         S DIE="^IBAT(351.61,"
    28         S DR=".05////C;.1////"_IBDISDT_";1.07////"_IBPTF_";1.08////"_IBDISM
    29         L +^IBAT(351.61,DA):10 I '$T Q "0^Transaction Locked"
    30         D ^DIE L -^IBAT(351.61,DA)
    31         Q DA
    32 DISC(DA)        ; - deletes discharge data
    33         ; DA=transaction ien in 351.61
    34         N DIE,DR Q:'$G(DA) 0
    35         S DIE="^IBAT(351.61,"
    36         S DR=".05////E;.1///@;1.08///@"
    37         L +^IBAT(351.61,DA):10 I '$T Q "0^Transaction Locked"
    38         D ^DIE L -^IBAT(351.61,DA)
    39         Q DA
    40 INPT(IBIEN,IBDRG,IBDRGA,IBLOS,IBHIGH,IBOUT,IBOUTR)      ; - file remaining inpt
    41         ; IBIEN=transaction ien in 351.61, IBDRG=DRG pointer
    42         ; IBDRGA=DRG amount,IBLOS=inpatient LOS,IBHIGH=high trim days
    43         ; IBOUT=outlier days,IBOUTR=outlier rate
    44         I '$G(IBIEN)!('$G(IBLOS))!('$D(IBHIGH))!('$D(IBOUT)) Q 0
    45         N DIE,X,Y,DR
    46         S DIE="^IBAT(351.61,",DA=IBIEN
    47         S DR="1.03////"_IBLOS_";1.04////"_IBHIGH_";1.05////"_IBOUT
    48         S:$G(IBDRG) DR=DR_";1.01///"_IBDRG
    49         S:$G(IBDRGA) DR=DR_";1.02////"_IBDRGA
    50         S:$G(IBOUTR) DR=DR_";1.06////"_IBOUTR
    51         L +^IBAT(351.61,IBIEN):10 I '$T Q "0^Transaction Locked"
    52         D ^DIE,TOTAL^IBATCM(IBIEN) I $P($G(^IBAT(351.61,IBIEN,6)),"^",2) D
    53         . S DR=";.05////P;.13////"_DT D ^DIE
    54         L -^IBAT(351.61,IBIEN)
    55         Q IBIEN
    56 OUT(DFN,IBEDT,IBPREF,IBSOURCE,IBPROC)   ; - files outpatient data
    57         ; DFN=dfn for patient, IBEDT=event date, IBPREF=enrolled facility
    58         ; IBSOURCE=source (outpatient encounter ien;SCE(
    59         ; IBPROC=procedures (by ref in array)
    60         I '$G(DFN)!('$G(IBEDT))!('$G(IBPREF))!($G(IBSOURCE)="") Q 0
    61         N IBIEN,IBX,Y,IBPRICE
    62         S IBIEN=$$NEW(DFN,IBEDT,IBPREF,IBSOURCE) I 'IBIEN Q IBIEN
    63         L +^IBAT(351.61,IBIEN):10 I '$T Q "0^Transaction Locked"
    64         S IBIEN=$$PROC(IBIEN,.IBPROC,.IBPRICE) ; file procedures
    65         I IBIEN<1 L -^IBAT(351.61,IBIEN) Q "0^Unable to file procedures"
    66         S DIE="^IBAT(351.61,",DA=IBIEN
    67         S DR=".1////"_IBEDT_";.05////"_$S($G(IBPRICE):"C",1:"P;.13////"_DT)
    68         D ^DIE,TOTAL^IBATCM(IBIEN) L -^IBAT(351.61,IBIEN)
    69         Q IBIEN
    70 UPDATE(IBIEN,IBPROC)    ; -- updates procedures
    71         ; IBIEN=351.61 ien, IBPROC=procedures by ref like above
    72         Q:'$G(IBIEN) 0
    73         N IBX,IBPRICE,DIE,DA,DR,X,Y
    74         S IBIEN(0)=^IBAT(351.61,IBIEN,0),IBEDT=$P(IBIEN(0),"^",4)
    75         ; if approved, cancel and create a new one
    76         I $P(IBIEN(0),"^",5)="A" D  Q IBIEN
    77         . S IBIEN=$$CANC(IBIEN)
    78         . S IBIEN=$$OUT($P(IBIEN(0),"^",2),IBEDT,$P(IBIEN(0),"^",11),$P(IBIEN(0),"^",12),.IBPROC)
    79         L +^IBAT(351.61,IBIEN):10 I '$T Q "0^Transaction Locked"
    80         ; first clean out procedures there
    81         S IBX=0 F  S IBX=$O(^IBAT(351.61,IBIEN,3,IBX)) Q:IBX<1  S DIK="^IBAT(351.61,"_IBIEN_",3,",DA(1)=IBIEN,DA=IBX D ^DIK
    82         S IBIEN=$$PROC(IBIEN,.IBPROC,.IBPRICE) ; file procedures
    83         I IBIEN<1 L -^IBAT(351.61,IBIEN) Q "0^Unable to file procedures"
    84         S DIE="^IBAT(351.61,",DA=IBIEN
    85         S DR=".1////"_IBEDT_";.05////"_$S($G(IBPRICE):"C",1:"P;.13////"_DT)
    86         D ^DIE,TOTAL^IBATCM(IBIEN) L -^IBAT(351.61,IBIEN)
    87         Q IBIEN
    88 RX(DFN,IBEDT,IBPREF,IBSOURCE,IBDRUG,IBQTY,IBCOST)       ; - files pharmacy data
    89         ; DFN=dfn for patient, IBEDT=event date, IBPREF=enrolled facility
    90         ; IBSOURCE=source (prescription ien;PSRX(;refill #
    91         ; IBDRUG=ien from drug file
    92         ; IBQTY=quantity of drug, IBCOST=drug cost
    93         I '$G(DFN)!('$G(IBEDT))!('$G(IBPREF))!($G(IBSOURCE)="")!('$G(IBDRUG))!('$G(IBQTY)) Q 0
    94         N IBIEN
    95         S IBIEN=$$NEW(DFN,IBEDT,IBPREF,IBSOURCE) I 'IBIEN Q IBIEN
    96         S DIE="^IBAT(351.61,",DA=IBIEN
    97         S DR=".1////"_+IBEDT_";4.01////"_+IBDRUG_";4.02////"_+IBQTY_";.05////"_$S($G(IBCOST):"P;4.03////"_+IBCOST_";.13////"_DT,1:"C")
    98         L +^IBAT(351.61,IBIEN):10 I '$T Q "0^Transaction Locked"
    99         D ^DIE D:$G(IBCOST) TOTAL^IBATCM(IBIEN)
    100         L -^IBAT(351.61,IBIEN)
    101         Q IBIEN
    102         ;
    103 RMPR(DFN,IBEDT,IBPREF,IBSOURCE,IBPROS,IBCOST)   ; - files prost. data
    104         ; DFN=dfn for patient, IBEDT=event date, IBPREF=enrolled facility
    105         ; IBSOURCE=source (prost ien;RMPR(660,
    106         ; IBPROS=ien from file 661 - removed in 389 no longer valid
    107         ; IBCOST=item cost
    108         I '$G(DFN)!('$G(IBEDT))!('$G(IBPREF))!($G(IBSOURCE)="") Q 0
    109         N IBIEN
    110         S IBIEN=$$NEW(DFN,IBEDT,IBPREF,IBSOURCE) I 'IBIEN Q IBIEN
    111         S DIE="^IBAT(351.61,",DA=IBIEN
    112         S DR=".1////"_+IBEDT_";.05////"_$S($G(IBCOST):"P;4.05////"_+IBCOST_";.13////"_DT,1:"C")
    113         L +^IBAT(351.61,IBIEN):10 I '$T Q "0^Transaction Locked"
    114         D ^DIE D:$G(IBCOST) TOTAL^IBATCM(IBIEN)
    115         L -^IBAT(351.61,IBIEN)
    116         Q IBIEN
    117         ;
    118 CANC(DA)        ; - used to cancel any transaction
    119         N DIE,DR,X,Y Q:'$G(DA)
    120         S DIE="^IBAT(351.61,",DR=".05///X" D ^DIE
    121         Q
    122 DEL(DA) ; - used to delete a transaction (only valid for inpatients or rx)
    123         N DIK,DR,X,Y,Z Q:'$G(DA)
    124         S Z=$G(^IBAT(351.61,DA,0)) Q:'Z
    125         Q:$P(Z,"^",12)["SCE("
    126         S DIK="^IBAT(351.61," D ^DIK
    127         Q
    128 NEW(DFN,IBEDT,IBPREF,IBSOURCE)  ; - creates new transaction and returns ien
    129         N IBIEN,IBSITE,DD,DO,DIC,X,Y,DINUM,DLAYGO,DIE,DA,DR
    130         S IBSITE=$$SITE^IBATUTL
    131         L +^IBAT(351.6,DFN):10 I '$T Q "0^Patient file Locked"
    132         L +^IBAT(351.61,0):10 I '$T Q "0^Transaction File Locked"
    133         S IBIEN=$P(^IBAT(351.61,0),"^",3)+1
    134         F IBIEN=IBIEN:1 Q:'$D(^IBAT(351.61,"B",IBSITE_IBIEN))
    135         S DIC="^IBAT(351.61,",DIC(0)="",X=IBSITE_IBIEN,DINUM=IBIEN,DLAYGO=351.61
    136         S DIC("DR")=".02////"_+DFN_";.03////"_+DT_";.04////"_+IBEDT_";.05////E;.09////"_+IBEDT_";.11////"_+IBPREF_";.12////^S X=IBSOURCE"
    137         D FILE^DICN I +Y<1 L -(^IBAT(351.61,0),^IBAT(351.6,DFN)) Q "0^Unable to add new transaction"
    138         S DIE="^IBAT(351.6,",DA=+DFN
    139         S DR=$S(IBSOURCE["DGPM":".05",IBSOURCE["SCE":".06",IBSOURCE["RMPR":".11",1:".07")_"////"_+IBEDT
    140         I $P(^IBAT(351.6,DFN,0),"^",+(DR*100))<IBEDT D ^DIE
    141         L -(^IBAT(351.61,0),^IBAT(351.6,DFN))
    142         Q IBIEN
    143 PROC(IBIEN,IBPROC,IBPRICE)      ; files procedures
    144         N X,Y
    145         S Y=1,IBX=0 F  S IBX=$O(IBPROC(IBX)) Q:IBX=""!(+Y<1)  D
    146         . N DIC,X,DA,DD,DO
    147         . S DIC="^IBAT(351.61,"_IBIEN_",3,",DIC(0)="L"
    148         . S X=IBX,DA(1)=IBIEN
    149         . ;S DIC("P")=$P(^DD(351.61,3,0),"^",2) ; no longer required with fm22
    150         . S DIC("DR")=".02////"_$P(IBPROC(IBX),"^")
    151         . I $P(IBPROC(IBX),"^",2) S DIC("DR")=DIC("DR")_";.03////"_$P(IBPROC(IBX),"^",2)
    152         . E  S IBPRICE=1
    153         . D FILE^DICN
    154         I +Y<1 L -^IBAT(351.61,IBIEN) Q "0^Unable to file procedures"
    155         Q IBIEN
    156 DX(IBIEN,IBPTF) ; - files dx info
    157         Q IBIEN
    158         N IBX,Y S Y=1,IBX="" F  S IBX=$O(IBDX(IBX)) Q:IBX=""!(+Y<1)  D
    159         . N DD,DO,DIC,DINUM,X
    160         . S DIC="^IBAT(351.61,"_IBIEN_",2,",DIC(0)="",X=$P(IBDX(IBX),"^")
    161         . ;S DA(1)=IBIEN,DIC("P")=$P(^DD(351.61,2,0),"^",2) D FILE^DICN
    162         . ; no longer required with fm22
    163         . S DA(1)=IBIEN D FILE^DICN
    164         Q $S(+Y<1:"0^Unable to file diagnosis's",1:IBIEN)
    165         ;
    166 INIT    ; called to possibly initialize the 351.6 file if not done
    167         N IBS,ZTRTN,ZTDESC,ZTIO,ZTSK,X,Y
    168         ;
    169         Q:$O(^IBAT(351.6,0))  ; already populated
    170         ;
    171         ; is Transfer Pricing active or not for any
    172         S IBS=$G(^IBE(350.9,1,10))
    173         I '$P(IBS,"^",2),'$P(IBS,"^",3),'$P(IBS,"^",4),'$P(IBS,"^",5) Q
    174         ;
    175         ; queue off job
    176         W !!,"It appears you have never used Transfer Pricing before.  I need to populate",!,"the Transfer Pricing patient file.  Please select a date/time to do this.",!
    177         S ZTRTN="ADDTP^IBATFILE",ZTDESC="Initializing Transfer Pricing Patient File",ZTIO="" D ^%ZTLOAD
    178         I $G(ZTSK) W !,"Task Queued #",ZTSK
    179         ;
    180         Q
    181 ADDTP   ; Add Transfer Pricing patients to file #351.6
    182         ;
    183         N DFN,IBADM,IBDFN,IBPREF,IBADMDT,IBX
    184         ;
    185         S DFN=0 F  S DFN=$O(^DPT(DFN)) Q:'DFN  D
    186         .;
    187         .S IBDFN=$$TPP^IBATUTL(DFN)
    188         .Q:'IBDFN
    189         .;
    190         .; - see if they are admitted
    191         .S IBADM=$G(^DPT(DFN,.105))
    192         .I IBADM D
    193         ..S IBPREF=+$P($G(^IBAT(351.6,DFN,0)),"^",3)
    194         ..S IBADMDT=+$G(^DGPM(IBADM,0))
    195         ..S IBX=$$ADM(DFN,IBADMDT,IBPREF,IBADM_";DGPM(")
    196         ;
    197         Q
     1IBATFILE ;LL/ELZ - TRANSFER PRICING FILLING  ; 22-JAN-1999
     2 ;;2.0;INTEGRATED BILLING;**115**;21-MAR-94
     3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
     4PAT(DA,IBFAC,IBOVER) ; files patient in transfer pricing returns dfn
     5 Q:'$G(DA) 0
     6 I $D(^IBAT(351.6,DA,0)) Q DA
     7 N DO,DD,DIC,X,DINUM
     8 S DIC="^IBAT(351.6,",DIC(0)="",X=DA,DINUM=DA
     9 S DIC("DR")=".02///"_$$NOW^XLFDT_";.03////"_+$S($G(IBFAC):IBFAC,1:$$PPF^IBATUTL(DA))_";.04///1"_$S($D(IBOVER):";.1////"_+IBOVER,1:"")
     10 D FILE^DICN
     11 Q $S(Y>0:Y,1:0)
     12UPPPF(DA,PPF) ; updates a patient's enrolled facility
     13 I '$G(DA)!('$G(PPF))!('$D(^IBAT(351.6,DA))) Q
     14 N DIE,DR
     15 S DIE="^IBAT(351.6,",DR=".03////"_+PPF D ^DIE
     16 Q
     17ADM(DFN,IBADMDT,IBPREF,IBSOURCE) ; - files admissions
     18 ; IBADMDT=admission date, IBPREF=enrolled facility
     19 ; IBSOURCE=source (movement ien;DGPM(
     20 I '$G(DFN)!('$G(IBADMDT))!('$G(IBPREF))!($G(IBSOURCE)="") Q 0
     21 Q $$NEW(DFN,IBADMDT,IBPREF,IBSOURCE)
     22DIS(DA,IBDISDT,IBPTF,IBDISM) ; - files discharges
     23 ; DA=transaction ien in 351.61, IBDISDT=discharge date
     24 ; IBPTF=ptf pointer, IBDISM=discharge movement pointer
     25 I '$G(DA)!('$G(IBDISDT))!('$G(IBPTF))!('$G(IBDISM)) Q 0
     26 N DIE,DR
     27 S DIE="^IBAT(351.61,"
     28 S DR=".05////C;.1////"_IBDISDT_";1.07////"_IBPTF_";1.08////"_IBDISM
     29 L +^IBAT(351.61,DA):10 I '$T Q "0^Transaction Locked"
     30 D ^DIE L -^IBAT(351.61,DA)
     31 Q DA
     32DISC(DA) ; - deletes discharge data
     33 ; DA=transaction ien in 351.61
     34 N DIE,DR Q:'$G(DA) 0
     35 S DIE="^IBAT(351.61,"
     36 S DR=".05////E;.1///@;1.08///@"
     37 L +^IBAT(351.61,DA):10 I '$T Q "0^Transaction Locked"
     38 D ^DIE L -^IBAT(351.61,DA)
     39 Q DA
     40INPT(IBIEN,IBDRG,IBDRGA,IBLOS,IBHIGH,IBOUT,IBOUTR) ; - file remaining inpt
     41 ; IBIEN=transaction ien in 351.61, IBDRG=DRG pointer
     42 ; IBDRGA=DRG amount,IBLOS=inpatient LOS,IBHIGH=high trim days
     43 ; IBOUT=outlier days,IBOUTR=outlier rate
     44 I '$G(IBIEN)!('$G(IBLOS))!('$D(IBHIGH))!('$D(IBOUT)) Q 0
     45 N DIE,X,Y,DR
     46 S DIE="^IBAT(351.61,",DA=IBIEN
     47 S DR="1.03////"_IBLOS_";1.04////"_IBHIGH_";1.05////"_IBOUT
     48 S:$G(IBDRG) DR=DR_";1.01///"_IBDRG
     49 S:$G(IBDRGA) DR=DR_";1.02////"_IBDRGA
     50 S:$G(IBOUTR) DR=DR_";1.06////"_IBOUTR
     51 L +^IBAT(351.61,IBIEN):10 I '$T Q "0^Transaction Locked"
     52 D ^DIE,TOTAL^IBATCM(IBIEN) I $P($G(^IBAT(351.61,IBIEN,6)),"^",2) D
     53 . S DR=";.05////P;.13////"_DT D ^DIE
     54 L -^IBAT(351.61,IBIEN)
     55 Q IBIEN
     56OUT(DFN,IBEDT,IBPREF,IBSOURCE,IBPROC) ; - files outpatient data
     57 ; DFN=dfn for patient, IBEDT=event date, IBPREF=enrolled facility
     58 ; IBSOURCE=source (outpatient encounter ien;SCE(
     59 ; IBPROC=procedures (by ref in array)
     60 I '$G(DFN)!('$G(IBEDT))!('$G(IBPREF))!($G(IBSOURCE)="") Q 0
     61 N IBIEN,IBX,Y,IBPRICE
     62 S IBIEN=$$NEW(DFN,IBEDT,IBPREF,IBSOURCE) I 'IBIEN Q IBIEN
     63 L +^IBAT(351.61,IBIEN):10 I '$T Q "0^Transaction Locked"
     64 S IBIEN=$$PROC(IBIEN,.IBPROC,.IBPRICE) ; file procedures
     65 I IBIEN<1 L -^IBAT(351.61,IBIEN) Q "0^Unable to file procedures"
     66 S DIE="^IBAT(351.61,",DA=IBIEN
     67 S DR=".1////"_IBEDT_";.05////"_$S($G(IBPRICE):"C",1:"P;.13////"_DT)
     68 D ^DIE,TOTAL^IBATCM(IBIEN) L -^IBAT(351.61,IBIEN)
     69 Q IBIEN
     70UPDATE(IBIEN,IBPROC) ; -- updates procedures
     71 ; IBIEN=351.61 ien, IBPROC=procedures by ref like above
     72 Q:'$G(IBIEN) 0
     73 N IBX,IBPRICE,DIE,DA,DR,X,Y
     74 S IBIEN(0)=^IBAT(351.61,IBIEN,0),IBEDT=$P(IBIEN(0),"^",4)
     75 ; if approved, cancel and create a new one
     76 I $P(IBIEN(0),"^",5)="A" D  Q IBIEN
     77 . S IBIEN=$$CANC(IBIEN)
     78 . S IBIEN=$$OUT($P(IBIEN(0),"^",2),IBEDT,$P(IBIEN(0),"^",11),$P(IBIEN(0),"^",12),.IBPROC)
     79 L +^IBAT(351.61,IBIEN):10 I '$T Q "0^Transaction Locked"
     80 ; first clean out procedures there
     81 S IBX=0 F  S IBX=$O(^IBAT(351.61,IBIEN,3,IBX)) Q:IBX<1  S DIK="^IBAT(351.61,"_IBIEN_",3,",DA(1)=IBIEN,DA=IBX D ^DIK
     82 S IBIEN=$$PROC(IBIEN,.IBPROC,.IBPRICE) ; file procedures
     83 I IBIEN<1 L -^IBAT(351.61,IBIEN) Q "0^Unable to file procedures"
     84 S DIE="^IBAT(351.61,",DA=IBIEN
     85 S DR=".1////"_IBEDT_";.05////"_$S($G(IBPRICE):"C",1:"P;.13////"_DT)
     86 D ^DIE,TOTAL^IBATCM(IBIEN) L -^IBAT(351.61,IBIEN)
     87 Q IBIEN
     88RX(DFN,IBEDT,IBPREF,IBSOURCE,IBDRUG,IBQTY,IBCOST) ; - files pharmacy data
     89 ; DFN=dfn for patient, IBEDT=event date, IBPREF=enrolled facility
     90 ; IBSOURCE=source (prescription ien;PSRX(;refill #
     91 ; IBDRUG=ien from drug file
     92 ; IBQTY=quantity of drug, IBCOST=drug cost
     93 I '$G(DFN)!('$G(IBEDT))!('$G(IBPREF))!($G(IBSOURCE)="")!('$G(IBDRUG))!('$G(IBQTY)) Q 0
     94 N IBIEN
     95 S IBIEN=$$NEW(DFN,IBEDT,IBPREF,IBSOURCE) I 'IBIEN Q IBIEN
     96 S DIE="^IBAT(351.61,",DA=IBIEN
     97 S DR=".1////"_+IBEDT_";4.01////"_+IBDRUG_";4.02////"_+IBQTY_";.05////"_$S($G(IBCOST):"P;4.03////"_+IBCOST_";.13////"_DT,1:"C")
     98 L +^IBAT(351.61,IBIEN):10 I '$T Q "0^Transaction Locked"
     99 D ^DIE D:$G(IBCOST) TOTAL^IBATCM(IBIEN)
     100 L -^IBAT(351.61,IBIEN)
     101 Q IBIEN
     102 ;
     103RMPR(DFN,IBEDT,IBPREF,IBSOURCE,IBPROS,IBCOST) ; - files prost. data
     104 ; DFN=dfn for patient, IBEDT=event date, IBPREF=enrolled facility
     105 ; IBSOURCE=source (prost ien;RMPR(660,
     106 ; IBPROS=ien from file 661
     107 ; IBCOST=item cost
     108 I '$G(DFN)!('$G(IBEDT))!('$G(IBPREF))!($G(IBSOURCE)="")!('$G(IBPROS)) Q 0
     109 N IBIEN
     110 S IBIEN=$$NEW(DFN,IBEDT,IBPREF,IBSOURCE) I 'IBIEN Q IBIEN
     111 S DIE="^IBAT(351.61,",DA=IBIEN
     112 S DR=".1////"_+IBEDT_";4.04////"_+IBPROS_";.05////"_$S($G(IBCOST):"P;4.05////"_+IBCOST_";.13////"_DT,1:"C")
     113 L +^IBAT(351.61,IBIEN):10 I '$T Q "0^Transaction Locked"
     114 D ^DIE D:$G(IBCOST) TOTAL^IBATCM(IBIEN)
     115 L -^IBAT(351.61,IBIEN)
     116 Q IBIEN
     117 ;
     118CANC(DA) ; - used to cancel any transaction
     119 N DIE,DR,X,Y Q:'$G(DA)
     120 S DIE="^IBAT(351.61,",DR=".05///X" D ^DIE
     121 Q
     122DEL(DA) ; - used to delete a transaction (only valid for inpatients or rx)
     123 N DIK,DR,X,Y,Z Q:'$G(DA)
     124 S Z=$G(^IBAT(351.61,DA,0)) Q:'Z
     125 Q:$P(Z,"^",12)["SCE("
     126 S DIK="^IBAT(351.61," D ^DIK
     127 Q
     128NEW(DFN,IBEDT,IBPREF,IBSOURCE) ; - creates new transaction and returns ien
     129 N IBIEN,IBSITE,DD,DO,DIC,X,Y,DINUM,DLAYGO,DIE,DA,DR
     130 S IBSITE=$$SITE^IBATUTL
     131 L +^IBAT(351.6,DFN):10 I '$T Q "0^Patient file Locked"
     132 L +^IBAT(351.61,0):10 I '$T Q "0^Transaction File Locked"
     133 S IBIEN=$P(^IBAT(351.61,0),"^",3)+1
     134 F IBIEN=IBIEN:1 Q:'$D(^IBAT(351.61,"B",IBSITE_IBIEN))
     135 S DIC="^IBAT(351.61,",DIC(0)="",X=IBSITE_IBIEN,DINUM=IBIEN,DLAYGO=351.61
     136 S DIC("DR")=".02////"_+DFN_";.03////"_+DT_";.04////"_+IBEDT_";.05////E;.09////"_+IBEDT_";.11////"_+IBPREF_";.12////^S X=IBSOURCE"
     137 D FILE^DICN I +Y<1 L -(^IBAT(351.61,0),^IBAT(351.6,DFN)) Q "0^Unable to add new transaction"
     138 S DIE="^IBAT(351.6,",DA=+DFN
     139 S DR=$S(IBSOURCE["DGPM":".05",IBSOURCE["SCE":".06",IBSOURCE["RMPR":".11",1:".07")_"////"_+IBEDT
     140 I $P(^IBAT(351.6,DFN,0),"^",+(DR*100))<IBEDT D ^DIE
     141 L -(^IBAT(351.61,0),^IBAT(351.6,DFN))
     142 Q IBIEN
     143PROC(IBIEN,IBPROC,IBPRICE) ; files procedures
     144 N X,Y
     145 S Y=1,IBX=0 F  S IBX=$O(IBPROC(IBX)) Q:IBX=""!(+Y<1)  D
     146 . N DIC,X,DA,DD,DO
     147 . S DIC="^IBAT(351.61,"_IBIEN_",3,",DIC(0)="L"
     148 . S X=IBX,DA(1)=IBIEN
     149 . ;S DIC("P")=$P(^DD(351.61,3,0),"^",2) ; no longer required with fm22
     150 . S DIC("DR")=".02////"_$P(IBPROC(IBX),"^")
     151 . I $P(IBPROC(IBX),"^",2) S DIC("DR")=DIC("DR")_";.03////"_$P(IBPROC(IBX),"^",2)
     152 . E  S IBPRICE=1
     153 . D FILE^DICN
     154 I +Y<1 L -^IBAT(351.61,IBIEN) Q "0^Unable to file procedures"
     155 Q IBIEN
     156DX(IBIEN,IBPTF) ; - files dx info
     157 Q IBIEN
     158 N IBX,Y S Y=1,IBX="" F  S IBX=$O(IBDX(IBX)) Q:IBX=""!(+Y<1)  D
     159 . N DD,DO,DIC,DINUM,X
     160 . S DIC="^IBAT(351.61,"_IBIEN_",2,",DIC(0)="",X=$P(IBDX(IBX),"^")
     161 . ;S DA(1)=IBIEN,DIC("P")=$P(^DD(351.61,2,0),"^",2) D FILE^DICN
     162 . ; no longer required with fm22
     163 . S DA(1)=IBIEN D FILE^DICN
     164 Q $S(+Y<1:"0^Unable to file diagnosis's",1:IBIEN)
     165 ;
     166INIT ; called to possibly initialize the 351.6 file if not done
     167 N IBS,ZTRTN,ZTDESC,ZTIO,ZTSK,X,Y
     168 ;
     169 Q:$O(^IBAT(351.6,0))  ; already populated
     170 ;
     171 ; is Transfer Pricing active or not for any
     172 S IBS=$G(^IBE(350.9,1,10))
     173 I '$P(IBS,"^",2),'$P(IBS,"^",3),'$P(IBS,"^",4),'$P(IBS,"^",5) Q
     174 ;
     175 ; queue off job
     176 W !!,"It appears you have never used Transfer Pricing before.  I need to populate",!,"the Transfer Pricing patient file.  Please select a date/time to do this.",!
     177 S ZTRTN="ADDTP^IBATFILE",ZTDESC="Initializing Transfer Pricing Patient File",ZTIO="" D ^%ZTLOAD
     178 I $G(ZTSK) W !,"Task Queued #",ZTSK
     179 ;
     180 Q
     181ADDTP ; Add Transfer Pricing patients to file #351.6
     182 ;
     183 N DFN,IBADM,IBDFN,IBPREF,IBADMDT,IBX
     184 ;
     185 S DFN=0 F  S DFN=$O(^DPT(DFN)) Q:'DFN  D
     186 .;
     187 .S IBDFN=$$TPP^IBATUTL(DFN)
     188 .Q:'IBDFN
     189 .;
     190 .; - see if they are admitted
     191 .S IBADM=$G(^DPT(DFN,.105))
     192 .I IBADM D
     193 ..S IBPREF=+$P($G(^IBAT(351.6,DFN,0)),"^",3)
     194 ..S IBADMDT=+$G(^DGPM(IBADM,0))
     195 ..S IBX=$$ADM(DFN,IBADMDT,IBPREF,IBADM_";DGPM(")
     196 ;
     197 Q

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBATLM1B.m

    r613 r623  
    1 IBATLM1B        ;LL/ELZ - TRANSFER PRICING TRANSACTION LIST MENU ; 15-SEP-1998
    2         ;;2.0;INTEGRATED BILLING;**115,261,389**;21-MAR-94;Build 6
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5 CF      ; -- change facility from patient level
    6         D LMOPT^IBATUTL,CFP^IBATLM0A(DFN),HDR^IBATLM1
    7         Q
    8 CS      ; -- change status of patient from patient level
    9         D LMOPT^IBATUTL,CSP^IBATLM0A(DFN),HDR^IBATLM1
    10         Q
    11 CT      ; -- cancel a transaction
    12         N IBVAL,DIE,DA,DR,DTOUT,%
    13         D LMOPT^IBATUTL,EN^VALM2($G(XQORNOD(0)))
    14         S (DA,IBVAL)=0,IBVAL=$O(VALMY(IBVAL)) Q:'IBVAL
    15         S DA=$O(@VALMAR@("INDEX",IBVAL,DA))
    16         I $P(^IBAT(351.61,DA,0),U,5)="X" W !!,"Transaction already cancelled!" D H Q
    17         W !!,"Are you sure you want to cancel this transaction"
    18         S %=2 D YN^DICN Q:%'=1
    19         D CANC^IBATFILE(DA),ARRAY^IBATLM1A(VALMAR)
    20         Q
    21 CD      ; -- change the current date range for transactions displayed
    22         N IBSAVE S IBSAVE=IBBDT_"^"_IBEDT
    23         D LMOPT^IBATUTL
    24         I $$SLDR^IBATUTL S IBBDT=$P(IBSAVE,"^"),IBEDT=$P(IBSAVE,"^",2)
    25         D ARRAY^IBATLM1A(VALMAR),HDR^IBATLM1
    26         Q
    27 CP      ; -- change the currently selected patient
    28         N IBDFN
    29         D LMOPT^IBATUTL
    30         S IBDFN=$$SLPT^IBATUTL I 'IBDFN Q
    31         I $$SLDR^IBATUTL Q
    32         S DFN=IBDFN K ^TMP("VALM DATA",$J),^TMP("VALMAR",$J)
    33         D HDR^IBATLM1,ARRAY^IBATLM1A(VALMAR)
    34         Q
    35 AT      ; -- add a transaction
    36         N X,Y,DTOUT,DUOUT,DIRUT,DIROUT
    37         D LMOPT^IBATUTL
    38         S DIR(0)="SMBA^I:Inpatient;O:Outpatient;P:Prescription;R:Prosthetic"
    39         S DIR("A")="Select type of Transaction to add: " D ^DIR Q:$D(DIRUT)
    40         D @Y K ^TMP("VALM DATA",$J),^TMP("VALMAR",$J)
    41         D HDR^IBATLM1,ARRAY^IBATLM1A(VALMAR)
    42         Q
    43 I       ; -- select an inpatient stay and add
    44         N IBXA,IBADM,DIRUT,IBIEN,VAIP,IBCHARGE,IBPPF,IBRES
    45         S IBXA=7,IBADM=+$$ADSEL^IBECEA31(DFN) Q:IBADM<0
    46         I IBADM=0 W !!,"Patient has no admissions on file." D H Q
    47         D DUP(IBADM_";DGPM(",.DIRUT)
    48         I $D(DIRUT) D H Q
    49         S VAIP("E")=IBADM D IN5^VADPT S IBPPF=$$PPF^IBATUTL(DFN)
    50         S IBIEN=$$ADM^IBATFILE(DFN,+VAIP(13,1),IBPPF,(+IBADM)_";DGPM(")
    51         I 'IBIEN D M(,$P(IBIEN,"^",2)) Q
    52         I '$G(VAIP(17)) D M(IBIEN,"missing discharge information") Q
    53         S IBRES=$$DIS^IBATFILE(IBIEN,+VAIP(17,1),VAIP(12),VAIP(17))
    54         I 'IBRES D M(IBIEN,$P(IBRES,"^",2)) Q
    55         S IBFINDRT=$$FINDRT^IBATEI(VAIP(12),VAIP(13),DFN)
    56         I '+IBFINDRT D M(IBIEN,"Cannot price transaction") Q
    57         I $P(IBFINDRT,"^",3)="B" S IBRES=$$INPT^IBATFILE(IBIEN,0,0,$P(IBFINDRT,"^",4),0,$P(IBFINDRT,"^",4),$P(IBFINDRT,"^",7))
    58         E  S IBRES=$$INPT^IBATFILE(IBIEN,$P(IBFINDRT,"^",3),$P(IBFINDRT,"^",2),$P(IBFINDRT,"^",4),$P(IBFINDRT,"^",5),$P(IBFINDRT,"^",6),$P(IBFINDRT,"^",7))
    59         I 'IBRES D M(IBIEN,"Error in filling pricing information") Q
    60         D M(IBIEN)
    61         Q
    62 M(X,Y)  ; Prints message and hangs
    63         N IBSITE S IBSITE=$$SITE^IBATUTL
    64         I $D(X) W !,"Transaction #",IBSITE,X," Added"
    65         I $D(Y) W !,"Cannot complete, ",Y
    66         D H
    67         Q
    68 O       ; -- select an outpatient stay
    69         N X,Y,DIR,DTOUT,DUOUT,DIRUT,DIROUT,IBDATA,IBX,IBC,CPTLIST,IBIEN,IBFAC
    70         K ^TMP("IBAT",$J)
    71         S DIR(0)="D^::AEPX",DIR("A")="Visit Date" D ^DIR Q:$D(DIRUT)
    72         S IBDATA("DFN")=DFN,IBDATA("BDT")=Y,IBDATA("EDT")=Y+.99999
    73         ;
    74         ; scan for the appointments and set up tmp global
    75         ; screen to eliminate children and inpatient appointments
    76         D SCAN^IBSDU("PATIENT/DATE",.IBDATA,"I '$P(Y0,""^"",6),$P(Y0,""^"",12)'=8","S ^TMP(""IBAT"",$J,Y)=Y0","")
    77         ;
    78         I '$D(^TMP("IBAT",$J)) W !!,"No appointments exist for the date!" D H Q
    79         W !,?10,"Choose which Visit:" S IBX=0
    80         F IBC=1:1 S IBX=$O(^TMP("IBAT",$J,IBX)) Q:IBX<1  S IBDATA=^(IBX) D
    81         . W !,?4,IBC,?10,$$FMTE^XLFDT($P(IBDATA,"^"),"1P")
    82         . W ?35,$$EX^IBATUTL(409.68,.04,$P(IBDATA,"^",4))
    83         . W ?55,$$EX^IBATUTL(409.68,.12,$P(IBDATA,"^",12))
    84         S DIR(0)="N^1:"_(IBC-1),DIR("A")="Select" D ^DIR Q:$D(DIRUT)
    85         S IBX=0 F IBC=1:1:Y S IBX=$O(^TMP("IBAT",$J,IBX))
    86         ; check for duplicates
    87         D DUP(IBX_";SCE(",.DIRUT) I $D(DIRUT) D H Q
    88         ; setup visit info
    89         S IBX(0)=^TMP("IBAT",$J,IBX)
    90         D GETCPT^SDOE(IBX,"CPTLIST") ;GETDX^SDOE(IBX,"DXLIST")
    91         S IBFAC=$$PPF^IBATUTL(DFN)
    92         ; ok now lets format cpts and price
    93         S IBIEN=0 F  S IBIEN=$O(CPTLIST(IBIEN)) Q:IBIEN<1  D
    94         . N IBCPT,IBQTY,IBPRICE
    95         . S IBCPT=$P(CPTLIST(IBIEN),"^"),IBQTY=$P(CPTLIST(IBIEN),"^",16)
    96         . S IBPRICE=$$OPT^IBATCM(IBCPT,$P(IBX(0),"^"),IBFAC)
    97         . S IBIEN(IBCPT)=IBQTY_"^"_$S(IBPRICE:$P(IBPRICE,"^",4),1:0)
    98         S IBIEN=$$OUT^IBATFILE(DFN,$P(IBX(0),"^"),IBFAC,IBX_";SCE(",.IBIEN)
    99         W !!,"Transaction Number ",$P(^IBAT(351.61,IBIEN,0),"^")," Added!" D H
    100         K ^TMP("IBAT",$J)
    101         Q
    102 P       ; -- select an rx
    103         N IBRX,IBPSRX,IBOUT,IBCOUNT,DIRUT,DIR,IBP,IBNUM,IBSITE,IBQUIT,IBBDT,IBEDT
    104         S (IBCOUNT,IBOUT)=0
    105         Q:$$SLDR^IBATUTL
    106         D RX^IBATRX(DFN,IBBDT,IBEDT,.IBRX)
    107         I '$D(IBRX) W !!,"No Rx's on file for date range selected." D H Q
    108         W @IOF,!,"Prescriptions Issued:",!
    109         S IBPSRX=0 F  S IBPSRX=$O(IBRX(IBPSRX)) Q:IBPSRX=""!(IBOUT)  D
    110         . S IBDT=0 F  S IBDT=$O(IBRX(IBPSRX,IBDT)) Q:IBDT<1!(IBOUT)  D
    111         .. S IBDAT=IBRX(IBPSRX,IBDT),IBCOUNT=IBCOUNT+1
    112         .. W !,IBCOUNT,?4,$$FMTE^XLFDT(IBDT,"5D"),?18,$P(IBDAT,"^")
    113         .. W "(",$P(IBDAT,"^",2),")",?35,$E($P(IBDAT,"^",4),1,27)
    114         .. W ?65,$J($FN($P(IBDAT,"^",5)*$P(IBDAT,"^",6),",",2),12)
    115         .. ;I $Y+4>IOSL D H X:'$D(DIRUT) "W @IOF,!" I $D(DIRUT) S IBOUT=1 Q
    116         .. S IBNUM(IBCOUNT)=IBPSRX_"^"_IBDT
    117         W ! K DIRUT S DIR(0)="L^1:"_IBCOUNT,DIR("A")="Which Prescriptions"
    118         D ^DIR Q:$D(DIRUT)  W !!,"Selected number(s): "_Y S IBNUM=Y
    119         W !,"Ok to add: " S %=1 D YN^DICN I %'=1 D H Q
    120         S IBFAC=$$PPF^IBATUTL(DFN),IBSITE=$$SITE^IBATUTL
    121         F IBP=1:1 S IBRX=$P(IBNUM,",",IBP) Q:'IBRX  D
    122         . S IBRX(0)=IBRX($P(IBNUM(IBRX),"^"),$P(IBNUM(IBRX),"^",2))
    123         . D DUP($P(IBRX(0),"^")_";PSRX(;"_$P(IBRX(0),"^",2),.IBQUIT)
    124         . I $G(IBQUIT) K IBQUIT Q
    125         . W !!,"Adding Transaction number ",IBSITE
    126         . W $$RX^IBATFILE(DFN,$P(IBNUM(IBRX),"^",2),IBFAC,$P(IBRX(0),"^")_";PSRX(;"_$P(IBRX(0),"^",2),$P(IBRX(0),"^",3),$P(IBRX(0),"^",5),$P(IBRX(0),"^",6))
    127         . W "!" H 1
    128         D H
    129         Q
    130 R       ; -- select an prosthetic
    131         N IBBDT,IBEDT,IBCOUNT,IBOUT,IBDA,IBDATA,IBDATA1,IBP,IBC,IBCOUNT,%,DIRUT
    132         ;
    133         S (IBCOUNT,IBOUT)=0
    134         Q:$$SLDR^IBATUTL
    135         ;
    136         ; look up prosthetic devices issued
    137         S IBDA="" F  S IBDA=$O(^RMPR(660,"C",DFN,IBDA)) Q:'IBDA  D
    138         . ;
    139         . ; valid data
    140         . S IBDATA=$G(^RMPR(660,+IBDA,0)) Q:IBDATA=""  S IBDATA1=$G(^RMPR(660,+IBDA,1))
    141         . ;
    142         . ; valid date range
    143         . I $P(IBDATA,"^",12)<IBBDT!($P(IBDATA,"^",12)>IBEDT) Q
    144         . ;
    145         . ; checks from RMPRBIL copied 4/7/2000 with mod for AM node patients
    146         . I $S('$D(^RMPR(660,IBDA,"AM")):1,$P(IBDATA,"^",9)="":1,$P(IBDATA,"^",12)="":1,$P(IBDATA1,"^",4)="":1,$P(IBDATA,"^",14)="V":1,$P(IBDATA,"^",15)="*":1,1:0) Q
    147         . ;
    148         . ; set array
    149         . S IBCOUNT=IBCOUNT+1,IBP(IBCOUNT,IBDA)=IBDATA
    150         ;
    151         I 'IBCOUNT W !!,"No Prosthetic Devices on file for date range selected." D H Q
    152         ;
    153         W @IOF,!,"Prosthetic Devices Issued:",!
    154         F IBC=1:1:IBCOUNT Q:IBOUT  D
    155         . S IBDATA=IBP(IBC,$O(IBP(IBC,0)))
    156         . W !,IBC,?4,$$FMTE^XLFDT($P(IBDATA,"^",12),"5D")
    157         . W ?20,$E($P($$PIN^IBATUTL($O(IBP(IBC,0))),U,2),1,28),?50,"("
    158         . W $$EX^IBATUTL(660,62,$P(^RMPR(660,$O(IBP(IBC,0)),"AM"),"^",3)),")"
    159         . W ?65,$J($FN($P(IBDATA,"^",16),",",2),12)
    160         ;
    161         W ! K DIRUT S DIR(0)="N^1:"_IBCOUNT_":0"
    162         S DIR("A")="Which Prosthetic Device" D ^DIR Q:$D(DIRUT)  S IBC=+Y
    163         W !,"Ok to add: " S %=1 D YN^DICN I %'=1 D H Q
    164         S IBDA=$O(IBP(IBC,0)),IBDATA=IBP(IBC,IBDA)
    165         D DUP(IBDA_";RMPR(660,",.DIRUT)
    166         I $D(DIRUT) D H Q
    167         W !!,"Adding Transaction number ",$$SITE^IBATUTL
    168         W $$RMPR^IBATFILE(DFN,$P(IBDATA,"^",12),$$PPF^IBATUTL(DFN),(IBDA_";RMPR(660,"),,$P(IBDATA,"^",16))
    169         W "!" H 1
    170         D H
    171         Q
    172 H       ; -- page reader
    173         N DIR,X,Y,DTOUT,DUOUT,DIROUT
    174         W !! S DIR(0)="E" D ^DIR
    175         Q
    176 DUP(IBSOURCE,IBQUIT)    ; -- checks for dups that are not cancelled
    177         N IBT S IBT=0
    178         F  S IBT=$O(^IBAT(351.61,"AD",IBSOURCE,IBT)) Q:IBT<1!($D(IBQUIT))  D
    179         . Q:$P(^IBAT(351.61,IBT,0),"^",5)="X"
    180         . W !,$S(IBSOURCE["SCE(":"Visit",IBSOURCE["DGPM(":"Admission",IBSOURCE["RMPR(":"Prosthetic",1:"Prescription")," exists already!" S IBQUIT=1
    181         Q
     1IBATLM1B ;LL/ELZ - TRANSFER PRICING TRANSACTION LIST MENU ; 15-SEP-1998
     2 ;;2.0;INTEGRATED BILLING;**115,261**;21-MAR-94
     3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
     4 ;
     5CF ; -- change facility from patient level
     6 D LMOPT^IBATUTL,CFP^IBATLM0A(DFN),HDR^IBATLM1
     7 Q
     8CS ; -- change status of patient from patient level
     9 D LMOPT^IBATUTL,CSP^IBATLM0A(DFN),HDR^IBATLM1
     10 Q
     11CT ; -- cancel a transaction
     12 N IBVAL,DIE,DA,DR,DTOUT,%
     13 D LMOPT^IBATUTL,EN^VALM2($G(XQORNOD(0)))
     14 S (DA,IBVAL)=0,IBVAL=$O(VALMY(IBVAL)) Q:'IBVAL
     15 S DA=$O(@VALMAR@("INDEX",IBVAL,DA))
     16 I $P(^IBAT(351.61,DA,0),U,5)="X" W !!,"Transaction already cancelled!" D H Q
     17 W !!,"Are you sure you want to cancel this transaction"
     18 S %=2 D YN^DICN Q:%'=1
     19 D CANC^IBATFILE(DA),ARRAY^IBATLM1A(VALMAR)
     20 Q
     21CD ; -- change the current date range for transactions displayed
     22 N IBSAVE S IBSAVE=IBBDT_"^"_IBEDT
     23 D LMOPT^IBATUTL
     24 I $$SLDR^IBATUTL S IBBDT=$P(IBSAVE,"^"),IBEDT=$P(IBSAVE,"^",2)
     25 D ARRAY^IBATLM1A(VALMAR),HDR^IBATLM1
     26 Q
     27CP ; -- change the currently selected patient
     28 N IBDFN
     29 D LMOPT^IBATUTL
     30 S IBDFN=$$SLPT^IBATUTL I 'IBDFN Q
     31 I $$SLDR^IBATUTL Q
     32 S DFN=IBDFN K ^TMP("VALM DATA",$J),^TMP("VALMAR",$J)
     33 D HDR^IBATLM1,ARRAY^IBATLM1A(VALMAR)
     34 Q
     35AT ; -- add a transaction
     36 N X,Y,DTOUT,DUOUT,DIRUT,DIROUT
     37 D LMOPT^IBATUTL
     38 S DIR(0)="SMBA^I:Inpatient;O:Outpatient;P:Prescription;R:Prosthetic"
     39 S DIR("A")="Select type of Transaction to add: " D ^DIR Q:$D(DIRUT)
     40 D @Y K ^TMP("VALM DATA",$J),^TMP("VALMAR",$J)
     41 D HDR^IBATLM1,ARRAY^IBATLM1A(VALMAR)
     42 Q
     43I ; -- select an inpatient stay and add
     44 N IBXA,IBADM,DIRUT,IBIEN,VAIP,IBCHARGE,IBPPF,IBRES
     45 S IBXA=7,IBADM=+$$ADSEL^IBECEA31(DFN) Q:IBADM<0
     46 I IBADM=0 W !!,"Patient has no admissions on file." D H Q
     47 D DUP(IBADM_";DGPM(",.DIRUT)
     48 I $D(DIRUT) D H Q
     49 S VAIP("E")=IBADM D IN5^VADPT S IBPPF=$$PPF^IBATUTL(DFN)
     50 S IBIEN=$$ADM^IBATFILE(DFN,+VAIP(13,1),IBPPF,(+IBADM)_";DGPM(")
     51 I 'IBIEN D M(,$P(IBIEN,"^",2)) Q
     52 I '$G(VAIP(17)) D M(IBIEN,"missing discharge information") Q
     53 S IBRES=$$DIS^IBATFILE(IBIEN,+VAIP(17,1),VAIP(12),VAIP(17))
     54 I 'IBRES D M(IBIEN,$P(IBRES,"^",2)) Q
     55 S IBFINDRT=$$FINDRT^IBATEI(VAIP(12),VAIP(13),DFN)
     56 I '+IBFINDRT D M(IBIEN,"Cannot price transaction") Q
     57 I $P(IBFINDRT,"^",3)="B" S IBRES=$$INPT^IBATFILE(IBIEN,0,0,$P(IBFINDRT,"^",4),0,$P(IBFINDRT,"^",4),$P(IBFINDRT,"^",7))
     58 E  S IBRES=$$INPT^IBATFILE(IBIEN,$P(IBFINDRT,"^",3),$P(IBFINDRT,"^",2),$P(IBFINDRT,"^",4),$P(IBFINDRT,"^",5),$P(IBFINDRT,"^",6),$P(IBFINDRT,"^",7))
     59 I 'IBRES D M(IBIEN,"Error in filling pricing information") Q
     60 D M(IBIEN)
     61 Q
     62M(X,Y) ; Prints message and hangs
     63 N IBSITE S IBSITE=$$SITE^IBATUTL
     64 I $D(X) W !,"Transaction #",IBSITE,X," Added"
     65 I $D(Y) W !,"Cannot complete, ",Y
     66 D H
     67 Q
     68O ; -- select an outpatient stay
     69 N X,Y,DIR,DTOUT,DUOUT,DIRUT,DIROUT,IBDATA,IBX,IBC,CPTLIST,IBIEN,IBFAC
     70 K ^TMP("IBAT",$J)
     71 S DIR(0)="D^::AEPX",DIR("A")="Visit Date" D ^DIR Q:$D(DIRUT)
     72 S IBDATA("DFN")=DFN,IBDATA("BDT")=Y,IBDATA("EDT")=Y+.99999
     73 ;
     74 ; scan for the appointments and set up tmp global
     75 ; screen to eliminate children and inpatient appointments
     76 D SCAN^IBSDU("PATIENT/DATE",.IBDATA,"I '$P(Y0,""^"",6),$P(Y0,""^"",12)'=8","S ^TMP(""IBAT"",$J,Y)=Y0","")
     77 ;
     78 I '$D(^TMP("IBAT",$J)) W !!,"No appointments exist for the date!" D H Q
     79 W !,?10,"Choose which Visit:" S IBX=0
     80 F IBC=1:1 S IBX=$O(^TMP("IBAT",$J,IBX)) Q:IBX<1  S IBDATA=^(IBX) D
     81 . W !,?4,IBC,?10,$$FMTE^XLFDT($P(IBDATA,"^"),"1P")
     82 . W ?35,$$EX^IBATUTL(409.68,.04,$P(IBDATA,"^",4))
     83 . W ?55,$$EX^IBATUTL(409.68,.12,$P(IBDATA,"^",12))
     84 S DIR(0)="N^1:"_(IBC-1),DIR("A")="Select" D ^DIR Q:$D(DIRUT)
     85 S IBX=0 F IBC=1:1:Y S IBX=$O(^TMP("IBAT",$J,IBX))
     86 ; check for duplicates
     87 D DUP(IBX_";SCE(",.DIRUT) I $D(DIRUT) D H Q
     88 ; setup visit info
     89 S IBX(0)=^TMP("IBAT",$J,IBX)
     90 D GETCPT^SDOE(IBX,"CPTLIST") ;GETDX^SDOE(IBX,"DXLIST")
     91 S IBFAC=$$PPF^IBATUTL(DFN)
     92 ; ok now lets format cpts and price
     93 S IBIEN=0 F  S IBIEN=$O(CPTLIST(IBIEN)) Q:IBIEN<1  D
     94 . N IBCPT,IBQTY,IBPRICE
     95 . S IBCPT=$P(CPTLIST(IBIEN),"^"),IBQTY=$P(CPTLIST(IBIEN),"^",16)
     96 . S IBPRICE=$$OPT^IBATCM(IBCPT,$P(IBX(0),"^"),IBFAC)
     97 . S IBIEN(IBCPT)=IBQTY_"^"_$S(IBPRICE:$P(IBPRICE,"^",4),1:0)
     98 S IBIEN=$$OUT^IBATFILE(DFN,$P(IBX(0),"^"),IBFAC,IBX_";SCE(",.IBIEN)
     99 W !!,"Transaction Number ",$P(^IBAT(351.61,IBIEN,0),"^")," Added!" D H
     100 K ^TMP("IBAT",$J)
     101 Q
     102P ; -- select an rx
     103 N IBRX,IBPSRX,IBOUT,IBCOUNT,DIRUT,DIR,IBP,IBNUM,IBSITE,IBQUIT,IBBDT,IBEDT
     104 S (IBCOUNT,IBOUT)=0
     105 Q:$$SLDR^IBATUTL
     106 D RX^IBATRX(DFN,IBBDT,IBEDT,.IBRX)
     107 I '$D(IBRX) W !!,"No Rx's on file for date range selected." D H Q
     108 W @IOF,!,"Prescriptions Issued:",!
     109 S IBPSRX=0 F  S IBPSRX=$O(IBRX(IBPSRX)) Q:IBPSRX=""!(IBOUT)  D
     110 . S IBDT=0 F  S IBDT=$O(IBRX(IBPSRX,IBDT)) Q:IBDT<1!(IBOUT)  D
     111 .. S IBDAT=IBRX(IBPSRX,IBDT),IBCOUNT=IBCOUNT+1
     112 .. W !,IBCOUNT,?4,$$FMTE^XLFDT(IBDT,"5D"),?18,$P(IBDAT,"^")
     113 .. W "(",$P(IBDAT,"^",2),")",?35,$E($P(IBDAT,"^",4),1,27)
     114 .. W ?65,$J($FN($P(IBDAT,"^",5)*$P(IBDAT,"^",6),",",2),12)
     115 .. ;I $Y+4>IOSL D H X:'$D(DIRUT) "W @IOF,!" I $D(DIRUT) S IBOUT=1 Q
     116 .. S IBNUM(IBCOUNT)=IBPSRX_"^"_IBDT
     117 W ! K DIRUT S DIR(0)="L^1:"_IBCOUNT,DIR("A")="Which Prescriptions"
     118 D ^DIR Q:$D(DIRUT)  W !!,"Selected number(s): "_Y S IBNUM=Y
     119 W !,"Ok to add: " S %=1 D YN^DICN I %'=1 D H Q
     120 S IBFAC=$$PPF^IBATUTL(DFN),IBSITE=$$SITE^IBATUTL
     121 F IBP=1:1 S IBRX=$P(IBNUM,",",IBP) Q:'IBRX  D
     122 . S IBRX(0)=IBRX($P(IBNUM(IBRX),"^"),$P(IBNUM(IBRX),"^",2))
     123 . D DUP($P(IBRX(0),"^")_";PSRX(;"_$P(IBRX(0),"^",2),.IBQUIT)
     124 . I $G(IBQUIT) K IBQUIT Q
     125 . W !!,"Adding Transaction number ",IBSITE
     126 . W $$RX^IBATFILE(DFN,$P(IBNUM(IBRX),"^",2),IBFAC,$P(IBRX(0),"^")_";PSRX(;"_$P(IBRX(0),"^",2),$P(IBRX(0),"^",3),$P(IBRX(0),"^",5),$P(IBRX(0),"^",6))
     127 . W "!" H 1
     128 D H
     129 Q
     130R ; -- select an prosthetic
     131 N IBBDT,IBEDT,IBCOUNT,IBOUT,IBDA,IBDATA,IBP,IBC,IBCOUNT,%,DIRUT
     132 ;
     133 S (IBCOUNT,IBOUT)=0
     134 Q:$$SLDR^IBATUTL
     135 ;
     136 ; look up prosthetic devices issued
     137 S IBDA="" F  S IBDA=$O(^RMPR(660,"C",DFN,IBDA)) Q:'IBDA  D
     138 . ;
     139 . ; valid data
     140 . S IBDATA=$G(^RMPR(660,+IBDA,0)) Q:IBDATA=""
     141 . ;
     142 . ; valid date range
     143 . I $P(IBDATA,"^",12)<IBBDT!($P(IBDATA,"^",12)>IBEDT) Q
     144 . ;
     145 . ; checks from RMPRBIL copied 4/7/2000 with mod for AM node patients
     146 . I $S('$D(^RMPR(660,IBDA,"AM")):1,$P(IBDATA,"^",9)="":1,$P(IBDATA,"^",12)="":1,$P(IBDATA,"^",6)="":1,$P(IBDATA,"^",14)="V":1,$P(IBDATA,"^",15)="*":1,1:0) Q
     147 . ;
     148 . ; set array
     149 . S IBCOUNT=IBCOUNT+1,IBP(IBCOUNT,IBDA)=IBDATA
     150 ;
     151 I 'IBCOUNT W !!,"No Prosthetic Devices on file for date range selected." D H Q
     152 ;
     153 W @IOF,!,"Prosthetic Devices Issued:",!
     154 F IBC=1:1:IBCOUNT Q:IBOUT  D
     155 . S IBDATA=IBP(IBC,$O(IBP(IBC,0)))
     156 . W !,IBC,?4,$$FMTE^XLFDT($P(IBDATA,"^",12),"5D")
     157 . W ?20,$$EX^IBATUTL(660,4,$P(IBDATA,"^",6)),?40,"("
     158 . W $$EX^IBATUTL(660,62,$P(^RMPR(660,$O(IBP(IBC,0)),"AM"),"^",3)),")"
     159 . W ?65,$J($FN($P(IBDATA,"^",16),",",2),12)
     160 ;
     161 W ! K DIRUT S DIR(0)="N^1:"_IBCOUNT_":0"
     162 S DIR("A")="Which Prosthetic Device" D ^DIR Q:$D(DIRUT)  S IBC=+Y
     163 W !,"Ok to add: " S %=1 D YN^DICN I %'=1 D H Q
     164 S IBDA=$O(IBP(IBC,0)),IBDATA=IBP(IBC,IBDA)
     165 D DUP(IBDA_";RMPR(660,",.DIRUT)
     166 I $D(DIRUT) D H Q
     167 W !!,"Adding Transaction number ",$$SITE^IBATUTL
     168 W $$RMPR^IBATFILE(DFN,$P(IBDATA,"^",12),$$PPF^IBATUTL(DFN),(IBDA_";RMPR(660,"),$P(IBDATA,"^",6),$P(IBDATA,"^",16))
     169 W "!" H 1
     170 D H
     171 Q
     172H ; -- page reader
     173 N DIR,X,Y,DTOUT,DUOUT,DIROUT
     174 W !! S DIR(0)="E" D ^DIR
     175 Q
     176DUP(IBSOURCE,IBQUIT) ; -- checks for dups that are not cancelled
     177 N IBT S IBT=0
     178 F  S IBT=$O(^IBAT(351.61,"AD",IBSOURCE,IBT)) Q:IBT<1!($D(IBQUIT))  D
     179 . Q:$P(^IBAT(351.61,IBT,0),"^",5)="X"
     180 . W !,$S(IBSOURCE["SCE(":"Visit",IBSOURCE["DGPM(":"Admission",IBSOURCE["RMPR(":"Prosthetic",1:"Prescription")," exists already!" S IBQUIT=1
     181 Q

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBATLM2A.m

    r613 r623  
    1 IBATLM2A        ;LL/ELZ - TRANSFER PRICING PT TRANSACTION DETAIL ; 15-SEP-1998
    2         ;;2.0;INTEGRATED BILLING;**115,210,266,309,389**;21-MAR-94;Build 6
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5         N IBX,IBY K ^TMP("IBATEE",$J)
    6         F IBX=0,4,5,6 S IBDATA(IBX)=$G(^IBAT(351.61,IBIEN,IBX))
    7         ;
    8         S IBY=""
    9         D SET("*** General Information ***",.IBY,26,27)
    10         D SETVALM(.VALMCNT,.IBY)
    11         D CNTRL^VALM10(VALMCNT,26,27,IOINHI,IOINORM)
    12         D SETVALM(.VALMCNT,"")
    13         ;
    14         D SET("Transaction Date:",.IBY,1,17)
    15         D SET($$DATE($P(IBDATA(0),"^",3)),.IBY,19,19)
    16         D SET("Event Date:",.IBY,48,11)
    17         D SET($$DATE($P(IBDATA(0),"^",4)),.IBY,60,20)
    18         D SETVALM(.VALMCNT,.IBY)
    19         ;
    20         D SET("Status:",.IBY,11,7)
    21         D SET($$EX^IBATUTL(351.61,.05,$P(IBDATA(0),"^",5)),.IBY,19,19)
    22         D SET("Priced Date:",.IBY,47,12)
    23         D SET($$DATE($P(IBDATA(0),"^",13)),.IBY,60,20)
    24         D SETVALM(.VALMCNT,.IBY)
    25         ;
    26         D SET("From Date:",.IBY,8,10)
    27         D SET($$DATE($P(IBDATA(0),"^",9)),.IBY,19,19)
    28         D SET("To Date:",.IBY,51,8)
    29         D SET($$DATE($P(IBDATA(0),"^",10)),.IBY,60,20)
    30         D SETVALM(.VALMCNT,.IBY)
    31         ;
    32         D SET("Facility:",.IBY,9,9)
    33         D SET($$EX^IBATUTL(351.61,.11,$P(IBDATA(0),"^",11)),.IBY,19,19)
    34         D SETVALM(.VALMCNT,.IBY),SETVALM(.VALMCNT,""),SETVALM(.VALMCNT,"")
    35         ;
    36         D SET("*** Workload/Pricing Detail ***",.IBY,24,31)
    37         D SETVALM(.VALMCNT,.IBY)
    38         D CNTRL^VALM10(VALMCNT,24,31,IOINHI,IOINORM)
    39         ;
    40         D @$S($P(IBDATA(0),"^",12)["DGPM(":"INPT",$P(IBDATA(0),"^",12)["SCE(":"OUT",$P(IBDATA(0),"^",12)["RMPR(":"RMPR",1:"RX")
    41         ;
    42         D SETVALM(.VALMCNT,"")
    43         D SET("*** Totals ***",.IBY,33,14)
    44         D SETVALM(.VALMCNT,.IBY)
    45         D CNTRL^VALM10(VALMCNT,26,28,IOINHI,IOINORM)
    46         D SETVALM(.VALMCNT,"")
    47         ;
    48         D SET("Bill Amount:",.IBY,6,18)
    49         D SET($FN($P(IBDATA(6),"^",2),"",2),.IBY,25,54)
    50         D SETVALM(.VALMCNT,.IBY)
    51         ;
    52         D SET("Patient Copay:",.IBY,6,14)
    53         S $P(IBDATA(6),"^",3)=$$COPAY^IBATUTL(DFN,$P(IBDATA(0),"^",12),$P(IBDATA(0),"^",9),$P(IBDATA(0),"^",10))
    54         D SET($FN($P(IBDATA(6),"^",3),"",2),.IBY,26,54)
    55         D SETVALM(.VALMCNT,.IBY)
    56         ;
    57         Q
    58 INPT    ; -- detail display for inpatient
    59         N IBDRG,VAIP
    60         ;
    61         S IBDRG=$G(^IBAT(351.61,IBIEN,1))
    62         ;
    63         S VAIP("E")=+$P(IBDATA(0),"^",12) D IN5^VADPT
    64         ;
    65         D SETVALM(.VALMCNT,"")
    66         D SET("Admission Date:",.IBY,3,15)
    67         D SET($P(VAIP(13,1),"^",2),.IBY,19,19)
    68         D SET("Discharge Date:",.IBY,44,15)
    69         D SET($P(VAIP(17,1),"^",2),.IBY,60,20)
    70         D SETVALM(.VALMCNT,.IBY)
    71         ;
    72         D SET("Ward Location:",.IBY,4,14)
    73         D SET($P(VAIP(5),"^",2),.IBY,19,19)
    74         D SET("Treating Specialty:",.IBY,40,19)
    75         D SET($P(VAIP(8),"^",2),.IBY,60,20)
    76         D SETVALM(.VALMCNT,.IBY)
    77         ;
    78         D SET("DRG:",.IBY,14,4)
    79         D SET($$EX^IBATUTL(351.61,1.01,$P(IBDRG,"^")),.IBY,19,19)
    80         D SET("DRG Charge:",.IBY,48,11)
    81         D SET($FN($P(IBDRG,"^",2),"",2),.IBY,60,20)
    82         D SETVALM(.VALMCNT,.IBY)
    83         ;
    84         D SET("Inpatient LOS:",.IBY,4,14)
    85         D SET(+$P(IBDRG,"^",3),.IBY,19,19)
    86         D SET("High Trim Days:",.IBY,44,15)
    87         D SET(+$P(IBDRG,"^",4),.IBY,60,20)
    88         D SETVALM(.VALMCNT,.IBY)
    89         ;
    90         D SET("Outlier Days:",.IBY,5,13)
    91         D SET(+$P(IBDRG,"^",5),.IBY,19,19)
    92         D SET("Outlier Rate:",.IBY,46,13)
    93         D SET($FN($P(IBDRG,"^",6),"",2),.IBY,60,20)
    94         D SETVALM(.VALMCNT,.IBY)
    95         Q
    96 OUT     ; -- detail display for outpatient
    97         N IBX,IBDXLIST,IBSCE,IBPROV,IBDATE
    98         ;
    99         D GETGEN^SDOE($P($P(IBDATA(0),"^",12),";"),"IBSCE")
    100         D GETPRV^SDOE($P($P(IBDATA(0),"^",12),";"),"IBPROV")
    101         ;
    102         D GETDX^SDOE($P($P(IBDATA(0),"^",12),";"),"IBDXLIST")
    103         S IBDATE=$P($G(IBDATA(0)),U,4) ; Event date
    104         D DX(.IBDXLIST,IBDATE)
    105         ;
    106         D SET("Procedure Information:",.IBY,1,22)
    107         D SETVALM(.VALMCNT,.IBY)
    108         D CNTRL^VALM10(VALMCNT,1,22,IOINHI,IOINORM)
    109         ;
    110         S IBX=0 F  S IBX=$O(^IBAT(351.61,IBIEN,3,IBX)) Q:IBX<1  D
    111         . S IBX(0)=$G(^IBAT(351.61,IBIEN,3,IBX,0))
    112         . S IBX(1)=$$PROC^IBATUTL($P(IBX(0),U),IBDATE)
    113         . ;
    114         . D SET(+IBX(1),.IBY,5,6)
    115         . D SET("-",.IBY,13,1)
    116         . D SET($P(IBX(1),"^",2),.IBY,15,40)
    117         . D SET(+$P(IBX(0),"^",2),.IBY,57,3)
    118         . D SET("x",.IBY,62,1)
    119         . D SET($FN($P(IBX(0),"^",3),"",2),.IBY,64,15)
    120         . D SETVALM(.VALMCNT,.IBY)
    121         D SETVALM(.VALMCNT,"")
    122         ;
    123         D SET("Visit Information:",.IBY,1,18)
    124         D SETVALM(.VALMCNT,.IBY)
    125         D CNTRL^VALM10(VALMCNT,1,22,IOINHI,IOINORM)
    126         ;
    127         D SET("Location:",.IBY,8,14)
    128         D SET($P(^SC(+$P(IBSCE(0),"^",4),0),"^"),.IBY,19,46) ; dbia 10040
    129         D SETVALM(.VALMCNT,.IBY)
    130         ;
    131         D SETVALM(.VALMCNT,"")
    132         D SET("Provider(s):",.IBY,5,17)
    133         S IBX=0 F  S IBX=$O(IBPROV(IBX)) Q:IBX<.5  D
    134         . D SET($$GET1^DIQ(200,+IBPROV(IBX),.01),.IBY,19,49) ; dbia 10060
    135         . D SETVALM(.VALMCNT,.IBY)
    136         ;
    137         Q
    138 RX      ; -- detail display for rx
    139         D SET("Drug:",.IBY,5,5)
    140         D ZERO^IBRXUTL(+IBDATA(4))
    141         D SET(^TMP($J,"IBDRUG",+IBDATA(4),.01),.IBY,12,40) ; dbia 4533
    142         D SET(+$P(IBDATA(4),"^",2),.IBY,55,3)
    143         D SET("x",.IBY,60,1)
    144         D SET($FN($P(IBDATA(4),"^",3),"",3),.IBY,62,15)
    145         D SETVALM(.VALMCNT,.IBY)
    146         D SETVALM(.VALMCNT,"")
    147         K ^TMP($J,"IBDRUG")
    148         Q
    149 RMPR    ; -- detail display for prosthetic
    150         D SETVALM(.VALMCNT,"")
    151         D SET("Prosthetic Item:",.IBY,5,16)
    152         D SET($P($$PIN^IBATUTL(+$P(IBDATA(0),"^",12)),U,2),.IBY,23,30) ; dbia 374
    153         D SET($FN($P(IBDATA(4),"^",5),",",2),.IBY,58,15)
    154         D SETVALM(.VALMCNT,.IBY)
    155         D SETVALM(.VALMCNT,"")
    156         Q
    157 DX(IBDX,IBDATE) ; -- diagnosis info
    158         N IBX
    159         ;
    160         D SETVALM(.VALMCNT,"")
    161         D SET("Diagnosis Information:",.IBY,1,22)
    162         D SETVALM(.VALMCNT,.IBY)
    163         D CNTRL^VALM10(VALMCNT,1,22,IOINHI,IOINORM)
    164         ;
    165         S IBX=0 F  S IBX=$O(IBDX(IBX)) Q:IBX<1  D
    166         . S IBX(0)=$$ICD9^IBACSV(+IBDX(IBX),$G(IBDATE))
    167         . ;
    168         . D SET($P(IBX(0),"^"),.IBY,5,7)
    169         . D SET("-",.IBY,14,1)
    170         . D SET($P(IBX(0),"^",3),.IBY,16,30)
    171         . D SETVALM(.VALMCNT,.IBY)
    172         D SETVALM(.VALMCNT,"")
    173         Q
    174 SET(TEXT,STRING,COL,LENGTH)     ; -- set up string with valm1
    175         S STRING=$$SETSTR^VALM1($$LOWER^VALM1(TEXT),STRING,COL,LENGTH)
    176         Q
    177 SETVALM(LINE,TEXT)      ; -- sets line for display
    178         S LINE=LINE+1
    179         S ^TMP("IBATEE",$J,LINE,0)=TEXT
    180         S TEXT=""
    181         Q
    182 DATE(X) ; -- returns date for display
    183         Q $$FMTE^XLFDT(X,"5D")
     1IBATLM2A ;LL/ELZ - TRANSFER PRICING PT TRANSACTION DETAIL ; 15-SEP-1998
     2 ;;2.0;INTEGRATED BILLING;**115,210,266,309**;21-MAR-94
     3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
     4 ;
     5 N IBX,IBY K ^TMP("IBATEE",$J)
     6 F IBX=0,4,5,6 S IBDATA(IBX)=$G(^IBAT(351.61,IBIEN,IBX))
     7 ;
     8 S IBY=""
     9 D SET("*** General Information ***",.IBY,26,27)
     10 D SETVALM(.VALMCNT,.IBY)
     11 D CNTRL^VALM10(VALMCNT,26,27,IOINHI,IOINORM)
     12 D SETVALM(.VALMCNT,"")
     13 ;
     14 D SET("Transaction Date:",.IBY,1,17)
     15 D SET($$DATE($P(IBDATA(0),"^",3)),.IBY,19,19)
     16 D SET("Event Date:",.IBY,48,11)
     17 D SET($$DATE($P(IBDATA(0),"^",4)),.IBY,60,20)
     18 D SETVALM(.VALMCNT,.IBY)
     19 ;
     20 D SET("Status:",.IBY,11,7)
     21 D SET($$EX^IBATUTL(351.61,.05,$P(IBDATA(0),"^",5)),.IBY,19,19)
     22 D SET("Priced Date:",.IBY,47,12)
     23 D SET($$DATE($P(IBDATA(0),"^",13)),.IBY,60,20)
     24 D SETVALM(.VALMCNT,.IBY)
     25 ;
     26 D SET("From Date:",.IBY,8,10)
     27 D SET($$DATE($P(IBDATA(0),"^",9)),.IBY,19,19)
     28 D SET("To Date:",.IBY,51,8)
     29 D SET($$DATE($P(IBDATA(0),"^",10)),.IBY,60,20)
     30 D SETVALM(.VALMCNT,.IBY)
     31 ;
     32 D SET("Facility:",.IBY,9,9)
     33 D SET($$EX^IBATUTL(351.61,.11,$P(IBDATA(0),"^",11)),.IBY,19,19)
     34 D SETVALM(.VALMCNT,.IBY),SETVALM(.VALMCNT,""),SETVALM(.VALMCNT,"")
     35 ;
     36 D SET("*** Workload/Pricing Detail ***",.IBY,24,31)
     37 D SETVALM(.VALMCNT,.IBY)
     38 D CNTRL^VALM10(VALMCNT,24,31,IOINHI,IOINORM)
     39 ;
     40 D @$S($P(IBDATA(0),"^",12)["DGPM(":"INPT",$P(IBDATA(0),"^",12)["SCE(":"OUT",$P(IBDATA(0),"^",12)["RMPR(":"RMPR",1:"RX")
     41 ;
     42 D SETVALM(.VALMCNT,"")
     43 D SET("*** Totals ***",.IBY,33,14)
     44 D SETVALM(.VALMCNT,.IBY)
     45 D CNTRL^VALM10(VALMCNT,26,28,IOINHI,IOINORM)
     46 D SETVALM(.VALMCNT,"")
     47 ;
     48 D SET("Bill Amount:",.IBY,6,18)
     49 D SET($FN($P(IBDATA(6),"^",2),"",2),.IBY,25,54)
     50 D SETVALM(.VALMCNT,.IBY)
     51 ;
     52 D SET("Patient Copay:",.IBY,6,14)
     53 S $P(IBDATA(6),"^",3)=$$COPAY^IBATUTL(DFN,$P(IBDATA(0),"^",12),$P(IBDATA(0),"^",9),$P(IBDATA(0),"^",10))
     54 D SET($FN($P(IBDATA(6),"^",3),"",2),.IBY,26,54)
     55 D SETVALM(.VALMCNT,.IBY)
     56 ;
     57 Q
     58INPT ; -- detail display for inpatient
     59 N IBDRG,VAIP
     60 ;
     61 S IBDRG=$G(^IBAT(351.61,IBIEN,1))
     62 ;
     63 S VAIP("E")=+$P(IBDATA(0),"^",12) D IN5^VADPT
     64 ;
     65 D SETVALM(.VALMCNT,"")
     66 D SET("Admission Date:",.IBY,3,15)
     67 D SET($P(VAIP(13,1),"^",2),.IBY,19,19)
     68 D SET("Discharge Date:",.IBY,44,15)
     69 D SET($P(VAIP(17,1),"^",2),.IBY,60,20)
     70 D SETVALM(.VALMCNT,.IBY)
     71 ;
     72 D SET("Ward Location:",.IBY,4,14)
     73 D SET($P(VAIP(5),"^",2),.IBY,19,19)
     74 D SET("Treating Specialty:",.IBY,40,19)
     75 D SET($P(VAIP(8),"^",2),.IBY,60,20)
     76 D SETVALM(.VALMCNT,.IBY)
     77 ;
     78 D SET("DRG:",.IBY,14,4)
     79 D SET($$EX^IBATUTL(351.61,1.01,$P(IBDRG,"^")),.IBY,19,19)
     80 D SET("DRG Charge:",.IBY,48,11)
     81 D SET($FN($P(IBDRG,"^",2),"",2),.IBY,60,20)
     82 D SETVALM(.VALMCNT,.IBY)
     83 ;
     84 D SET("Inpatient LOS:",.IBY,4,14)
     85 D SET(+$P(IBDRG,"^",3),.IBY,19,19)
     86 D SET("High Trim Days:",.IBY,44,15)
     87 D SET(+$P(IBDRG,"^",4),.IBY,60,20)
     88 D SETVALM(.VALMCNT,.IBY)
     89 ;
     90 D SET("Outlier Days:",.IBY,5,13)
     91 D SET(+$P(IBDRG,"^",5),.IBY,19,19)
     92 D SET("Outlier Rate:",.IBY,46,13)
     93 D SET($FN($P(IBDRG,"^",6),"",2),.IBY,60,20)
     94 D SETVALM(.VALMCNT,.IBY)
     95 Q
     96OUT ; -- detail display for outpatient
     97 N IBX,IBDXLIST,IBSCE,IBPROV,IBDATE
     98 ;
     99 D GETGEN^SDOE($P($P(IBDATA(0),"^",12),";"),"IBSCE")
     100 D GETPRV^SDOE($P($P(IBDATA(0),"^",12),";"),"IBPROV")
     101 ;
     102 D GETDX^SDOE($P($P(IBDATA(0),"^",12),";"),"IBDXLIST")
     103 S IBDATE=$P($G(IBDATA(0)),U,4) ; Event date
     104 D DX(.IBDXLIST,IBDATE)
     105 ;
     106 D SET("Procedure Information:",.IBY,1,22)
     107 D SETVALM(.VALMCNT,.IBY)
     108 D CNTRL^VALM10(VALMCNT,1,22,IOINHI,IOINORM)
     109 ;
     110 S IBX=0 F  S IBX=$O(^IBAT(351.61,IBIEN,3,IBX)) Q:IBX<1  D
     111 . S IBX(0)=$G(^IBAT(351.61,IBIEN,3,IBX,0))
     112 . S IBX(1)=$$PROC^IBATUTL($P(IBX(0),U),IBDATE)
     113 . ;
     114 . D SET(+IBX(1),.IBY,5,6)
     115 . D SET("-",.IBY,13,1)
     116 . D SET($P(IBX(1),"^",2),.IBY,15,40)
     117 . D SET(+$P(IBX(0),"^",2),.IBY,57,3)
     118 . D SET("x",.IBY,62,1)
     119 . D SET($FN($P(IBX(0),"^",3),"",2),.IBY,64,15)
     120 . D SETVALM(.VALMCNT,.IBY)
     121 D SETVALM(.VALMCNT,"")
     122 ;
     123 D SET("Visit Information:",.IBY,1,18)
     124 D SETVALM(.VALMCNT,.IBY)
     125 D CNTRL^VALM10(VALMCNT,1,22,IOINHI,IOINORM)
     126 ;
     127 D SET("Location:",.IBY,8,14)
     128 D SET($P(^SC(+$P(IBSCE(0),"^",4),0),"^"),.IBY,19,46) ; dbia 10040
     129 D SETVALM(.VALMCNT,.IBY)
     130 ;
     131 D SETVALM(.VALMCNT,"")
     132 D SET("Provider(s):",.IBY,5,17)
     133 S IBX=0 F  S IBX=$O(IBPROV(IBX)) Q:IBX<.5  D
     134 . D SET($$GET1^DIQ(200,+IBPROV(IBX),.01),.IBY,19,49) ; dbia 10060
     135 . D SETVALM(.VALMCNT,.IBY)
     136 ;
     137 Q
     138RX ; -- detail display for rx
     139 D SET("Drug:",.IBY,5,5)
     140 D ZERO^IBRXUTL(+IBDATA(4))
     141 D SET(^TMP($J,"IBDRUG",+IBDATA(4),.01),.IBY,12,40) ; dbia 4533
     142 D SET(+$P(IBDATA(4),"^",2),.IBY,55,3)
     143 D SET("x",.IBY,60,1)
     144 D SET($FN($P(IBDATA(4),"^",3),"",3),.IBY,62,15)
     145 D SETVALM(.VALMCNT,.IBY)
     146 D SETVALM(.VALMCNT,"")
     147 K ^TMP($J,"IBDRUG")
     148 Q
     149RMPR ; -- detail display for prosthetic
     150 D SETVALM(.VALMCNT,"")
     151 D SET("Prosthetic Item:",.IBY,5,16)
     152 D SET($$GET1^DIQ(661,$P(IBDATA(4),"^",4),.01),.IBY,12,40) ; dbia 374
     153 D SET($FN($P(IBDATA(4),"^",5),",",2),.IBY,55,15)
     154 D SETVALM(.VALMCNT,.IBY)
     155 D SETVALM(.VALMCNT,"")
     156 Q
     157DX(IBDX,IBDATE) ; -- diagnosis info
     158 N IBX
     159 ;
     160 D SETVALM(.VALMCNT,"")
     161 D SET("Diagnosis Information:",.IBY,1,22)
     162 D SETVALM(.VALMCNT,.IBY)
     163 D CNTRL^VALM10(VALMCNT,1,22,IOINHI,IOINORM)
     164 ;
     165 S IBX=0 F  S IBX=$O(IBDX(IBX)) Q:IBX<1  D
     166 . S IBX(0)=$$ICD9^IBACSV(+IBDX(IBX),$G(IBDATE))
     167 . ;
     168 . D SET($P(IBX(0),"^"),.IBY,5,7)
     169 . D SET("-",.IBY,14,1)
     170 . D SET($P(IBX(0),"^",3),.IBY,16,30)
     171 . D SETVALM(.VALMCNT,.IBY)
     172 D SETVALM(.VALMCNT,"")
     173 Q
     174SET(TEXT,STRING,COL,LENGTH) ; -- set up string with valm1
     175 S STRING=$$SETSTR^VALM1($$LOWER^VALM1(TEXT),STRING,COL,LENGTH)
     176 Q
     177SETVALM(LINE,TEXT) ; -- sets line for display
     178 S LINE=LINE+1
     179 S ^TMP("IBATEE",$J,LINE,0)=TEXT
     180 S TEXT=""
     181 Q
     182DATE(X) ; -- returns date for display
     183 Q $$FMTE^XLFDT(X,"5D")

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBATO1.m

    r613 r623  
    1 IBATO1  ;LL/ELZ - TRANSFER PRICING REPORTS CONT. ; 18-DEC-98
    2         ;;2.0;INTEGRATED BILLING;**115,266,389**;21-MAR-94;Build 6
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5 PAGE()  ; performs page reads and returns 1 if quiting is needed
    6         N DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
    7         S DIR(0)="E" D ^DIR
    8         Q $D(DIRUT)
    9 NUM(X,X2,X3)    ; calls to format numbers
    10         D COMMA^%DTC
    11         Q $E(X,1,$L(X)-1)
    12 UNIT(IBA,IBD,IBO)       ; sets IBD subscripted with units for IBA
    13         N IBX,IBB S IBB="UNIT"
    14         I $P(IBA(0),"^",12)["DGPM" D  Q
    15         . S IBD(1,IBO,IBB)=$$EX^IBATUTL(351.61,1.01,+IBA(1))
    16         I $P(IBA(0),"^",12)["PSRX(" D  Q
    17         . S IBD(1,IBO,IBB)=$$EX^IBATUTL(52,.01,+$P(IBA(0),"^",12))
    18         I $P(IBA(0),"^",12)["RMPR" D  Q
    19         . S IBD(1,IBO,IBB)="PROSTHETIC"
    20         S IBX=0 F  S IBX=$O(^IBAT(351.61,IBA,3,IBX)) Q:IBX<1  D
    21         . S IBX(0)=^IBAT(351.61,IBIEN,3,IBX,0)
    22         . S IBD(IBX,IBO,IBB)="CPT"_$P($$PROC^IBATUTL(+IBX(0)),U)
    23         Q
    24 TYPE(IBA,IBO)   ; sets IBO with descriptive trans type for IBA
    25         N IBB,IBC,IBD
    26         S:'$D(IBA(0)) IBA(0)=^IBAT(351.61,IBA,0)
    27         S IBB=$P(IBA(0),"^",12)
    28         I IBB["DGPM(" S IBO="INPATIENT" Q
    29         I IBB["PSRX(" S IBO="PHARMACY" Q
    30         I IBB["RMPR(660," S IBO="PROSTHETICS" Q
    31         D GETGEN^SDOE(+$P(IBA(0),"^",12),"IBC")
    32         D:$P($G(IBC(0)),"^",3) PARSE^SDOE(.IBC,"EXTERNAL","IBD")
    33         S IBO=$S($G(IBD(.03))="":"OUTPATINET",1:$E("OUT "_IBD(.03),1,10))
    34         Q
    35 DES(IBA,IBD,IBO)        ; sets IBD subscripted with description for IBA
    36         N IBX,IBB,IBDATE S IBB="UNIT DESCRIPTION"
    37         I $P(IBA(0),"^",12)["DGPM" D  Q
    38         . S IBD(1,IBO,IBB)=$E($$DRGTD^IBACSV(+IBA(1),$P(IBA(0),U,4)),1,18)
    39         I $P(IBA(0),"^",12)["PSRX(" D  Q
    40         . S IBD(1,IBO,IBB)=$E($$EX^IBATUTL(351.61,4.01,+IBA(4)),1,18)
    41         I $P(IBA(0),"^",12)["RMPR(660," D  Q
    42         . S IBD(1,IBO,IBB)=$E($P($$PIN^IBATUTL(+$P(IBA(0),"^",12)),U,2),1,18)
    43         S IBDATE=$P($G(^IBAT(351.61,IBIEN,0)),U,4) ; Event Date
    44         S IBX=0 F  S IBX=$O(^IBAT(351.61,IBA,3,IBX)) Q:IBX<1  D
    45         . S IBX(0)=^IBAT(351.61,IBIEN,3,IBX,0)
    46         . S IBD(IBX,IBO,IBB)=$E($P($$PROC^IBATUTL(+IBX(0),IBDATE),U,2),1,18)
    47         Q
    48 PRICE(IBA,IBD,IBO)      ; sets IBD subscripted with price for IBA
    49         N IBX,IBB S IBB="UNIT PRICE"
    50         I $P(IBA(0),"^",12)["DGPM" D  Q
    51         . S IBD(1,IBO,IBB)=$$NUM($P(IBA(1),"^",2),2,9)
    52         I $P(IBA(0),"^",12)["PSRX(" D  Q
    53         . S IBD(1,IBO,IBB)=$$NUM($P(IBA(4),"^",3),3,10)
    54         I $P(IBA(0),"^",12)["RMPR(660," D  Q
    55         . S IBD(1,IBO,IBB)=$$NUM($P(IBA(4),"^",5),3,10)
    56         S IBX=0 F  S IBX=$O(^IBAT(351.61,IBA,3,IBX)) Q:IBX<1  D
    57         . S IBX(0)=^IBAT(351.61,IBIEN,3,IBX,0)
    58         . S IBD(IBX,IBO,IBB)=$$NUM($P(IBX(0),"^",3),2,9)
    59         Q
    60 QTY(IBA,IBD,IBO)        ; sets IBD subscripted with quantity for IBA
    61         N IBX,IBB S IBB="QTY"
    62         I $P(IBA(0),"^",12)["DGPM" D  Q
    63         . S IBD(1,IBO,IBB)=$$NUM($P(IBA(1),"^",5),0,3)
    64         I $P(IBA(0),"^",12)["PSRX(" D  Q
    65         . S IBD(1,IBO,IBB)=$$NUM($P(IBA(4),"^",2),0,3)
    66         I $P(IBA(0),"^",12)["RMPR(660," D  Q
    67         . S IBD(1,IBO,IBB)=$$NUM(1,0,3)
    68         S IBX=0 F  S IBX=$O(^IBAT(351.61,IBA,3,IBX)) Q:IBX<1  D
    69         . S IBX(0)=^IBAT(351.61,IBIEN,3,IBX,0)
    70         . S IBD(IBX,IBO,IBB)=$$NUM($P(IBX(0),"^",2),0,3)
    71         Q
    72 COPAY(IBA)      ; compute copay for iba and return
    73         N IBC,IBT,IBCOPAY
    74         S IBCOPAY=$$COPAY^IBATUTL($P(IBA(0),"^",2),$P(IBA(0),"^",12),$P($P(IBA(0),"^",9),"."),$P($P(IBA(0),"^",10),"."))
    75         I IBCOPAY,$P(IBA(0),"^",12)["SCE(" S (IBC,IBT)=0 F  S IBT=$O(^IBAT(351.61,"AH",$P(IBA(0),"^",2),$P(IBA(0),"^",4),IBT)) Q:IBT<1  I $P(^IBAT(351.61,IBT,0),"^",12)["SCE(" S IBC=IBC+1
    76         I  S IBCOPAY=IBCOPAY/IBC
    77         Q $$NUM(IBCOPAY,2,7)
    78         ;
    79 VAR(IBA)        ; set up required variables
    80         N IBX
    81         F IBX=0,1,4 S IBA(IBX)=$G(^IBAT(351.61,IBA,IBX))
    82         Q
    83 PRT(IBIEN)      ; main entry for report printing
    84         ;
    85         N DFN,IBXDATA,IBC,IBF,IBF1,IBF2,IBO,VA,VAERR,IBM
    86         ;
    87         D VAR(.IBIEN)
    88         S DFN=$P(IBIEN(0),"^",2)
    89         I IBPAGE=0!($Y+5>IOSL)!(IBLAST'=$P(IBIEN(0),"^",11)) S IBLAST=$P(IBIEN(0),"^",11) D PRTH Q:IBQUIT
    90         W ! S IBC=0
    91         ;
    92         ; print single valued data first
    93         S IBF=0 F  S IBF=$O(IBFIELD(IBF)) Q:IBF<1  D
    94         . D PRTG(.IBFIELD,.IBF,.IBF1,.IBC)
    95         . X ^IBAT(351.62,IBF1,1)
    96         . W IBXDATA,?IBC
    97         ;
    98         ; compute multiple valued data
    99         S IBM=IBC
    100         S IBF=0 F  S IBF=$O(IBMUL(IBF)) Q:IBF<1  D
    101         . S IBF1=0,IBF1=$O(IBMUL(IBF,IBF1))
    102         . X ^IBAT(351.62,IBF1,1)
    103         ;
    104         ; print multiple valued data
    105         S IBF=0 F  S IBF=$O(IBXDATA(IBF)) Q:IBF=""  W:IBC'=IBM ! W ?IBM S IBC=IBM D
    106         . S IBO=0 F  S IBO=$O(IBXDATA(IBF,IBO)) Q:IBO<1  S IBF1=0 F  S IBF1=$O(IBXDATA(IBF,IBO,IBF1)) Q:IBF1=""  D
    107         .. S IBF2=0,IBF2=$O(^IBAT(351.62,"B",IBF1,IBF2))
    108         .. S IBF2=^IBAT(351.62,IBF2,0)
    109         .. S IBC=IBC+$P(IBF2,"^",2)+1
    110         .. I IBC>IOM W !?5 S IBC=$P(IBF2,"^",2)+6
    111         .. W IBXDATA(IBF,IBO,IBF1),?IBC
    112         ;
    113         ; clean up
    114         X ^IBAT(351.62,999,1)
    115         ;
    116         Q
    117 EXPRT(IBIEN)    ; main entry for excel printing
    118         ;
    119         N DFN,IBXDATA,IBF,IBF1,IBF2,IBO,VA,VAERR
    120         ;
    121         D VAR(.IBIEN)
    122         S DFN=$P(IBIEN(0),"^",2)
    123         ;
    124         ; do single if no multiple
    125         I '$D(IBMUL) D EXSING() W ! X ^IBAT(351.62,999,1) Q
    126         ;
    127         ; compute multiple valued data
    128         S IBF=0 F  S IBF=$O(IBMUL(IBF)) Q:IBF<1  D
    129         . S IBF1=0,IBF1=$O(IBMUL(IBF,IBF1))
    130         . X ^IBAT(351.62,IBF1,1)
    131         ;
    132         ; print multiple valued data
    133         S IBF=0 F  S IBF=$O(IBXDATA(IBF)) Q:IBF=""  D EXSING(IBF) D
    134         . S IBO=0 F  S IBO=$O(IBXDATA(IBF,IBO)) Q:IBO<1  S IBF1=0 F  S IBF1=$O(IBXDATA(IBF,IBO,IBF1)) Q:IBF1=""  D
    135         .. S IBF2=0,IBF2=$O(^IBAT(351.62,"B",IBF1,IBF2))
    136         .. S IBF2=^IBAT(351.62,IBF2,0)
    137         .. W $$STRIP(IBXDATA(IBF,IBO,IBF1),IBF2),"|"
    138         . W !
    139         ;
    140         ; clean up
    141         X ^IBAT(351.62,999,1)
    142         ;
    143         Q
    144 STRIP(A,B)      ; strips off junk from numbers
    145         Q $S($P(B,"^",5):+$TR(A,", "),1:A)
    146         ;
    147 EXSING(IBF)     ; print single valued data first
    148         S IBF=0 F  S IBF=$O(IBFIELD(IBF)) Q:IBF<1  D
    149         . D PRTG(.IBFIELD,.IBF,.IBF1,.IBC)
    150         . X ^IBAT(351.62,IBF1,1)
    151         . W $$STRIP(IBXDATA,IBF1(0)),"|"
    152         Q
    153         ;
    154 PRTH    ; header
    155         S IBC=0
    156         D HEAD^IBATO($P(IBIEN(0),"^",11)) Q:IBQUIT
    157         W !
    158         S IBF=0 F  S IBF=$O(IBFIELD(IBF)) Q:IBF<1  D
    159         . D PRTG(.IBFIELD,.IBF,.IBF1,.IBC)
    160         . W $P(IBF1(0),"^"),?IBC
    161         ;
    162         ; multiple part of header
    163         S IBF=0 F  S IBF=$O(IBMUL(IBF)) Q:IBF<1  D
    164         . D PRTG(.IBMUL,.IBF,.IBF1,.IBC)
    165         . W $P(IBF1(0),"^"),?IBC
    166         ;
    167         W ! F IBC=1:1:IOM W "-"
    168         Q
    169 PRTG(X,Y,Z,C)   ; general printing stuff
    170         S Z=0,Z=$O(X(Y,Z))
    171         S Z(0)=X(Y,Z)
    172         I $D(C) S C=C+$P(Z(0),"^",2)+1 I C>IOM W !?5 S C=$P(Z(0),"^",2)+6
    173         Q
    174 SEL(B)  ; selection of which fields B = default
    175         ; sets up variables IBFIELD and IBMUL
    176         ; returns max length of output
    177         ;
    178         N DTOUT,DUOUT,DIRUT,DIROUT,DIR,W,X,Y,Z,IBR,IBM
    179         S (IBR,IBM)=0
    180         ;
    181 AGAIN   S DIR(0)="LAO^1:98",DIR("A")="Which fields: "_$S($D(B):B_"//",1:"")
    182         S DIR("?")="Select what fields you want printed. Ranges must start with a valid number."
    183         D ^DIR Q:$D(DTOUT)!($D(DUOUT))!($D(DIROUT)) 0
    184         ;
    185         ; if default selected set Y
    186         S:Y="" Y=$G(B)
    187         ;
    188         ; validate input
    189         I '$D(^IBAT(351.62,"AC",+Y)) W *7,"??" G AGAIN
    190         F X=1:1 Q:$P(Y,",",X)=""  S:'$D(^IBAT(351.62,"AC",$P(Y,",",X))) Y=$P(Y,",",1,X-1)_","_$P(Y,",",X+1,98),X=X-1
    191         ;
    192         ; setup variables for output
    193         F X=1:1 Q:'$P(Y,",",X)  S W=+$P($Q(^IBAT(351.62,"AC",$P(Y,",",X))),",",4),Z=^IBAT(351.62,W,0),IBR=$S($P(Z,"^",3):"IBMUL",1:"IBFIELD"),@(IBR_"("_X_","_W_")")=Z,@IBR=$G(@IBR)+$P(Z,"^",2)+1
    194         ;
    195         Q $G(IBFIELD)+$G(IBMUL)
    196         ;
    197 DISP    ; displays fields for selection
    198         ;
    199         N IBX,IBL,IBI
    200         ;
    201         ; set up lines
    202         S (IBX,IBL)=0 F  S IBX=$O(^IBAT(351.62,"AC",IBX)),IBL=IBL+1 Q:IBX<1  S:IBX=40 IBL=1 S IBI=+$P($Q(^IBAT(351.62,"AC",IBX)),",",4),IBL(IBL,$S(IBX<40:0,1:40))=^IBAT(351.62,IBI,0)
    203         ;
    204         ; display lines
    205         W @IOF,!,"Select the fields you would like printed on this report, in the order you",!,"want them printed.  Fields with an asterisk (*) are fields that are multiples.",!
    206         S IBX="" F  S IBX=$O(IBL(IBX)) Q:IBX=""  W ! S IBI="" F  S IBI=$O(IBL(IBX,IBI)) Q:IBI=""  W ?IBI,$P(IBL(IBX,IBI),"^",4),?IBI+4,$S($P(IBL(IBX,IBI),"^",3):"*",1:""),$P(IBL(IBX,IBI),"^")
    207         ;
    208         W !
    209         ;
    210         Q
     1IBATO1 ;LL/ELZ - TRANSFER PRICING REPORTS CONT. ; 18-DEC-98
     2 ;;2.0;INTEGRATED BILLING;**115,266**;21-MAR-94
     3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
     4 ;
     5PAGE() ; performs page reads and returns 1 if quiting is needed
     6 N DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
     7 S DIR(0)="E" D ^DIR
     8 Q $D(DIRUT)
     9NUM(X,X2,X3) ; calls to format numbers
     10 D COMMA^%DTC
     11 Q $E(X,1,$L(X)-1)
     12UNIT(IBA,IBD,IBO) ; sets IBD subscripted with units for IBA
     13 N IBX,IBB S IBB="UNIT"
     14 I $P(IBA(0),"^",12)["DGPM" D  Q
     15 . S IBD(1,IBO,IBB)=$$EX^IBATUTL(351.61,1.01,+IBA(1))
     16 I $P(IBA(0),"^",12)["PSRX(" D  Q
     17 . S IBD(1,IBO,IBB)=$$EX^IBATUTL(52,.01,+$P(IBA(0),"^",12))
     18 I $P(IBA(0),"^",12)["RMPR" D  Q
     19 . S IBD(1,IBO,IBB)="PROSTHETIC"
     20 S IBX=0 F  S IBX=$O(^IBAT(351.61,IBA,3,IBX)) Q:IBX<1  D
     21 . S IBX(0)=^IBAT(351.61,IBIEN,3,IBX,0)
     22 . S IBD(IBX,IBO,IBB)="CPT"_$P($$PROC^IBATUTL(+IBX(0)),U)
     23 Q
     24TYPE(IBA,IBO) ; sets IBO with descriptive trans type for IBA
     25 N IBB,IBC,IBD
     26 S:'$D(IBA(0)) IBA(0)=^IBAT(351.61,IBA,0)
     27 S IBB=$P(IBA(0),"^",12)
     28 I IBB["DGPM(" S IBO="INPATIENT" Q
     29 I IBB["PSRX(" S IBO="PHARMACY" Q
     30 I IBB["RMPR(660," S IBO="PROSTHETICS" Q
     31 D GETGEN^SDOE(+$P(IBA(0),"^",12),"IBC")
     32 D:$P($G(IBC(0)),"^",3) PARSE^SDOE(.IBC,"EXTERNAL","IBD")
     33 S IBO=$S($G(IBD(.03))="":"OUTPATINET",1:$E("OUT "_IBD(.03),1,10))
     34 Q
     35DES(IBA,IBD,IBO) ; sets IBD subscripted with description for IBA
     36 N IBX,IBB,IBDATE S IBB="UNIT DESCRIPTION"
     37 I $P(IBA(0),"^",12)["DGPM" D  Q
     38 . S IBD(1,IBO,IBB)=$E($$DRGTD^IBACSV(+IBA(1),$P(IBA(0),U,4)),1,18)
     39 I $P(IBA(0),"^",12)["PSRX(" D  Q
     40 . S IBD(1,IBO,IBB)=$E($$EX^IBATUTL(351.61,4.01,+IBA(4)),1,18)
     41 I $P(IBA(0),"^",12)["RMPR(660," D  Q
     42 . S IBD(1,IBO,IBB)=$E($$EX^IBATUTL(351.61,4.04,$P(IBA(4),"^",4)),1,18)
     43 S IBDATE=$P($G(^IBAT(351.61,IBIEN,0)),U,4) ; Event Date
     44 S IBX=0 F  S IBX=$O(^IBAT(351.61,IBA,3,IBX)) Q:IBX<1  D
     45 . S IBX(0)=^IBAT(351.61,IBIEN,3,IBX,0)
     46 . S IBD(IBX,IBO,IBB)=$E($P($$PROC^IBATUTL(+IBX(0),IBDATE),U,2),1,18)
     47 Q
     48PRICE(IBA,IBD,IBO) ; sets IBD subscripted with price for IBA
     49 N IBX,IBB S IBB="UNIT PRICE"
     50 I $P(IBA(0),"^",12)["DGPM" D  Q
     51 . S IBD(1,IBO,IBB)=$$NUM($P(IBA(1),"^",2),2,9)
     52 I $P(IBA(0),"^",12)["PSRX(" D  Q
     53 . S IBD(1,IBO,IBB)=$$NUM($P(IBA(4),"^",3),3,10)
     54 I $P(IBA(0),"^",12)["RMPR(660," D  Q
     55 . S IBD(1,IBO,IBB)=$$NUM($P(IBA(4),"^",5),3,10)
     56 S IBX=0 F  S IBX=$O(^IBAT(351.61,IBA,3,IBX)) Q:IBX<1  D
     57 . S IBX(0)=^IBAT(351.61,IBIEN,3,IBX,0)
     58 . S IBD(IBX,IBO,IBB)=$$NUM($P(IBX(0),"^",3),2,9)
     59 Q
     60QTY(IBA,IBD,IBO) ; sets IBD subscripted with quantity for IBA
     61 N IBX,IBB S IBB="QTY"
     62 I $P(IBA(0),"^",12)["DGPM" D  Q
     63 . S IBD(1,IBO,IBB)=$$NUM($P(IBA(1),"^",5),0,3)
     64 I $P(IBA(0),"^",12)["PSRX(" D  Q
     65 . S IBD(1,IBO,IBB)=$$NUM($P(IBA(4),"^",2),0,3)
     66 I $P(IBA(0),"^",12)["RMPR(660," D  Q
     67 . S IBD(1,IBO,IBB)=$$NUM(1,0,3)
     68 S IBX=0 F  S IBX=$O(^IBAT(351.61,IBA,3,IBX)) Q:IBX<1  D
     69 . S IBX(0)=^IBAT(351.61,IBIEN,3,IBX,0)
     70 . S IBD(IBX,IBO,IBB)=$$NUM($P(IBX(0),"^",2),0,3)
     71 Q
     72COPAY(IBA) ; compute copay for iba and return
     73 N IBC,IBT,IBCOPAY
     74 S IBCOPAY=$$COPAY^IBATUTL($P(IBA(0),"^",2),$P(IBA(0),"^",12),$P($P(IBA(0),"^",9),"."),$P($P(IBA(0),"^",10),"."))
     75 I IBCOPAY,$P(IBA(0),"^",12)["SCE(" S (IBC,IBT)=0 F  S IBT=$O(^IBAT(351.61,"AH",$P(IBA(0),"^",2),$P(IBA(0),"^",4),IBT)) Q:IBT<1  I $P(^IBAT(351.61,IBT,0),"^",12)["SCE(" S IBC=IBC+1
     76 I  S IBCOPAY=IBCOPAY/IBC
     77 Q $$NUM(IBCOPAY,2,7)
     78 ;
     79VAR(IBA) ; set up required variables
     80 N IBX
     81 F IBX=0,1,4 S IBA(IBX)=$G(^IBAT(351.61,IBA,IBX))
     82 Q
     83PRT(IBIEN) ; main entry for report printing
     84 ;
     85 N DFN,IBXDATA,IBC,IBF,IBF1,IBF2,IBO,VA,VAERR,IBM
     86 ;
     87 D VAR(.IBIEN)
     88 S DFN=$P(IBIEN(0),"^",2)
     89 I IBPAGE=0!($Y+5>IOSL)!(IBLAST'=$P(IBIEN(0),"^",11)) S IBLAST=$P(IBIEN(0),"^",11) D PRTH Q:IBQUIT
     90 W ! S IBC=0
     91 ;
     92 ; print single valued data first
     93 S IBF=0 F  S IBF=$O(IBFIELD(IBF)) Q:IBF<1  D
     94 . D PRTG(.IBFIELD,.IBF,.IBF1,.IBC)
     95 . X ^IBAT(351.62,IBF1,1)
     96 . W IBXDATA,?IBC
     97 ;
     98 ; compute multiple valued data
     99 S IBM=IBC
     100 S IBF=0 F  S IBF=$O(IBMUL(IBF)) Q:IBF<1  D
     101 . S IBF1=0,IBF1=$O(IBMUL(IBF,IBF1))
     102 . X ^IBAT(351.62,IBF1,1)
     103 ;
     104 ; print multiple valued data
     105 S IBF=0 F  S IBF=$O(IBXDATA(IBF)) Q:IBF=""  W:IBC'=IBM ! W ?IBM S IBC=IBM D
     106 . S IBO=0 F  S IBO=$O(IBXDATA(IBF,IBO)) Q:IBO<1  S IBF1=0 F  S IBF1=$O(IBXDATA(IBF,IBO,IBF1)) Q:IBF1=""  D
     107 .. S IBF2=0,IBF2=$O(^IBAT(351.62,"B",IBF1,IBF2))
     108 .. S IBF2=^IBAT(351.62,IBF2,0)
     109 .. S IBC=IBC+$P(IBF2,"^",2)+1
     110 .. I IBC>IOM W !?5 S IBC=$P(IBF2,"^",2)+6
     111 .. W IBXDATA(IBF,IBO,IBF1),?IBC
     112 ;
     113 ; clean up
     114 X ^IBAT(351.62,999,1)
     115 ;
     116 Q
     117EXPRT(IBIEN) ; main entry for excel printing
     118 ;
     119 N DFN,IBXDATA,IBF,IBF1,IBF2,IBO,VA,VAERR
     120 ;
     121 D VAR(.IBIEN)
     122 S DFN=$P(IBIEN(0),"^",2)
     123 ;
     124 ; do single if no multiple
     125 I '$D(IBMUL) D EXSING() W ! X ^IBAT(351.62,999,1) Q
     126 ;
     127 ; compute multiple valued data
     128 S IBF=0 F  S IBF=$O(IBMUL(IBF)) Q:IBF<1  D
     129 . S IBF1=0,IBF1=$O(IBMUL(IBF,IBF1))
     130 . X ^IBAT(351.62,IBF1,1)
     131 ;
     132 ; print multiple valued data
     133 S IBF=0 F  S IBF=$O(IBXDATA(IBF)) Q:IBF=""  D EXSING(IBF) D
     134 . S IBO=0 F  S IBO=$O(IBXDATA(IBF,IBO)) Q:IBO<1  S IBF1=0 F  S IBF1=$O(IBXDATA(IBF,IBO,IBF1)) Q:IBF1=""  D
     135 .. S IBF2=0,IBF2=$O(^IBAT(351.62,"B",IBF1,IBF2))
     136 .. S IBF2=^IBAT(351.62,IBF2,0)
     137 .. W $$STRIP(IBXDATA(IBF,IBO,IBF1),IBF2),"|"
     138 . W !
     139 ;
     140 ; clean up
     141 X ^IBAT(351.62,999,1)
     142 ;
     143 Q
     144STRIP(A,B) ; strips off junk from numbers
     145 Q $S($P(B,"^",5):+$TR(A,", "),1:A)
     146 ;
     147EXSING(IBF) ; print single valued data first
     148 S IBF=0 F  S IBF=$O(IBFIELD(IBF)) Q:IBF<1  D
     149 . D PRTG(.IBFIELD,.IBF,.IBF1,.IBC)
     150 . X ^IBAT(351.62,IBF1,1)
     151 . W $$STRIP(IBXDATA,IBF1(0)),"|"
     152 Q
     153 ;
     154PRTH ; header
     155 S IBC=0
     156 D HEAD^IBATO($P(IBIEN(0),"^",11)) Q:IBQUIT
     157 W !
     158 S IBF=0 F  S IBF=$O(IBFIELD(IBF)) Q:IBF<1  D
     159 . D PRTG(.IBFIELD,.IBF,.IBF1,.IBC)
     160 . W $P(IBF1(0),"^"),?IBC
     161 ;
     162 ; multiple part of header
     163 S IBF=0 F  S IBF=$O(IBMUL(IBF)) Q:IBF<1  D
     164 . D PRTG(.IBMUL,.IBF,.IBF1,.IBC)
     165 . W $P(IBF1(0),"^"),?IBC
     166 ;
     167 W ! F IBC=1:1:IOM W "-"
     168 Q
     169PRTG(X,Y,Z,C) ; general printing stuff
     170 S Z=0,Z=$O(X(Y,Z))
     171 S Z(0)=X(Y,Z)
     172 I $D(C) S C=C+$P(Z(0),"^",2)+1 I C>IOM W !?5 S C=$P(Z(0),"^",2)+6
     173 Q
     174SEL(B) ; selection of which fields B = default
     175 ; sets up variables IBFIELD and IBMUL
     176 ; returns max length of output
     177 ;
     178 N DTOUT,DUOUT,DIRUT,DIROUT,DIR,W,X,Y,Z,IBR,IBM
     179 S (IBR,IBM)=0
     180 ;
     181AGAIN S DIR(0)="LAO^1:98",DIR("A")="Which fields: "_$S($D(B):B_"//",1:"")
     182 S DIR("?")="Select what fields you want printed. Ranges must start with a valid number."
     183 D ^DIR Q:$D(DTOUT)!($D(DUOUT))!($D(DIROUT)) 0
     184 ;
     185 ; if default selected set Y
     186 S:Y="" Y=$G(B)
     187 ;
     188 ; validate input
     189 I '$D(^IBAT(351.62,"AC",+Y)) W *7,"??" G AGAIN
     190 F X=1:1 Q:$P(Y,",",X)=""  S:'$D(^IBAT(351.62,"AC",$P(Y,",",X))) Y=$P(Y,",",1,X-1)_","_$P(Y,",",X+1,98),X=X-1
     191 ;
     192 ; setup variables for output
     193 F X=1:1 Q:'$P(Y,",",X)  S W=+$P($Q(^IBAT(351.62,"AC",$P(Y,",",X))),",",4),Z=^IBAT(351.62,W,0),IBR=$S($P(Z,"^",3):"IBMUL",1:"IBFIELD"),@(IBR_"("_X_","_W_")")=Z,@IBR=$G(@IBR)+$P(Z,"^",2)+1
     194 ;
     195 Q $G(IBFIELD)+$G(IBMUL)
     196 ;
     197DISP ; displays fields for selection
     198 ;
     199 N IBX,IBL,IBI
     200 ;
     201 ; set up lines
     202 S (IBX,IBL)=0 F  S IBX=$O(^IBAT(351.62,"AC",IBX)),IBL=IBL+1 Q:IBX<1  S:IBX=40 IBL=1 S IBI=+$P($Q(^IBAT(351.62,"AC",IBX)),",",4),IBL(IBL,$S(IBX<40:0,1:40))=^IBAT(351.62,IBI,0)
     203 ;
     204 ; display lines
     205 W @IOF,!,"Select the fields you would like printed on this report, in the order you",!,"want them printed.  Fields with an asterisk (*) are fields that are multiples.",!
     206 S IBX="" F  S IBX=$O(IBL(IBX)) Q:IBX=""  W ! S IBI="" F  S IBI=$O(IBL(IBX,IBI)) Q:IBI=""  W ?IBI,$P(IBL(IBX,IBI),"^",4),?IBI+4,$S($P(IBL(IBX,IBI),"^",3):"*",1:""),$P(IBL(IBX,IBI),"^")
     207 ;
     208 W !
     209 ;
     210 Q

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBATUTL.m

    r613 r623  
    1 IBATUTL ;LL/ELZ - TRANSFER PRICING UTILITES ; 3-SEP-1998
    2         ;;2.0;INTEGRATED BILLING;**115,266,347,389**;21-MAR-94;Build 6
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5 SL()    ; -- called to select a patient or enrolled facility
    6         N X,Y,DTOUT,DUOUT,DIRUT,DIROUT,DIR
    7         S DIR(0)="350.9,10.01",DIR("A")="Select Patient or Enrolled Facility"
    8         D ^DIR
    9         Q Y
    10 SLPT()  ; -- called to select a patient, returns 0 or patient dfn
    11         N X,Y,DIC,DTOUT,DUOUT
    12         S DIC="^IBAT(351.6,",DIC(0)="AEMQ" D ^DIC
    13         Q $S(+Y>0:+Y,1:0)
    14         ;
    15 SLDR(Q) ; -- called to select a date range
    16         ; defaults are from=T-365, to=TODAY
    17         ; output IBBDT, IBEDT, quit returns 0 if not valid
    18         ;
    19         N DIR,DIRUT,DUOUT,DTOUT,DIROUT,X,Y,IBDT
    20         S DIR(0)="DA^:NOW:EX",DIR("A")="Select FROM DATE: "
    21         S:$D(Q) DIR("?")=Q
    22         D ^DIR G:'Y SLDRQ S IBDT=+Y
    23         S DIR(0)="DA^"_+Y_":NOW:EX",DIR("A")="              TO: "
    24         D ^DIR
    25         S:Y IBEDT=+Y+.999999,IBBDT=IBDT G SLDRQ
    26 SLDR1Y()        ; -- called to select a date range w/1y past default
    27         ; defaults are from=T-365, to=TODAY
    28         ; output IBBDT, IBEDT, quit returns 0 if not valid
    29         ;
    30         N DIR,DIRUT,DUOUT,DTOUT,DIROUT,X,Y,IBDT
    31         S DIR(0)="DA^:NOW:EX",DIR("A")="Select FROM DATE: "
    32         S DIR("B")=$$DAT2^IBOUTL($$FMADD^XLFDT(DT,-365)) D ^DIR
    33         G:'Y SLDRQ S IBDT=+Y
    34         S DIR(0)="DA^"_+Y_":NOW:EX",DIR("A")="              to: "
    35         S DIR("B")=$$DAT2^IBOUTL($$FMADD^XLFDT(IBDT,365)) D ^DIR
    36         G:'Y SLDRQ S IBEDT=+Y+.999999,IBBDT=IBDT
    37 SLDRQ   Q $D(DIRUT)!($D(DUOUT))
    38         ;
    39 PTTRAN(IBFILE,IBARRAY,IBXREF)   ; builds a list of patient transactions by date
    40         ; assumes DFN, IBBDT, IBEDT
    41         ; input IBARRAY - where to store info
    42         ;       IBXREF  - which date x-ref to use
    43         ; output 0,6 node of file IBFILE in array specified
    44         ;
    45         N IBIEN,IBDT,IBNODE
    46         K @IBARRAY
    47         S IBDT=IBBDT-.999999
    48         F  S IBDT=$O(^IBAT(IBFILE,IBXREF,DFN,IBDT)) Q:IBDT<1!(IBDT>IBEDT)  D
    49         . S IBIEN=0
    50         . F  S IBIEN=$O(^IBAT(IBFILE,IBXREF,DFN,IBDT,IBIEN)) Q:IBIEN<1  D
    51         .. F IBNODE=0,6 S @IBARRAY@(IBDT,IBIEN,IBNODE)=$G(^IBAT(IBFILE,IBIEN,IBNODE))
    52         Q
    53 LMOPT   ; -- called to do standard listmanager option calling
    54         D FULL^VALM1
    55         S VALMBCK="R"
    56         Q
    57         ;
    58 SETVALM(LINE,TEXT,IEN,ON,OFF)   ; -- sets up listmanager lines
    59         S LINE=LINE+1
    60         D SET^VALM10(LINE,TEXT,LINE)
    61         S:$G(IEN) @VALMAR@("INDEX",LINE,IEN)=""
    62         D:$G(ON)]""!($G(OFF)]"") CNTRL^VALM10(LINE,1,$L(TEXT),$G(ON),$G(OFF))
    63         W:'(LINE#5) "."
    64         Q LINE
    65         ;
    66 VISN(STATION)   ; -- looks up ien & name of VISN from ien of station
    67         N IBAT
    68         D PARENT^XUAF4("IBAT","`"_STATION,"VISN")
    69         S IBAT=0,IBAT=$O(IBAT("P",IBAT))
    70         Q $S(IBAT:IBAT_"^"_$P(IBAT("P",IBAT),"^"),1:"")
    71         ;
    72 ONEFAC()        ; returns one facility only, no visns allowed
    73         N DIC,DTOUT,DUOUT,X,Y
    74         S DIC="^DIC(4,",DIC(0)="AEMNQ"
    75         S DIC("S")="I $$SCR^IBATUTL(Y),$$INST^IBATUTL(Y)'[""VISN"""
    76         D ^DIC
    77         Q Y
    78 FAC()   ; -- facility/visn or all selection
    79         N DIC,X,Y,DTOUT,DUOUT K IBFAC
    80         S DIC="^DIC(4,",DIC(0)="EQMNZ"
    81         S DIC("S")="I $$SCR^IBATUTL(Y)"
    82 REDO    W !,"Select FACILITY/VISN: ALL// " R X:DTIME Q:(X["^")!'$T 1
    83         I X="?" W !,"Select a Facility (Name or Number), VISN (VISN XX), or press RETURN for ALL" G REDO
    84         I X=""!($$UP^XLFSTR(X)="ALL") Q 0
    85         D ^DIC G:Y<1 REDO D SET(Y)
    86         S DIC("A")="Select another FACILITY/VISN: ",DIC(0)="AEQMNZ"
    87         F  D ^DIC Q:X=""!(Y<1)  D SET(Y)
    88         Q 0
    89 SET(Y)  I Y'["VISN" N IBVISN D PARENT^XUAF4("IBVISN","`"_+Y,"VISN") D
    90         . S IBVISN=0,IBVISN=$O(IBVISN("P",IBVISN))
    91         . S IBFAC(IBVISN,"C",+Y)=$$INST(+Y)
    92         E  S IBFAC(+Y)="" D CHILDREN^XUAF4("IBFAC(+Y)","`"_+Y,"VISN")
    93         Q
    94 SCR(X)  ; screens invalid institution file entries
    95         N IBVISN
    96         ;Q:$P(X,".",2) 0
    97         D PARENT^XUAF4("IBVISN","`"_X,"VISN")
    98         S IBVISN=0,IBVISN=$O(IBVISN("P",IBVISN)) I IBVISN Q 1
    99         D CHILDREN^XUAF4("IBVISN","`"_X,"VISN")
    100         S IBVISN=0,IBVISN=$O(IBVISN("C",IBVISN)) I IBVISN Q 1
    101         Q 0
    102 PPF(DFN)        ; returns patient's enrolled/preferred facility
    103         N IBPPF
    104         ; first find current enrolment
    105         S IBPPF=+$$PREF^DGENPTA(DFN) ; dbia #2919
    106         ; now if they are already tp update if necessary
    107         I $D(^IBAT(351.6,DFN)),$P(^(DFN,0),"^",3)'=IBPPF D UPPPF^IBATFILE(DFN,IBPPF)
    108         ; now if they have an over ride facility use that
    109         Q $S($P($G(^IBAT(351.6,DFN,0)),"^",10):$P(^(0),"^",10),IBPPF=$$SITE:0,1:IBPPF)
    110 TPP(DFN)        ; returns dfn and files patient if a valid tp patient
    111         N IBSITE,IBPPF
    112         S IBSITE=$$SITE
    113         S IBPPF=$$PPF(DFN)
    114         I IBPPF,IBSITE'=IBPPF  S DFN=+$$PAT^IBATFILE(DFN,IBPPF)
    115         I DFN,$P($G(^IBAT(351.6,DFN,0)),"^",4) Q DFN
    116         Q 0
    117 SITE()  ; returns ien of current va site (this way I have only one outside call
    118         Q +$$SITE^VASITE
    119         ;
    120 INST(DA)        ; returns institution file info
    121         ; This will return the station name ^ station number ^ station type
    122         ; DA - The pointer value into file 4.
    123         I '$D(^DIC(4,DA,0)) Q 0
    124         Q $$NNT^XUAF4(DA)
    125 IPT(X)  ; returns institution file pointer from name
    126         Q $$LKUP^XUAF4(X)
    127 PROC(X,IBDATE)  ; -- returns CPT and descriptive name for cpts
    128         S X=$$CPT^ICPTCOD(X,$G(IBDATE))
    129         Q $P(X,"^",2,3)
    130 COPAY(DFN,IBFROM,IBBDT,IBEDT)   ; -- returns copay amount if any
    131         ; dfn=patient's dfn, from=what event the bill is from
    132         ; ibbdt & ibedt are date ranges (n/a for rx)
    133         N IBAMT,Y,Y1,IBDA,IBX S IBAMT=0
    134         I IBFROM["PSRX(" D  Q IBAMT
    135         . I $P(IBFROM,";",3)>0 D  Q
    136         .. ; refills
    137         .. S IBFROM=$$SUBFILE^IBRXUTL(+IBFROM,$P(IBFROM,";",3),52,9) I 'IBFROM Q
    138         .. S IBAMT=$P($G(^IB(IBFROM,0)),"^",7)
    139         . E  D  Q
    140         .. ; initial fill
    141         .. S IBFROM=$$FILE^IBRXUTL(+IBFROM,106) I 'IBFROM Q
    142         .. S IBAMT=$P($G(^IB(IBFROM,0)),"^",7)
    143         ; now on to scheduling and admissions
    144         S Y="" F  S Y=$O(^IB("AFDT",DFN,Y)) Q:'Y  I -Y'>IBEDT S Y1=0 F  S Y1=$O(^IB("AFDT",DFN,Y,Y1)) Q:'Y1  D
    145         . S IBDA=0 F  S IBDA=$O(^IB("AF",Y1,IBDA)) Q:'IBDA  D
    146         .. Q:'$D(^IB(IBDA,0))  S IBX=^(0)
    147         .. Q:$P(IBX,"^",8)["ADMISSION"
    148         .. ;
    149         .. ; quit if not correct type (inpatient vs outpatient)
    150         .. Q:$S(IBFROM["SCE("&($P($P(IBX,"^",4),":")'=409.68):1,IBFROM["DGPM("&($P($P(IBX,"^",4),":")=409.68):1,1:0)
    151         .. ;
    152         .. I $P(IBX,"^",15)<IBBDT!($P(IBX,"^",14)>IBEDT) Q
    153         .. S IBAMT=IBAMT+$P(IBX,"^",7)
    154         Q IBAMT
    155 FINDT(X)        ; -- looks up transactions for source in X
    156         ; returns ien of 351.61 if not cancelled
    157         Q:$G(X)="" 0
    158         N Y,Z S (Y,Z)=0
    159         F  S Y=$O(^IBAT(351.61,"AD",X,Y)) Q:Y<1!(Z)  D
    160         . I $G(^IBAT(351.61,Y,0)),$P(^(0),"^",5)'="X" S Z=Y
    161         Q Z
    162         ;
    163 PIN(P660,P6611) ; return Prosthetics Item Description (#661.1,.02)
    164         ; input:  P660 - pointer to Patient Item (#660) or P6611 - pointer to HCPCS (#661.1)
    165         ; return: pointer to HCPCS (#661.1) ^ Short Description (#661.1,.01) ^ HCPCS (#661.1,.01)
    166         N IBX,IBY S IBY=""
    167         I +$G(P660) S P6611=+$P($G(^RMPR(660,+P660,1)),U,4)
    168         I +$G(P6611) S IBX=$G(^RMPR(661.1,+P6611,0)) I IBX'="" S IBY=P6611_U_$P(IBX,U,2)_U_$P(IBX,U,1)
    169         Q IBY
    170         ;
    171 EX(FILE,FIELD,VALUE)    ; -- return external value
    172         N Y,C S Y=$G(VALUE)
    173         I +$G(FILE),+$G(FIELD),Y'="" S C=$P(^DD(FILE,FIELD,0),"^",2) D Y^DIQ
    174         Q Y
    175         ;
     1IBATUTL ;LL/ELZ - TRANSFER PRICING UTILITES ; 3-SEP-1998
     2 ;;2.0;INTEGRATED BILLING;**115,266,347**;21-MAR-94;Build 24
     3 ;;Per VHA Directive 2004-038, this routine should not be modified.
     4 ;
     5SL() ; -- called to select a patient or enrolled facility
     6 N X,Y,DTOUT,DUOUT,DIRUT,DIROUT,DIR
     7 S DIR(0)="350.9,10.01",DIR("A")="Select Patient or Enrolled Facility"
     8 D ^DIR
     9 Q Y
     10SLPT() ; -- called to select a patient, returns 0 or patient dfn
     11 N X,Y,DIC,DTOUT,DUOUT
     12 S DIC="^IBAT(351.6,",DIC(0)="AEMQ" D ^DIC
     13 Q $S(+Y>0:+Y,1:0)
     14 ;
     15SLDR(Q) ; -- called to select a date range
     16 ; defaults are from=T-365, to=TODAY
     17 ; output IBBDT, IBEDT, quit returns 0 if not valid
     18 ;
     19 N DIR,DIRUT,DUOUT,DTOUT,DIROUT,X,Y,IBDT
     20 S DIR(0)="DA^:NOW:EX",DIR("A")="Select FROM DATE: "
     21 S:$D(Q) DIR("?")=Q
     22 D ^DIR G:'Y SLDRQ S IBDT=+Y
     23 S DIR(0)="DA^"_+Y_":NOW:EX",DIR("A")="              TO: "
     24 D ^DIR
     25 S:Y IBEDT=+Y+.999999,IBBDT=IBDT G SLDRQ
     26SLDR1Y() ; -- called to select a date range w/1y past default
     27 ; defaults are from=T-365, to=TODAY
     28 ; output IBBDT, IBEDT, quit returns 0 if not valid
     29 ;
     30 N DIR,DIRUT,DUOUT,DTOUT,DIROUT,X,Y,IBDT
     31 S DIR(0)="DA^:NOW:EX",DIR("A")="Select FROM DATE: "
     32 S DIR("B")=$$DAT2^IBOUTL($$FMADD^XLFDT(DT,-365)) D ^DIR
     33 G:'Y SLDRQ S IBDT=+Y
     34 S DIR(0)="DA^"_+Y_":NOW:EX",DIR("A")="              to: "
     35 S DIR("B")=$$DAT2^IBOUTL($$FMADD^XLFDT(IBDT,365)) D ^DIR
     36 G:'Y SLDRQ S IBEDT=+Y+.999999,IBBDT=IBDT
     37SLDRQ Q $D(DIRUT)!($D(DUOUT))
     38 ;
     39PTTRAN(IBFILE,IBARRAY,IBXREF) ; builds a list of patient transactions by date
     40 ; assumes DFN, IBBDT, IBEDT
     41 ; input IBARRAY - where to store info
     42 ;       IBXREF  - which date x-ref to use
     43 ; output 0,6 node of file IBFILE in array specified
     44 ;
     45 N IBIEN,IBDT,IBNODE
     46 K @IBARRAY
     47 S IBDT=IBBDT-.999999
     48 F  S IBDT=$O(^IBAT(IBFILE,IBXREF,DFN,IBDT)) Q:IBDT<1!(IBDT>IBEDT)  D
     49 . S IBIEN=0
     50 . F  S IBIEN=$O(^IBAT(IBFILE,IBXREF,DFN,IBDT,IBIEN)) Q:IBIEN<1  D
     51 .. F IBNODE=0,6 S @IBARRAY@(IBDT,IBIEN,IBNODE)=$G(^IBAT(IBFILE,IBIEN,IBNODE))
     52 Q
     53LMOPT ; -- called to do standard listmanager option calling
     54 D FULL^VALM1
     55 S VALMBCK="R"
     56 Q
     57 ;
     58SETVALM(LINE,TEXT,IEN,ON,OFF) ; -- sets up listmanager lines
     59 S LINE=LINE+1
     60 D SET^VALM10(LINE,TEXT,LINE)
     61 S:$G(IEN) @VALMAR@("INDEX",LINE,IEN)=""
     62 D:$G(ON)]""!($G(OFF)]"") CNTRL^VALM10(LINE,1,$L(TEXT),$G(ON),$G(OFF))
     63 W:'(LINE#5) "."
     64 Q LINE
     65 ;
     66VISN(STATION) ; -- looks up ien & name of VISN from ien of station
     67 N IBAT
     68 D PARENT^XUAF4("IBAT","`"_STATION,"VISN")
     69 S IBAT=0,IBAT=$O(IBAT("P",IBAT))
     70 Q $S(IBAT:IBAT_"^"_$P(IBAT("P",IBAT),"^"),1:"")
     71 ;
     72ONEFAC() ; returns one facility only, no visns allowed
     73 N DIC,DTOUT,DUOUT,X,Y
     74 S DIC="^DIC(4,",DIC(0)="AEMNQ"
     75 S DIC("S")="I $$SCR^IBATUTL(Y),$$INST^IBATUTL(Y)'[""VISN"""
     76 D ^DIC
     77 Q Y
     78FAC() ; -- facility/visn or all selection
     79 N DIC,X,Y,DTOUT,DUOUT K IBFAC
     80 S DIC="^DIC(4,",DIC(0)="EQMNZ"
     81 S DIC("S")="I $$SCR^IBATUTL(Y)"
     82REDO W !,"Select FACILITY/VISN: ALL// " R X:DTIME Q:(X["^")!'$T 1
     83 I X="?" W !,"Select a Facility (Name or Number), VISN (VISN XX), or press RETURN for ALL" G REDO
     84 I X=""!($$UP^XLFSTR(X)="ALL") Q 0
     85 D ^DIC G:Y<1 REDO D SET(Y)
     86 S DIC("A")="Select another FACILITY/VISN: ",DIC(0)="AEQMNZ"
     87 F  D ^DIC Q:X=""!(Y<1)  D SET(Y)
     88 Q 0
     89SET(Y) I Y'["VISN" N IBVISN D PARENT^XUAF4("IBVISN","`"_+Y,"VISN") D
     90 . S IBVISN=0,IBVISN=$O(IBVISN("P",IBVISN))
     91 . S IBFAC(IBVISN,"C",+Y)=$$INST(+Y)
     92 E  S IBFAC(+Y)="" D CHILDREN^XUAF4("IBFAC(+Y)","`"_+Y,"VISN")
     93 Q
     94SCR(X) ; screens invalid institution file entries
     95 N IBVISN
     96 ;Q:$P(X,".",2) 0
     97 D PARENT^XUAF4("IBVISN","`"_X,"VISN")
     98 S IBVISN=0,IBVISN=$O(IBVISN("P",IBVISN)) I IBVISN Q 1
     99 D CHILDREN^XUAF4("IBVISN","`"_X,"VISN")
     100 S IBVISN=0,IBVISN=$O(IBVISN("C",IBVISN)) I IBVISN Q 1
     101 Q 0
     102PPF(DFN) ; returns patient's enrolled/preferred facility
     103 N IBPPF
     104 ; first find current enrolment
     105 S IBPPF=+$$PREF^DGENPTA(DFN) ; dbia #2919
     106 ; now if they are already tp update if necessary
     107 I $D(^IBAT(351.6,DFN)),$P(^(DFN,0),"^",3)'=IBPPF D UPPPF^IBATFILE(DFN,IBPPF)
     108 ; now if they have an over ride facility use that
     109 Q $S($P($G(^IBAT(351.6,DFN,0)),"^",10):$P(^(0),"^",10),IBPPF=$$SITE:0,1:IBPPF)
     110TPP(DFN) ; returns dfn and files patient if a valid tp patient
     111 N IBSITE,IBPPF
     112 S IBSITE=$$SITE
     113 S IBPPF=$$PPF(DFN)
     114 I IBPPF,IBSITE'=IBPPF  S DFN=+$$PAT^IBATFILE(DFN,IBPPF)
     115 I DFN,$P($G(^IBAT(351.6,DFN,0)),"^",4) Q DFN
     116 Q 0
     117SITE() ; returns ien of current va site (this way I have only one outside call
     118 Q +$$SITE^VASITE
     119 ;
     120INST(DA) ; returns institution file info
     121 ; This will return the station name ^ station number ^ station type
     122 ; DA - The pointer value into file 4.
     123 I '$D(^DIC(4,DA,0)) Q 0
     124 Q $$NNT^XUAF4(DA)
     125IPT(X) ; returns institution file pointer from name
     126 Q $$LKUP^XUAF4(X)
     127PROC(X,IBDATE) ; -- returns CPT and descriptive name for cpts
     128 S X=$$CPT^ICPTCOD(X,$G(IBDATE))
     129 Q $P(X,"^",2,3)
     130COPAY(DFN,IBFROM,IBBDT,IBEDT) ; -- returns copay amount if any
     131 ; dfn=patient's dfn, from=what event the bill is from
     132 ; ibbdt & ibedt are date ranges (n/a for rx)
     133 N IBAMT,Y,Y1,IBDA,IBX S IBAMT=0
     134 I IBFROM["PSRX(" D  Q IBAMT
     135 . I $P(IBFROM,";",3)>0 D  Q
     136 .. ; refills
     137 .. S IBFROM=$$SUBFILE^IBRXUTL(+IBFROM,$P(IBFROM,";",3),52,9) I 'IBFROM Q
     138 .. S IBAMT=$P($G(^IB(IBFROM,0)),"^",7)
     139 . E  D  Q
     140 .. ; initial fill
     141 .. S IBFROM=$$FILE^IBRXUTL(+IBFROM,106) I 'IBFROM Q
     142 .. S IBAMT=$P($G(^IB(IBFROM,0)),"^",7)
     143 ; now on to scheduling and admissions
     144 S Y="" F  S Y=$O(^IB("AFDT",DFN,Y)) Q:'Y  I -Y'>IBEDT S Y1=0 F  S Y1=$O(^IB("AFDT",DFN,Y,Y1)) Q:'Y1  D
     145 . S IBDA=0 F  S IBDA=$O(^IB("AF",Y1,IBDA)) Q:'IBDA  D
     146 .. Q:'$D(^IB(IBDA,0))  S IBX=^(0)
     147 .. Q:$P(IBX,"^",8)["ADMISSION"
     148 .. ;
     149 .. ; quit if not correct type (inpatient vs outpatient)
     150 .. Q:$S(IBFROM["SCE("&($P($P(IBX,"^",4),":")'=409.68):1,IBFROM["DGPM("&($P($P(IBX,"^",4),":")=409.68):1,1:0)
     151 .. ;
     152 .. I $P(IBX,"^",15)<IBBDT!($P(IBX,"^",14)>IBEDT) Q
     153 .. S IBAMT=IBAMT+$P(IBX,"^",7)
     154 Q IBAMT
     155FINDT(X) ; -- looks up transactions for source in X
     156 ; returns ien of 351.61 if not cancelled
     157 Q:$G(X)="" 0
     158 N Y,Z S (Y,Z)=0
     159 F  S Y=$O(^IBAT(351.61,"AD",X,Y)) Q:Y<1!(Z)  D
     160 . I $G(^IBAT(351.61,Y,0)),$P(^(0),"^",5)'="X" S Z=Y
     161 Q Z
     162 ;
     163EX(FILE,FIELD,VALUE) ; -- return external value
     164 N Y,C S Y=$G(VALUE)
     165 I +$G(FILE),+$G(FIELD),Y'="" S C=$P(^DD(FILE,FIELD,0),"^",2) D Y^DIQ
     166 Q Y
     167 ;

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCBB.m

    r613 r623  
    1 IBCBB   ;ALB/AAS - EDIT CHECK ROUTINE TO BE INVOKED BEFORE ALL BILL APPROVAL ACTIONS ;2-NOV-89
    2         ;;2.0;INTEGRATED BILLING;**80,51,137,288,327,361,371,377**;21-MAR-94;Build 23
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5         ;MAP TO DGCRBB
    6         ;
    7         ;IBNDn = IBND(n) = ^ib(399,n)
    8         ;RETURNS:
    9         ;IBER=fields with errors separated by semi-colons
    10         ;PRCASV("OKAY")=1 if iber="" and $D(prcasv("array")) compete
    11         ;
    12 GVAR    ;set up variables for mccr
    13         Q:'$D(IBIFN)  F I=0,"M","U","U1","S","MP","TX","UF3","UF31","U2" S @("IBND"_I)=$G(^DGCR(399,IBIFN,I))
    14         S IBBNO=$P(IBND0,"^"),DFN=$P(IBND0,"^",2),IBEVDT=$P(IBND0,"^",3)
    15         S IBLOC=$P(IBND0,"^",4),IBCL=$P(IBND0,"^",5),IBTF=$P(IBND0,"^",6)
    16         S IBAT=$P(IBND0,"^",7),IBWHO=$P(IBND0,"^",11),IBST=$P(IBND0,"^",13),IBFT=$P(IBND0,"^",19)
    17         S IBFDT=$P(IBNDU,"^",1),IBTDT=$P(IBNDU,"^",2)
    18         S IBTC=$P(IBNDU1,"^",1),IBFY=$P(IBNDU1,"^",9),IBFYC=$P(IBNDU1,"^",10)
    19         S IBEU=$P(IBNDS,"^",2),IBRU=$P(IBNDS,"^",5),IBAU=$P(IBNDS,"^",8)
    20         S IBTOB=$$TOB(IBND0),IBTOB12=$E(IBTOB,1,2)
    21         K ^TMP($J,"BILL-WARN")
    22         Q
    23         ;
    24 EN      ;Entry to check for errors
    25         N IBQ,IBXERR,IBXDATA,IBXSAVE,IBZPRC92,IBQUIT,IBISEQ,IDDATA,IBFOR,IBC
    26         I $D(IBFL) N IBFL
    27         K ^TMP($J)
    28         W !
    29         S IBER="" D GVAR I '$D(IBND0) S IBER=-1 Q
    30         ;
    31         ;patient in patient file
    32         I DFN="" S IBER=IBER_"IB057;"
    33         I DFN]"",'$D(^DPT(DFN)) S IBER=IBER_"IB057;"
    34         ;
    35         ;Event date in correct format
    36         I IBEVDT="" S IBER=IBER_"IB049;"
    37         I IBEVDT]"",IBEVDT'?7N&(IBEVDT'?7N1".".N) S IBER=IBER_"IB049;"
    38         ;
    39         ;Rate Type
    40         I IBAT="" S IBER=IBER_"IB059;"
    41         I IBAT]"",'$D(^DGCR(399.3,IBAT,0)) S IBER=IBER_"IB059;"
    42         I IBAT]"",$D(^DGCR(399.3,IBAT,0)),'$P(^(0),"^",6) S IBER=IBER_"IB059;",IBAT=""
    43         I IBAT]"",$P($G(^DGCR(399.3,IBAT,0)),"^",6) S IBARTP=$P($$CATN^PRCAFN($P(^DGCR(399.3,IBAT,0),"^",6)),"^",3)
    44         ;Check that AR category expects same debtor as defined in who's responsible.
    45         I $D(IBARTP),IBWHO="i"&(IBARTP'="T")!(IBWHO="p"&("PC"'[IBARTP))!(IBWHO="o"&(IBARTP'="N")) S IBER=IBER_"IB058;"
    46         ;
    47         ;Who's Responsible
    48         I IBWHO=""!($L(IBWHO)>1)!("iop"'[IBWHO) S IBER=IBER_"IB065;"
    49         S IBMRA=$S($$MCRWNR^IBEFUNC(+$$CURR^IBCEF2(IBIFN)):$$TXMT^IBCEF4(IBIFN)>0,1:0)
    50         ;  MCR will not reimburse is only valid if there is subsequent insurance
    51         ;   that will reimburse
    52         I IBWHO="i" D
    53         . I IBMRA D  Q
    54         .. N Z,IBZ
    55         .. S IBZ=0
    56         .. F Z=$$COBN^IBCEF(IBIFN):1:3 I $D(^DGCR(399,IBIFN,"I"_(Z+1))),$P($G(^DIC(36,+$G(^DGCR(399,IBIFN,"I"_(Z+1))),0)),U,2)'="N" S IBZ=1 Q
    57         .. I 'IBZ S IBER=IBER_"IB054;" D WARN^IBCBB11("A valid claim for MEDICARE WNR needs subsequent ins. that will reimburse")
    58         ..
    59         . I $$COB^IBCEF(IBIFN)="S",$$MCRWNR^IBEFUNC(+$$CURR^IBCEF2(IBIFN))=1,$D(^DGCR(399,IBIFN,"I3")) Q
    60         . I $S('IBNDMP:1,1:$P(IBNDMP,U,2)'=$$BPP^IBCNS2(IBIFN,1)) S IBER=IBER_"IB054;"
    61         I IBWHO="o",'$P(IBNDM,"^",11) S IBER=IBER_"IB053;"
    62         ;
    63         ; All insurance subscribers must have a birth date on file
    64         ;  - 11/10/04 - IB*2.0*288
    65         ;  - 12/14/06 - IB*2.0*361 - must have INSURED'S SEX too
    66         ; IB error codes
    67         ;    IB221 - Primary insurance subscriber missing date of birth
    68         ;    IB222 - Secondary insurance subscriber missing date of birth
    69         ;    IB223 - Tertiary insurance subscriber missing date of birth
    70         ;    IB261 - Primary insurance subscriber is missing INSURED'S SEX
    71         ;    IB262 - Secondary insurance subscriber is missing INSURED'S SEX
    72         ;    IB263 - Tertiary insurance subscriber is missing INSURED'S SEX
    73         ;
    74         F IBISEQ=1:1:3 D
    75         . I '$P($G(^DGCR(399,IBIFN,"I"_IBISEQ)),U,1) Q   ; no insurance here
    76         . K ^UTILITY("VADM",$J),^UTILITY("VAPA",$J)
    77         . S IDDATA=$$INSDEM^IBCEF(IBIFN,IBISEQ)
    78         . K ^UTILITY("VADM",$J),^UTILITY("VAPA",$J)
    79         . ;
    80         . I '$P(IDDATA,U,1) D ERR(221)   ; birth date missing
    81         . ;
    82         . I "^M^F^"'[(U_$P(IDDATA,U,2)_U) D ERR(261)  ; sex missing
    83         . ;
    84         . ; IB*2*371 - esg - check for other missing insurance pieces
    85         . ; check insured's name, primary ID#, pt. relationship to insured,
    86         . ; and subscriber address data 
    87         . N INNAME,SUBID,PTREL,SFA,CAS,LN,FN
    88         . ;
    89         . ;          IB273 - Primary Insurance name of insured missing
    90         . ;          IB274 - Secondary Insurance name of insured missing
    91         . ;          IB275 - Tertiary Insurance name of insured missing
    92         . S INNAME=$$POLICY^IBCEF(IBIFN,17,IBISEQ)
    93         . S LN=$P(INNAME,",",1),FN=$P(INNAME,",",2)   ; last name,first name
    94         . S LN=$$NOPUNCT^IBCEF(LN,1)
    95         . S FN=$$NOPUNCT^IBCEF(FN,1)
    96         . I LN=""!(FN="") D ERR(273)   ; name of insured missing or invalid
    97         . S LN=$$NAME^IBCEFG1(INNAME)  ; additional name checks
    98         . S FN=$P(LN,U,2)
    99         . S LN=$P(LN,U,1)
    100         . I LN=""!(FN="") D ERR(273)   ; name of insured missing or invalid
    101         . ;
    102         . ;          IB276 - Primary Insurance subscriber ID missing
    103         . ;          IB277 - Secondary Insurance subscriber ID missing
    104         . ;          IB278 - Tertiary Insurance subscriber ID missing
    105         . S SUBID=$$NOPUNCT^IBCEF($$POLICY^IBCEF(IBIFN,2,IBISEQ),1)
    106         . I SUBID="" D ERR(276)     ; subscriber ID# missing
    107         . ;
    108         . ;          IB279 - Primary Insurance missing pt relationship
    109         . ;          IB280 - Secondary Insurance missing pt relationship
    110         . ;          IB281 - Tertiary Insurance missing pt relationship
    111         . S PTREL=$$POLICY^IBCEF(IBIFN,16,IBISEQ)
    112         . I PTREL="" D ERR(279)      ; missing patient relationship to insured
    113         . ;
    114         . ; subscriber address section
    115         . S SFA=$$INSADDR^IBCEF(IBIFN,IBISEQ)     ; full address all pieces
    116         . S CAS=$$NOPUNCT^IBCEF($P(SFA,U,2,5),1)  ; string city,st,zip,addr1
    117         . ;
    118         . ;          IB282 - Primary Insurance address line 1 missing
    119         . ;          IB283 - Secondary Insurance address line 1 missing
    120         . ;          IB284 - Tertiary Insurance address line 1 missing
    121         . I $$NOPUNCT^IBCEF($P(SFA,U,5),1)="" D   ; address line 1 is blank
    122         .. ; pat=subscriber and current insurance - address is required
    123         .. I +PTREL=1,IBISEQ=$$COBN^IBCEF(IBIFN) D ERR(282) Q
    124         .. ; if any part of the address is there, then all fields are required
    125         .. I CAS'="" D ERR(282) Q
    126         .. Q
    127         . ;
    128         . ;          IB285 - Primary Insurance city missing
    129         . ;          IB286 - Secondary Insurance city missing
    130         . ;          IB287 - Tertiary Insurance city missing
    131         . I $$NOPUNCT^IBCEF($P(SFA,U,2),1)="" D   ; city is blank
    132         .. ; pat=subscriber and current insurance - address is required
    133         .. I +PTREL=1,IBISEQ=$$COBN^IBCEF(IBIFN) D ERR(285) Q
    134         .. ; if any part of the address is there, then all fields are required
    135         .. I CAS'="" D ERR(285) Q
    136         .. Q
    137         . ;
    138         . ;          IB288 - Primary Insurance state missing
    139         . ;          IB289 - Secondary Insurance state missing
    140         . ;          IB290 - Tertiary Insurance state missing
    141         . I $$NOPUNCT^IBCEF($P(SFA,U,3),1)="" D   ; state is blank
    142         .. ; pat=subscriber and current insurance - address is required
    143         .. I +PTREL=1,IBISEQ=$$COBN^IBCEF(IBIFN) D ERR(288) Q
    144         .. ; if any part of the address is there, then all fields are required
    145         .. I CAS'="" D ERR(288) Q
    146         .. Q
    147         . ;
    148         . ;          IB291 - Primary Insurance zipcode missing
    149         . ;          IB292 - Secondary Insurance zipcode missing
    150         . ;          IB293 - Tertiary Insurance zipcode missing
    151         . I $$NOPUNCT^IBCEF($P(SFA,U,4),1)="" D   ; zipcode is blank
    152         .. ; pat=subscriber and current insurance - address is required
    153         .. I +PTREL=1,IBISEQ=$$COBN^IBCEF(IBIFN) D ERR(291) Q
    154         .. ; if any part of the address is there, then all fields are required
    155         .. I CAS'="" D ERR(291) Q
    156         .. Q
    157         . ;
    158         . Q
    159         ;
    160         ; esg - IB*2*371 - check patient address fields
    161         K ^UTILITY("VAPA",$J)
    162         ;
    163         S IBFOR=0                              ; foreign address flag
    164         S IBC=+$$PTADDR^IBCEF(IBIFN,25)        ; country code ien
    165         I IBC D
    166         . N CODE
    167         . S CODE=$$GET1^DIQ(779.004,IBC,.01)   ; .01 code field file 779.004
    168         . I CODE'="",CODE'="USA" S IBFOR=1     ; foreign country exists
    169         . Q
    170         ;
    171         I $$NOPUNCT^IBCEF($$PTADDR^IBCEF(IBIFN,1),1)="" S IBER=IBER_"IB269;"
    172         I $$NOPUNCT^IBCEF($$PTADDR^IBCEF(IBIFN,4),1)="" S IBER=IBER_"IB270;"
    173         I $$NOPUNCT^IBCEF($$PTADDR^IBCEF(IBIFN,5),1)="",'IBFOR S IBER=IBER_"IB271;"
    174         I $$NOPUNCT^IBCEF($$PTADDR^IBCEF(IBIFN,11),1)="",'IBFOR S IBER=IBER_"IB272;"
    175         K ^UTILITY("VAPA",$J)
    176         ;
    177         D PAYERADD^IBCBB0(IBIFN)     ; check the payer addresses
    178         ;
    179         ; esg - 9/20/07 - IB patch 371 - prevent EDI transmission for 3 payer
    180         ;       claims for all but the first payer.  To be removed when Emdeon
    181         ;       and FSC are able to deal with these.
    182         ;
    183         I +$G(^DGCR(399,IBIFN,"I2")),+$G(^DGCR(399,IBIFN,"I3")),$$TXMT^IBCEF4(IBIFN) D
    184         . ; for MRA request claims, make sure the MRA secondary claim is forced to print
    185         . I $$REQMRA^IBEFUNC(IBIFN) D  Q
    186         .. I '$P($G(^DGCR(399,IBIFN,"TX")),U,9) S IBER=IBER_"IB146;"
    187         .. Q
    188         . ;
    189         . I $$COBN^IBCEF(IBIFN)=1 Q   ; primary payer sequence claims are OK
    190         . ;
    191         . ; But claims with a payer sequence of 2 or 3 need to print locally
    192         . S IBER=IBER_"IB147;"
    193         . Q
    194         ;
    195         D ^IBCBB1
    196         Q
    197         ;
    198 EDIT(IBIFN)     ; Run edits from within the billing edit screens
    199         N IBVIEW,IBDISP,IBNOFIX,DIR,X,Y
    200         S (IBNOFIX,IBVIEW,IBDISP)=1
    201         D EDITS^IBCB2
    202         W ! S DIR("A")="Press RETURN to continue",DIR(0)="E" D ^DIR K DIR
    203         Q
    204         ;
    205 TOB(IBND0)      ;
    206         ; IBND0 = the 0-node of the bill (file 399)
    207         Q ($P(IBND0,U,24)_$P($G(^DGCR(399.1,+$P(IBND0,U,25),0)),U,2)_$P(IBND0,U,26))
    208         ;
    209 ERR(Z)  ; update IBER variable from the above insurance checks
    210         ; Z is the IB error code# for the primary insurance error
    211         N IBERRNO
    212         S IBERRNO="IB"_(Z+IBISEQ-1)
    213         I IBER[IBERRNO Q
    214         S IBER=IBER_IBERRNO_";"
    215         Q
    216         ;
     1IBCBB ;ALB/AAS - EDIT CHECK ROUTINE TO BE INVOKED BEFORE ALL BILL APPROVAL ACTIONS ;2-NOV-89
     2 ;;2.0;INTEGRATED BILLING;**80,51,137,288,327,361**;21-MAR-94;Build 9
     3 ;;Per VHA Directive 2004-038, this routine should not be modified.
     4 ;
     5 ;MAP TO DGCRBB
     6 ;
     7 ;IBNDn = IBND(n) = ^ib(399,n)
     8 ;RETURNS:
     9 ;IBER=fields with errors separated by semi-colons
     10 ;PRCASV("OKAY")=1 if iber="" and $D(prcasv("array")) compete
     11 ;
     12GVAR ;set up variables for mccr
     13 Q:'$D(IBIFN)  F I=0,"M","U","U1","S","MP","TX","UF3","UF31","U2" S @("IBND"_I)=$G(^DGCR(399,IBIFN,I))
     14 S IBBNO=$P(IBND0,"^"),DFN=$P(IBND0,"^",2),IBEVDT=$P(IBND0,"^",3)
     15 S IBLOC=$P(IBND0,"^",4),IBCL=$P(IBND0,"^",5),IBTF=$P(IBND0,"^",6)
     16 S IBAT=$P(IBND0,"^",7),IBWHO=$P(IBND0,"^",11),IBST=$P(IBND0,"^",13),IBFT=$P(IBND0,"^",19)
     17 S IBFDT=$P(IBNDU,"^",1),IBTDT=$P(IBNDU,"^",2)
     18 S IBTC=$P(IBNDU1,"^",1),IBFY=$P(IBNDU1,"^",9),IBFYC=$P(IBNDU1,"^",10)
     19 S IBEU=$P(IBNDS,"^",2),IBRU=$P(IBNDS,"^",5),IBAU=$P(IBNDS,"^",8)
     20 S IBTOB=$$TOB(IBND0),IBTOB12=$E(IBTOB,1,2)
     21 K ^TMP($J,"BILL-WARN")
     22 Q
     23 ;
     24EN ;Entry to check for errors
     25 N IBQ,IBXERR,IBXDATA,IBXSAVE,IBZPRC92,IBQUIT,IBISEQ,IDDATA,IBERRNO
     26 I $D(IBFL) N IBFL
     27 K ^TMP($J)
     28 W !
     29 S IBER="" D GVAR I '$D(IBND0) S IBER=-1 Q
     30 ;
     31 ;I $$ISPROS^IBCEF1(IBIFN) D
     32 ;. D WARN^IBCBB11("Bill has prosthetics item(s) and will only print locally")
     33 ;. I $$NEEDMRA^IBEFUNC(IBIFN) S IBQUIT=$$IBER^IBCBB3(.IBER,"098")
     34 ;
     35 ;patient in patient file
     36 I DFN="" S IBER=IBER_"IB057;"
     37 I DFN]"",'$D(^DPT(DFN)) S IBER=IBER_"IB057;"
     38 ;
     39 ;Event date in correct format
     40 I IBEVDT="" S IBER=IBER_"IB049;"
     41 I IBEVDT]"",IBEVDT'?7N&(IBEVDT'?7N1".".N) S IBER=IBER_"IB049;"
     42 ;
     43 ;Rate Type
     44 I IBAT="" S IBER=IBER_"IB059;"
     45 I IBAT]"",'$D(^DGCR(399.3,IBAT,0)) S IBER=IBER_"IB059;"
     46 I IBAT]"",$D(^DGCR(399.3,IBAT,0)),'$P(^(0),"^",6) S IBER=IBER_"IB059;",IBAT=""
     47 ;I IBAT]"",$D(^DGCR(399.3,IBAT,0)) S IBARTP=$P(^PRCA(430.2,$P(^DGCR(399.3,IBAT,0),"^",6),0),"^",6)
     48 I IBAT]"",$P($G(^DGCR(399.3,IBAT,0)),"^",6) S IBARTP=$P($$CATN^PRCAFN($P(^DGCR(399.3,IBAT,0),"^",6)),"^",3)
     49 ;Check that AR category expects same debtor as defined in who's responsible.
     50 I $D(IBARTP),IBWHO="i"&(IBARTP'="T")!(IBWHO="p"&("PC"'[IBARTP))!(IBWHO="o"&(IBARTP'="N")) S IBER=IBER_"IB058;"
     51 ;
     52 ;Who's Responsible
     53 I IBWHO=""!($L(IBWHO)>1)!("iop"'[IBWHO) S IBER=IBER_"IB065;"
     54 S IBMRA=$S($$MCRWNR^IBEFUNC(+$$CURR^IBCEF2(IBIFN)):$$TXMT^IBCEF4(IBIFN)>0,1:0)
     55 ;  MCR will not reimburse is only valid if there is subsequent insurance
     56 ;   that will reimburse
     57 I IBWHO="i" D
     58 . I IBMRA D  Q
     59 .. N Z,IBZ
     60 .. S IBZ=0
     61 .. F Z=$$COBN^IBCEF(IBIFN):1:3 I $D(^DGCR(399,IBIFN,"I"_(Z+1))),$P($G(^DIC(36,+$G(^DGCR(399,IBIFN,"I"_(Z+1))),0)),U,2)'="N" S IBZ=1 Q
     62 .. I 'IBZ S IBER=IBER_"IB054;" D WARN^IBCBB11("A valid claim for MEDICARE WNR needs subsequent ins. that will reimburse")
     63 ..
     64 . I $$COB^IBCEF(IBIFN)="S",$$MCRWNR^IBEFUNC(+$$CURR^IBCEF2(IBIFN))=1,$D(^DGCR(399,IBIFN,"I3")) Q
     65 . I $S('IBNDMP:1,1:$P(IBNDMP,U,2)'=$$BPP^IBCNS2(IBIFN,1)) S IBER=IBER_"IB054;"
     66 I IBWHO="o",'$P(IBNDM,"^",11) S IBER=IBER_"IB053;"
     67 ;
     68 ; All insurance subscribers must have a birth date on file
     69 ;  - 11/10/04 - IB*2.0*288
     70 ;  - 12/14/06 - IB*2.0*361 - must have INSURED'S SEX too
     71 ; IB error codes
     72 ;    IB221 - Primary insurance subscriber missing date of birth
     73 ;    IB222 - Secondary insurance subscriber missing date of birth
     74 ;    IB223 - Tertiary insurance subscriber missing date of birth
     75 ;    IB261 - Primary insurance subscriber is missing INSURED'S SEX
     76 ;    IB262 - Secondary insurance subscriber is missing INSURED'S SEX
     77 ;    IB263 - Tertiary insurance subscriber is missing INSURED'S SEX
     78 ;
     79 F IBISEQ=1:1:3 D
     80 . I '$P($G(^DGCR(399,IBIFN,"I"_IBISEQ)),U,1) Q   ; no insurance here
     81 . K ^UTILITY("VADM",$J),^UTILITY("VAPA",$J)
     82 . S IDDATA=$$INSDEM^IBCEF(IBIFN,IBISEQ)
     83 . K ^UTILITY("VADM",$J),^UTILITY("VAPA",$J)
     84 . I '$P(IDDATA,U,1) D  ; birth date missing
     85 .. S IBERRNO=220+IBISEQ
     86 .. S IBER=IBER_"IB"_IBERRNO_";"
     87 . I "^M^F^"'[(U_$P(IDDATA,U,2)_U) D  ; sex missing
     88 .. S IBERRNO=260+IBISEQ
     89 .. S IBER=IBER_"IB"_IBERRNO_";"
     90 . Q
     91 ;
     92 D ^IBCBB1
     93 Q
     94 ;
     95EDIT(IBIFN) ; Run edits from within the billing edit screens
     96 N IBVIEW,IBDISP,IBNOFIX,DIR,X,Y
     97 S (IBNOFIX,IBVIEW,IBDISP)=1
     98 D EDITS^IBCB2
     99 W ! S DIR("A")="Press RETURN to continue",DIR(0)="E" D ^DIR K DIR
     100 Q
     101 ;
     102TOB(IBND0) ;
     103 ; IBND0 = the 0-node of the bill (file 399)
     104 Q ($P(IBND0,U,24)_$P($G(^DGCR(399.1,+$P(IBND0,U,25),0)),U,2)_$P(IBND0,U,26))
     105 ;

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCBB1.m

    r613 r623  
    1 IBCBB1  ;ALB/AAS - CONTINUATION OF EDIT CHECK ROUTINE ;2-NOV-89
    2         ;;2.0;INTEGRATED BILLING;**27,52,80,93,106,51,151,148,153,137,232,280,155,320,343,349,363,371,395**;21-MAR-94;Build 3
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5         ;MAP TO DGCRBB1
    6         ;
    7 %       ;Bill Status
    8         N Z,Z0,Z1
    9         I $S(+IBST=0:1,1:"^1^2^3^4^7^"'[(U_IBST_U)) S IBER=IBER_"IB045;"
    10         ;
    11         ;Statement Covers From
    12         I IBFDT="" S IBER=IBER_"IB061;"
    13         I IBFDT]"",IBFDT'?7N&(IBFDT'?7N1".".N) S IBER=IBER_"IB061;"
    14         I IBFDT>IBTDT S IBER=IBER_"IB061;" ; from must be on or before the to date
    15         S IBFFY=$$FY^IBOUTL(IBFDT)
    16         ; if inpat - from date must not be prior to admit date.
    17         I $$INPAT^IBCEF(IBIFN,1),(IBFDT<($P($G(^DGPT(+$P(IBND0,U,8),0)),U,2)\1))  S IBER=IBER_"IB061;"
    18         ;
    19         ;Statement Covers To
    20         I IBTDT="" S IBER=IBER_"IB062;"
    21         I IBTDT]"",IBTDT'?7N&(IBTDT'?7N1".".N) S IBER=IBER_"IB062;"
    22         I IBTDT>DT!(IBTDT<IBFDT) S IBER=IBER_"IB062;"  ; to date must not be >than today's date
    23         S IBTFY=$$FY^IBOUTL(IBTDT)
    24         ;
    25         ;Total Charges
    26         I +IBTC'>0!(+IBTC'=IBTC) S IBER=IBER_"IB064;"
    27         ;
    28         ;Billable charges for secondary claim
    29         I $$MCRONBIL^IBEFUNC(IBIFN)&(($P(IBNDU1,U,1)-$P(IBNDU1,U,2))'>0) S IBER=IBER_"IB094;"
    30         ;Fiscal Year 1
    31         S IBFFY=$$FY^IBOUTL(IBFDT)
    32         ;
    33         ;Check provider link for current user, enterer, reviewer and Authorizor
    34         I '$D(^VA(200,DUZ,0)) S IBER=IBER_"IB048;"
    35         I IBEU]"",'$D(^VA(200,IBEU,0)) S IBER=IBER_"IB048;"
    36         I IBRU]"",'$D(^VA(200,IBRU,0)) S IBER=IBER_"IB060;"
    37         I IBAU]"",'$D(^VA(200,IBAU,0)) S IBER=IBER_"IB041;"
    38         ;
    39         I IBER="",+$$STA^PRCAFN(IBIFN)=104 S IBER=IBER_"IB040;"
    40         ; If ins bill, must have valid COB sequence
    41         I $P(IBND0,U,11)="i",$S($P(IBND0,U,21)="":1,1:"PST"'[$P(IBND0,U,21)) S IBER=IBER_"IB324;"
    42         ;
    43         ; Check for valid sec provider id for current ins
    44         S Z=0 F  S Z=$O(^DGCR(399,IBIFN,"PRV",Z)) Q:'Z  S Z0=$G(^(Z,0)),Z1=+$$COBN^IBCEF(IBIFN) I $P(Z0,U,4+Z1)'="",$P(Z0,U,11+Z1)'="" D
    45         . I '$$SECIDCK^IBCEF74(IBIFN,Z1,$P(Z0,U,11+Z1),Z) D WARN^IBCBB11("Prov secondary id type for the "_$P("PRIMARY^SECONDARY^TERTIARY",U,Z1)_" "_$$EXTERNAL^DILFD(399.0222,.01,,+Z0)_" is invalid/won't transmit")
    46         ; Check NPIs
    47         D NPICHK^IBCBB11
    48         ;
    49         ; Check multiple rx NPIs
    50         D RXNPI^IBCBB11(IBIFN)
    51         ;
    52         ; Check taxonomies
    53         D TAXCHK^IBCBB11
    54         ;
    55         ; Check for Physician Name
    56         K IBXDATA D F^IBCEF("N-ATT/REND PHYSICIAN NAME",,,IBIFN)
    57         I $P($G(IBXDATA),U)="" S IBER=IBER_"IB303;"
    58         ;
    59         N FUNCTION,IBINS
    60         S FUNCTION=$S($$FT^IBCEF(IBIFN)=3:4,1:3)
    61         I IBER'["IB303;" D
    62         . F IBINS=1:1:3 D
    63         .. S Z=$$GETTYP^IBCEP2A(IBIFN,IBINS)
    64         .. I Z,$P(Z,U,2) D  ; Rendering/attending prov secondary id required
    65         ... N IBID,IBOK,Q0
    66         ... D PROVINF^IBCEF74(IBIFN,IBINS,.IBID,1,"C")  ; check all as though they were current
    67         ... S IBOK=0
    68         ... S Q0=0 F  S Q0=$O(IBID(1,FUNCTION,Q0)) Q:'Q0  I $P(IBID(1,FUNCTION,Q0),U,9)=+Z S IBOK=1 Q
    69         ... I 'IBOK S IBER=IBER_$S(IBINS=1:"IB236;",IBINS=2:"IB237;",IBINS=3:"IB238;",1:"")
    70         ;
    71         D PRIIDCHK^IBCBB11
    72         ;
    73         N IBM,IBM1
    74         S IBM=$G(^DGCR(399,IBIFN,"M"))
    75         S IBM1=$G(^DGCR(399,IBIFN,"M1"))
    76         I $P(IBM,U),$P($G(^DIC(36,$P(IBM,U),4)),U,6),$P(IBM1,U,2)="" S IBER=IBER_"IB244;"
    77         I $P(IBM,U,2),$P($G(^DIC(36,$P(IBM,U,2),4)),U,6),$P(IBM1,U,3)="" S IBER=IBER_"IB245;"
    78         I $P(IBM,U,3),$P($G(^DIC(36,$P(IBM,U,3),4)),U,6),$P(IBM1,U,4)="" S IBER=IBER_"IB246;"
    79         ;
    80         ; If outside facility, check for ID and qualifier in 355.93
    81         ; 5/15/06 - esg - hard error IB243 turned into warning message instead
    82         S Z=$P($G(^DGCR(399,IBIFN,"U2")),U,10)
    83         I Z D
    84         . I $P($G(^IBA(355.93,Z,0)),U,9)=""!($P($G(^IBA(355.93,Z,0)),U,13)="") D
    85         .. N Z1,Z2
    86         .. S Z1="Missing Lab or Facility Primary ID for non-VA facility, "
    87         .. S Z2=$$EXTERNAL^DILFD(399,232,,Z)
    88         .. I $L(Z2)'>19 D WARN^IBCBB11(Z1_Z2) Q
    89         .. D WARN^IBCBB11(Z1),WARN^IBCBB11("     "_Z2)
    90         .. Q
    91         . Q
    92         ;
    93         ; Must be one and only one division on bill
    94         S IBZ=$$MULTDIV^IBCBB11(IBIFN,IBND0)
    95         I IBZ S IBER=IBER_$S(IBZ=1:"IB095;",IBZ=2:"IB104;",1:"IB105;")
    96         ; Division address must be defined in institution file
    97         I $P(IBND0,U,22) D
    98         . N Z,Z0,Z1
    99         . S Z0=$G(^DIC(4,+$P($G(^DG(40.8,+$P(IBND0,U,22),0)),U,7),0))
    100         . S Z1=$G(^DIC(4,+$P($G(^DG(40.8,+$P(IBND0,U,22),0)),U,7),1))
    101         . I $P(Z0,U,2)="" S IBER=IBER_"IB097;" Q
    102         . F Z=1,3,4 I $P(Z1,U,Z)="" S IBER=IBER_"IB097;" Q
    103         ;
    104         ;CHAMPVA Rate Type and Primary Insurance Carriers Type of Coverage must match
    105         S (IBRTCHV,IBPICHV)=0
    106         I $P($G(^DGCR(399.3,+IBAT,0)),U,1)="CHAMPVA" S IBRTCHV=1
    107         I $P($G(^IBE(355.2,+$P($G(^DIC(36,+IBNDMP,0)),U,13),0)),U,1)="CHAMPVA" S IBPICHV=1
    108         I (+IBRTCHV!+IBPICHV)&('IBRTCHV!'IBPICHV) S IBER=IBER_"IB085;"
    109         ;
    110         N IBZPRC,IBZPRCUB
    111         D F^IBCEF("N-ALL PROCEDURES","IBZPRC",,IBIFN)
    112         ; Procedure Clinic is required for Surgical Procedures Outpt Facility Charges
    113         I +$P(IBND0,U,27)'=2,$$BILLRATE^IBCRU3(IBAT,IBCL,IBEVDT,"RC OUTPATIENT") D
    114         . N Z,Z0,Z1,ZE S (ZE,Z)=0 F  S Z=$O(^DGCR(399,IBIFN,"CP",Z)) Q:'Z  D  I +ZE S IBER=IBER_"IB320;" Q
    115         .. S Z0=$G(^DGCR(399,IBIFN,"CP",Z,0)),Z1=+Z0 I Z0'[";ICPT(" Q
    116         .. I '((Z1'<10000)&(Z1'>69999))&'((Z1'<93501)&(Z1'>93533)) Q
    117         .. I '$P(Z0,U,7) S ZE=1
    118         ;
    119         ; Extract procedures for UB-04
    120         D F^IBCEF("N-UB-04 PROCEDURES","IBZPRCUB",,IBIFN)
    121         ; Does this bill have ANY prescriptions associated with it?
    122         ; Must bill prescriptions separately from other charges
    123         ;
    124         I $$ISRX^IBCEF1(IBIFN) D
    125         . N IBZ,IBRXDEF
    126         . S IBRXDEF=$P($G(^IBE(350.9,1,1)),U,30),IBZ=0
    127         . F  S IBZ=$O(IBZPRCUB(IBZ)) Q:'IBZ  I IBZPRCUB(IBZ),+$P(IBZPRCUB(IBZ),U)'=IBRXDEF S IBER=IBER_"IB102;" Q
    128         . K IBZ
    129         ;
    130         ; Check that COB sequences are not skipped
    131         K Z
    132         F Z=1:1:3 S:+$G(^DGCR(399,IBIFN,"I"_Z)) Z(Z)=""
    133         F Z=0:1:2 S Z0=$O(Z(Z)) Q:'Z0  I Z0'=(Z+1) S IBER=IBER_"IB322;" Q
    134         K Z
    135         ; HD64676  IB*2*371 - OK for payer sequence to be blank when the Rate
    136         ;    Type is either Interagency or Sharing Agreement
    137         I $P($G(^DGCR(399,IBIFN,0)),U,21)="",$P($G(^DGCR(399,IBIFN,0)),U,7)'=4,$P($G(^DGCR(399,IBIFN,0)),U,7)'=9 S IBER=IBER_"IB323;"
    138         K IBXDATA D F^IBCEF("N-PROCEDURE CODING METHD",,,IBIFN)
    139         ; Coding method should agree with types of procedure codes
    140         S IBOK=$S('$O(IBZPRC(0))!(IBXDATA=""):1,1:0)
    141         I 'IBOK S IBOK=1,IBZ=0 F  S IBZ=$O(IBZPRC(IBZ)) Q:'IBZ  I IBZPRC(IBZ),$P(IBZPRC(IBZ),U)'[$S(IBXDATA=9:"ICD",1:"ICP") S IBOK=0 Q
    142         I 'IBOK D WARN^IBCBB11("Coding Method does not agree with all procedure codes found on bill")
    143         D EDITMRA^IBCBB3(.IBQUIT,.IBER,IBIFN,IBFT)
    144         Q:$G(IBQUIT)
    145         ;
    146         ;Other things that could be added:  Rev Code - calculating charges
    147         ;        Diagnosis Coding, if MT copay - check for other co-payments
    148         ;
    149         I $P(IBNDTX,U,8),$$REQMRA^IBEFUNC(IBIFN) S IBER=IBER_"IB121;"   ; can't force MRAs to print
    150         I $P(IBNDTX,U,8)!$P(IBNDTX,U,9) D WARN^IBCBB11($S($$REQMRA^IBEFUNC(IBIFN)&($P(IBNDTX,U,9)):"MRA Secondary ",1:"")_"Bill has been forced to print "_$S($P(IBNDTX,U,8)=1!($P(IBNDTX,U,9)=1):"locally",1:"at clearinghouse"))
    151         N IBXZ,IBIZ F IBIZ=12,13,14 S IBXZ=$P(IBNDM,U,IBIZ) I +IBXZ S IBXZ=$P($G(^DPT(DFN,.312,IBXZ,0)),U,18) I +IBXZ S IBXZ=$G(^IBA(355.3,+IBXZ,0)) I +$P(IBXZ,U,12) D
    152         . D WARN^IBCBB11($P($G(^DIC(36,+IBXZ,0)),U,1)_" requires Amb Care Certification")
    153         ;
    154         D VALNDC^IBCBB11(IBIFN,DFN)  ;validate NDC#
    155         ;
    156         ;Build AR array if no errors and MRA not needed or already rec'd
    157         I IBER="",$S($$NEEDMRA^IBEFUNC(IBIFN)!($$REQMRA^IBEFUNC(IBIFN)):0,1:1) D ARRAY
    158         ;
    159 END     ;Don't kill IBIFN, IBER, DFN
    160         I $O(^TMP($J,"BILL-WARN",0)),$G(IBER)="" S IBER="WARN" ;Warnings only
    161         K IBBNO,IBEVDT,IBLOC,IBCL,IBTF,IBAT,IBWHO,IBST,IBFDT,IBTDT,IBTC,IBFY,IBFY1,IBAU,IBRU,IBEU,IBARTP,IBFYC,IBMRA,IBTOB,IBTOB12,IBNDU2,IBNDUF3,IBNDUF31,IBNDTX
    162         K IBNDS,IBND0,IBNDU,IBNDM,IBNDMP,IBNDU1,IBFFY,IBTFY,IBFT,IBRTCHV,IBPICHV,IBXDATA,IBOK
    163         I $D(IBER),IBER="" W !,"No Errors found for National edits"
    164         Q
    165         ;
    166 ARRAY   ;Build PRCASV(array)
    167         N IBCOBN,X
    168         K PRCASV
    169         Q:$$MCRWNR^IBEFUNC(+$$CURR^IBCEF2(IBIFN))
    170         S IBCOBN=$$COBN^IBCEF(IBIFN)
    171         S X=IBIFN
    172         S PRCASV("BDT")=DT,PRCASV("ARREC")=IBIFN
    173         S PRCASV("APR")=DUZ
    174         S PRCASV("PAT")=DFN,PRCASV("CAT")=$P(^DGCR(399.3,IBAT,0),"^",6)
    175         I IBWHO="i" S PRCASV("DEBTOR")=+IBNDMP_";DIC(36,"
    176         S PRCASV("DEBTOR")=$S(IBWHO="p":DFN_";DPT(",IBWHO="o":$P(IBNDM,"^",11)_";DIC(4,",IBWHO="i":PRCASV("DEBTOR"),1:"")
    177         S PRCASV("CARE")=$E($$TOB^IBCEF1(IBIFN),1,2)
    178         S PRCASV("FY")=$$FY^IBOUTL(DT)_U_($P(IBNDU1,U)-$P(IBNDU1,U,2))
    179         ;S PRCASV("FY")=$P(IBNDU1,U,9)_U_$S($P(IBNDU1,U,2)]"":($P(IBNDU1,U,10)-$P(IBNDU1,U,2)),1:$P(IBNDU1,U,10))_$S($P(IBNDU1,U,11)]"":U_$P(IBNDU1,U,11)_U_$P(IBNDU1,U,12),1:"")
    180 PLUS    I IBWHO="i",$P(IBNDM,"^",2),$D(^DIC(36,$P(IBNDM,"^",2),0)) S PRCASV("2NDINS")=$P(IBNDM,"^",2)
    181         I IBWHO="i",$P(IBNDM,"^",3),$D(^DIC(36,$P(IBNDM,"^",3),0)) S PRCASV("3RDINS")=$P(IBNDM,"^",3)
    182         ;
    183         N IBX S IBX=$P(IBND0,U,21),IBX=$S(IBX="P":"I1",IBX="S":"I2",IBX="T":"I3",1:"") Q:IBX=""
    184         N IBNDI1
    185         Q:'$D(^DGCR(399,IBIFN,IBX))  S IBNDI1=^(IBX)
    186         S:$P(IBNDI1,"^",3)]"" PRCASV("GPNO")=$P(IBNDI1,"^",3)
    187         S:$P(IBNDI1,"^",15)]"" PRCASV("GPNM")=$P(IBNDI1,"^",15)
    188         S:$P(IBNDI1,"^",17)]"" PRCASV("INPA")=$P(IBNDI1,"^",17)
    189         S:$P(IBNDI1,"^",2)]"" PRCASV("IDNO")=$P(IBNDI1,"^",2),PRCASV("INID")=PRCASV("IDNO")
    190         ; Check that this is a secondary or tertiary bill and insurance for previous
    191         ; COB sequence is Medicare WNR and MRA is active --> send data elements to AR
    192         I IBCOBN>1,$$WNRBILL^IBEFUNC(IBIFN,IBCOBN-1),$$EDIACTV^IBCEF4(2) D MRA
    193         Q
    194         ;
    195 MRA     N IBEOB S IBEOB=0
    196         ;
    197         K PRCASV("MEDURE"),PRCASV("MEDCA")
    198         ; Get EOB data
    199         F  S IBEOB=$O(^IBM(361.1,"B",IBIFN,IBEOB)) Q:'IBEOB  D
    200         . D MRACALC^IBCEMU2(IBEOB,IBIFN,1,.PRCASV)
    201         Q  ;MRA
    202         ;
    203         ;; PREGNANCY DX CODES: V22**-V24**, V27**-V28**, 630**-677**
    204         ;; FLU SHOTS PROCEDURE CODES: 90724, G0008, 90732, G0009
     1IBCBB1 ;ALB/AAS - CONTINUATION OF EDIT CHECK ROUTINE ;2-NOV-89
     2 ;;2.0;INTEGRATED BILLING;**27,52,80,93,106,51,151,148,153,137,232,280,155,320,343,349,363**;21-MAR-94;Build 35
     3 ;;Per VHA Directive 2004-038, this routine should not be modified.
     4 ;
     5 ;MAP TO DGCRBB1
     6 ;
     7% ;Bill Status
     8 N Z,Z0,Z1
     9 I $S(+IBST=0:1,1:"^1^2^3^4^7^"'[(U_IBST_U)) S IBER=IBER_"IB045;"
     10 ;
     11 ;Statement Covers From
     12 I IBFDT="" S IBER=IBER_"IB061;"
     13 I IBFDT]"",IBFDT'?7N&(IBFDT'?7N1".".N) S IBER=IBER_"IB061;"
     14 I IBFDT>IBTDT S IBER=IBER_"IB061;" ; from must be on or before the to date
     15 S IBFFY=$$FY^IBOUTL(IBFDT)
     16 ; if inpat - from date must not be prior to admit date.
     17 I $$INPAT^IBCEF(IBIFN,1),(IBFDT<($P($G(^DGPT(+$P(IBND0,U,8),0)),U,2)\1))  S IBER=IBER_"IB061;"
     18 ;
     19 ;Statement Covers To
     20 I IBTDT="" S IBER=IBER_"IB062;"
     21 I IBTDT]"",IBTDT'?7N&(IBTDT'?7N1".".N) S IBER=IBER_"IB062;"
     22 I IBTDT>DT!(IBTDT<IBFDT) S IBER=IBER_"IB062;"  ; to date must not be >than today's date
     23 S IBTFY=$$FY^IBOUTL(IBTDT)
     24 ;
     25 ;Statement crosses fiscal years
     26 ;I IBTFY'=IBFFY S IBER=IBER_"IB047;"
     27 ;
     28 ;Statement crosses calendar years
     29 ;I $E(IBTDT,1,3)'=$E(IBFDT,1,3) S IBER=IBER_"IB046;"
     30 ;
     31 ;Total Charges
     32 I +IBTC'>0!(+IBTC'=IBTC) S IBER=IBER_"IB064;"
     33 ;
     34 ;Billable charges for secondary claim
     35 I $$MCRONBIL^IBEFUNC(IBIFN)&(($P(IBNDU1,U,1)-$P(IBNDU1,U,2))'>0) S IBER=IBER_"IB094;"
     36 ;Fiscal Year 1
     37 S IBFFY=$$FY^IBOUTL(IBFDT)
     38 ;
     39 ;Check provider link for current user, enterer, reviewer and Authorizor
     40 I '$D(^VA(200,DUZ,0)) S IBER=IBER_"IB048;"
     41 I IBEU]"",'$D(^VA(200,IBEU,0)) S IBER=IBER_"IB048;"
     42 I IBRU]"",'$D(^VA(200,IBRU,0)) S IBER=IBER_"IB060;"
     43 I IBAU]"",'$D(^VA(200,IBAU,0)) S IBER=IBER_"IB041;"
     44 ;
     45 ;Bill exists and not already new bill
     46 ;I $S('$D(^PRCA(430,IBIFN,0)):1,$P($P(^PRCA(430,IBIFN,0),"^"),"-",2)'=IBBNO:1,1:0) S IBER=IBER_"IB056;"
     47 ;I $P($$BN^PRCAFN(IBIFN),"-",2)'=IBBNO S IBER=IBER_"IB056;"
     48 ;I IBER="",$P(^PRCA(430,IBIFN,0),"^",8)=$O(^PRCA(430.3,"AC",104,"")) S IBER=IBER_"IB040;"
     49 I IBER="",+$$STA^PRCAFN(IBIFN)=104 S IBER=IBER_"IB040;"
     50 ; If ins bill, must have valid COB sequence
     51 I $P(IBND0,U,11)="i",$S($P(IBND0,U,21)="":1,1:"PST"'[$P(IBND0,U,21)) S IBER=IBER_"IB324;"
     52 ;
     53 ; Check for valid sec provider id for current ins
     54 S Z=0 F  S Z=$O(^DGCR(399,IBIFN,"PRV",Z)) Q:'Z  S Z0=$G(^(Z,0)),Z1=+$$COBN^IBCEF(IBIFN) I $P(Z0,U,4+Z1)'="",$P(Z0,U,11+Z1)'="" D
     55 . I '$$SECIDCK^IBCEF74(IBIFN,Z1,$P(Z0,U,11+Z1),Z) D WARN^IBCBB11("Prov secondary id type for the "_$P("PRIMARY^SECONDARY^TERTIARY",U,Z1)_" "_$$EXTERNAL^DILFD(399.0222,.01,,+Z0)_" is invalid/won't transmit")
     56 ; Check NPIs
     57 D NPICHK^IBCBB11
     58 ;
     59 ; Check taxonomies
     60 D TAXCHK^IBCBB11
     61 ;
     62 ; Check for Physician Name
     63 K IBXDATA D F^IBCEF("N-ATT/REND PHYSICIAN NAME",,,IBIFN)
     64 I $P($G(IBXDATA),U)="" S IBER=IBER_"IB303;"
     65 ;
     66 N FUNCTION,IBINS
     67 S FUNCTION=$S($$FT^IBCEF(IBIFN)=3:4,1:3)
     68 I IBER'["IB303;" D
     69 . F IBINS=1:1:3 D
     70 .. S Z=$$GETTYP^IBCEP2A(IBIFN,IBINS)
     71 .. I Z,$P(Z,U,2) D  ; Rendering/attending prov secondary id required
     72 ... N IBID,IBOK,Q0
     73 ... D PROVINF^IBCEF74(IBIFN,IBINS,.IBID,1,"C")  ; check all as though they were current
     74 ... S IBOK=0
     75 ... S Q0=0 F  S Q0=$O(IBID(1,FUNCTION,Q0)) Q:'Q0  I $P(IBID(1,FUNCTION,Q0),U,9)=+Z S IBOK=1 Q
     76 ... I 'IBOK S IBER=IBER_$S(IBINS=1:"IB236;",IBINS=2:"IB237;",IBINS=3:"IB238;",1:"")
     77 . I $$TXMT^IBCEF4(IBIFN) D
     78 .. D F^IBCEF("N-ALL ATT/REND PROV SSN/EI","IBZ",,IBIFN)
     79 .. I $P(IBZ,U,3)=""&($P(IBZ,U,4)="") S IBER=IBER_"IB321;" ; SSN/IEN required for rend/att
     80 ;
     81 N IBM,IBM1
     82 S IBM=$G(^DGCR(399,IBIFN,"M"))
     83 S IBM1=$G(^DGCR(399,IBIFN,"M1"))
     84 I $P(IBM,U),$P($G(^DIC(36,$P(IBM,U),4)),U,6),$P(IBM1,U,2)="" S IBER=IBER_"IB244;"
     85 I $P(IBM,U,2),$P($G(^DIC(36,$P(IBM,U,2),4)),U,6),$P(IBM1,U,3)="" S IBER=IBER_"IB245;"
     86 I $P(IBM,U,3),$P($G(^DIC(36,$P(IBM,U,3),4)),U,6),$P(IBM1,U,4)="" S IBER=IBER_"IB246;"
     87 ;
     88 ; If outside facility, check for ID and qualifier in 355.93
     89 ; 5/15/06 - esg - hard error IB243 turned into warning message instead
     90 S Z=$P($G(^DGCR(399,IBIFN,"U2")),U,10)
     91 I Z D
     92 . I $P($G(^IBA(355.93,Z,0)),U,9)=""!($P($G(^IBA(355.93,Z,0)),U,13)="") D
     93 .. N Z1,Z2
     94 .. S Z1="Missing Lab or Facility Primary ID for non-VA facility, "
     95 .. S Z2=$$EXTERNAL^DILFD(399,232,,Z)
     96 .. I $L(Z2)'>19 D WARN^IBCBB11(Z1_Z2) Q
     97 .. D WARN^IBCBB11(Z1),WARN^IBCBB11("     "_Z2)
     98 .. Q
     99 . Q
     100 ;
     101 ; Must be one and only one division on bill
     102 S IBZ=$$MULTDIV^IBCBB11(IBIFN,IBND0)
     103 I IBZ S IBER=IBER_$S(IBZ=1:"IB095;",IBZ=2:"IB104;",1:"IB105;")
     104 ; Division address must be defined in institution file
     105 I $P(IBND0,U,22) D
     106 . N Z,Z0,Z1
     107 . S Z0=$G(^DIC(4,+$P($G(^DG(40.8,+$P(IBND0,U,22),0)),U,7),0))
     108 . S Z1=$G(^DIC(4,+$P($G(^DG(40.8,+$P(IBND0,U,22),0)),U,7),1))
     109 . I $P(Z0,U,2)="" S IBER=IBER_"IB097;" Q
     110 . F Z=1,3,4 I $P(Z1,U,Z)="" S IBER=IBER_"IB097;" Q
     111 ;
     112 ;CHAMPVA Rate Type and Primary Insurance Carriers Type of Coverage must match
     113 S (IBRTCHV,IBPICHV)=0
     114 I $P($G(^DGCR(399.3,+IBAT,0)),U,1)="CHAMPVA" S IBRTCHV=1
     115 I $P($G(^IBE(355.2,+$P($G(^DIC(36,+IBNDMP,0)),U,13),0)),U,1)="CHAMPVA" S IBPICHV=1
     116 I (+IBRTCHV!+IBPICHV)&('IBRTCHV!'IBPICHV) S IBER=IBER_"IB085;"
     117 ;
     118 N IBZPRC,IBZPRCUB
     119 D F^IBCEF("N-ALL PROCEDURES","IBZPRC",,IBIFN)
     120 ; Procedure Clinic is required for Surgical Procedures Outpt Facility Charges
     121 I +$P(IBND0,U,27)'=2,$$BILLRATE^IBCRU3(IBAT,IBCL,IBEVDT,"RC OUTPATIENT") D
     122 . N Z,Z0,Z1,ZE S (ZE,Z)=0 F  S Z=$O(^DGCR(399,IBIFN,"CP",Z)) Q:'Z  D  I +ZE S IBER=IBER_"IB320;" Q
     123 .. S Z0=$G(^DGCR(399,IBIFN,"CP",Z,0)),Z1=+Z0 I Z0'[";ICPT(" Q
     124 .. I '((Z1'<10000)&(Z1'>69999))&'((Z1'<93501)&(Z1'>93533)) Q
     125 .. I '$P(Z0,U,7) S ZE=1
     126 ;
     127 ; Extract procedures for UB-04
     128 D F^IBCEF("N-UB-04 PROCEDURES","IBZPRCUB",,IBIFN)
     129 ; Does this bill have ANY prescriptions associated with it?
     130 ; Must bill prescriptions separately from other charges
     131 ;
     132 I $$ISRX^IBCEF1(IBIFN) D
     133 . N IBZ,IBRXDEF
     134 . S IBRXDEF=$P($G(^IBE(350.9,1,1)),U,30),IBZ=0
     135 . F  S IBZ=$O(IBZPRCUB(IBZ)) Q:'IBZ  I IBZPRCUB(IBZ),+$P(IBZPRCUB(IBZ),U)'=IBRXDEF S IBER=IBER_"IB102;" Q
     136 . K IBZ
     137 ;
     138 ; Check that COB sequences are not skipped
     139 K Z
     140 F Z=1:1:3 S:+$G(^DGCR(399,IBIFN,"I"_Z)) Z(Z)=""
     141 F Z=0:1:2 S Z0=$O(Z(Z)) Q:'Z0  I Z0'=(Z+1) S IBER=IBER_"IB322;" Q
     142 K Z
     143 I $P($G(^DGCR(399,IBIFN,0)),U,21)="" S IBER=IBER_"IB323;"
     144 K IBXDATA D F^IBCEF("N-PROCEDURE CODING METHD",,,IBIFN)
     145 ; Coding method should agree with types of procedure codes
     146 S IBOK=$S('$O(IBZPRC(0))!(IBXDATA=""):1,1:0)
     147 I 'IBOK S IBOK=1,IBZ=0 F  S IBZ=$O(IBZPRC(IBZ)) Q:'IBZ  I IBZPRC(IBZ),$P(IBZPRC(IBZ),U)'[$S(IBXDATA=9:"ICD",1:"ICP") S IBOK=0 Q
     148 I 'IBOK D WARN^IBCBB11("Coding Method does not agree with all procedure codes found on bill")
     149 D EDITMRA^IBCBB3(.IBQUIT,.IBER,IBIFN,IBFT)
     150 Q:$G(IBQUIT)
     151 ;
     152 ;Other things that could be added:  Rev Code - calculating charges
     153 ;        Diagnosis Coding, if MT copay - check for other co-payments
     154 ;
     155 I $P(IBNDTX,U,8),$$REQMRA^IBEFUNC(IBIFN) S IBER=IBER_"IB121;"   ; can't force MRAs to print
     156 I $P(IBNDTX,U,8)!$P(IBNDTX,U,9) D WARN^IBCBB11($S($$REQMRA^IBEFUNC(IBIFN)&($P(IBNDTX,U,9)):"MRA Secondary ",1:"")_"Bill has been forced to print "_$S($P(IBNDTX,U,8)=1!($P(IBNDTX,U,9)=1):"locally",1:"at clearinghouse"))
     157 N IBXZ,IBIZ F IBIZ=12,13,14 S IBXZ=$P(IBNDM,U,IBIZ) I +IBXZ S IBXZ=$P($G(^DPT(DFN,.312,IBXZ,0)),U,18) I +IBXZ S IBXZ=$G(^IBA(355.3,+IBXZ,0)) I +$P(IBXZ,U,12) D
     158 . D WARN^IBCBB11($P($G(^DIC(36,+IBXZ,0)),U,1)_" requires Amb Care Certification")
     159 ;
     160 D VALNDC^IBCBB11(IBIFN,DFN)  ;validate NDC#
     161 ;Build AR array if no errors and MRA not needed or already rec'd
     162 I IBER="",$S($$NEEDMRA^IBEFUNC(IBIFN)!($$REQMRA^IBEFUNC(IBIFN)):0,1:1) D ARRAY
     163 ;
     164END ;Don't kill IBIFN, IBER, DFN
     165 I $O(^TMP($J,"BILL-WARN",0)),$G(IBER)="" S IBER="WARN" ;Warnings only
     166 K IBBNO,IBEVDT,IBLOC,IBCL,IBTF,IBAT,IBWHO,IBST,IBFDT,IBTDT,IBTC,IBFY,IBFY1,IBAU,IBRU,IBEU,IBARTP,IBFYC,IBMRA,IBTOB,IBTOB12,IBNDU2,IBNDUF3,IBNDUF31,IBNDTX
     167 K IBNDS,IBND0,IBNDU,IBNDM,IBNDMP,IBNDU1,IBFFY,IBTFY,IBFT,IBRTCHV,IBPICHV,IBXDATA,IBOK
     168 I $D(IBER),IBER="" W !,"No Errors found for National edits"
     169 Q
     170 ;
     171ARRAY ;Build PRCASV(array)
     172 N IBCOBN,X
     173 K PRCASV
     174 Q:$$MCRWNR^IBEFUNC(+$$CURR^IBCEF2(IBIFN))
     175 S IBCOBN=$$COBN^IBCEF(IBIFN)
     176 S X=IBIFN
     177 S PRCASV("BDT")=DT,PRCASV("ARREC")=IBIFN
     178 S PRCASV("APR")=DUZ
     179 S PRCASV("PAT")=DFN,PRCASV("CAT")=$P(^DGCR(399.3,IBAT,0),"^",6)
     180 I IBWHO="i" S PRCASV("DEBTOR")=+IBNDMP_";DIC(36,"
     181 S PRCASV("DEBTOR")=$S(IBWHO="p":DFN_";DPT(",IBWHO="o":$P(IBNDM,"^",11)_";DIC(4,",IBWHO="i":PRCASV("DEBTOR"),1:"")
     182 S PRCASV("CARE")=$E($$TOB^IBCEF1(IBIFN),1,2)
     183 S PRCASV("FY")=$$FY^IBOUTL(DT)_U_($P(IBNDU1,U)-$P(IBNDU1,U,2))
     184 ;S PRCASV("FY")=$P(IBNDU1,U,9)_U_$S($P(IBNDU1,U,2)]"":($P(IBNDU1,U,10)-$P(IBNDU1,U,2)),1:$P(IBNDU1,U,10))_$S($P(IBNDU1,U,11)]"":U_$P(IBNDU1,U,11)_U_$P(IBNDU1,U,12),1:"")
     185PLUS I IBWHO="i",$P(IBNDM,"^",2),$D(^DIC(36,$P(IBNDM,"^",2),0)) S PRCASV("2NDINS")=$P(IBNDM,"^",2)
     186 I IBWHO="i",$P(IBNDM,"^",3),$D(^DIC(36,$P(IBNDM,"^",3),0)) S PRCASV("3RDINS")=$P(IBNDM,"^",3)
     187 ;
     188 N IBX S IBX=$P(IBND0,U,21),IBX=$S(IBX="P":"I1",IBX="S":"I2",IBX="T":"I3",1:"") Q:IBX=""
     189 N IBNDI1
     190 Q:'$D(^DGCR(399,IBIFN,IBX))  S IBNDI1=^(IBX)
     191 S:$P(IBNDI1,"^",3)]"" PRCASV("GPNO")=$P(IBNDI1,"^",3)
     192 S:$P(IBNDI1,"^",15)]"" PRCASV("GPNM")=$P(IBNDI1,"^",15)
     193 S:$P(IBNDI1,"^",17)]"" PRCASV("INPA")=$P(IBNDI1,"^",17)
     194 S:$P(IBNDI1,"^",2)]"" PRCASV("IDNO")=$P(IBNDI1,"^",2),PRCASV("INID")=PRCASV("IDNO")
     195 ; Check that this is a secondary or tertiary bill and insurance for previous
     196 ; COB sequence is Medicare WNR and MRA is active --> send data elements to AR
     197 I IBCOBN>1,$$WNRBILL^IBEFUNC(IBIFN,IBCOBN-1),$$EDIACTV^IBCEF4(2) D MRA
     198 Q
     199 ;
     200MRA N IBEOB S IBEOB=0
     201 ;
     202 K PRCASV("MEDURE"),PRCASV("MEDCA")
     203 ; Get EOB data
     204 F  S IBEOB=$O(^IBM(361.1,"B",IBIFN,IBEOB)) Q:'IBEOB  D
     205 . D MRACALC^IBCEMU2(IBEOB,IBIFN,1,.PRCASV)
     206 Q  ;MRA
     207 ;
     208 ;; PREGNANCY DX CODES: V22**-V24**, V27**-V28**, 630**-677**
     209 ;; FLU SHOTS PROCEDURE CODES: 90724, G0008, 90732, G0009

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCBB11.m

    r613 r623  
    1 IBCBB11 ;ALB/AAS - CONTINUATION OF EDIT CHECK ROUTINE ;12 Jun 2006  3:45 PM
    2         ;;2.0;INTEGRATED BILLING;**51,343,363,371,395,392,401**;21-MAR-94;Build 5
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5 WARN(IBDISP)    ; Set warning in global
    6         ; DISP = warning text to display
    7         ;
    8         N Z
    9         S Z=+$O(^TMP($J,"BILL-WARN",""),-1)
    10         I Z=0 S ^TMP($J,"BILL-WARN",1)=$J("",5)_"**Warnings**:",Z=1
    11         S Z=Z+1,^TMP($J,"BILL-WARN",Z)=$J("",5)_IBDISP
    12         Q
    13         ;
    14 MULTDIV(IBIFN,IBND0)    ; Check for multiple divisions on a bill ien IBIFN
    15         ; IBND0 = 0-node of bill
    16         ;
    17         ;  Function returns 1 if more than 1 division found on bill
    18         N Z,Z0,Z1,MULT
    19         S MULT=0,Z1=$P(IBND0,U,22)
    20         I Z1 D
    21         . S Z=0 F  S Z=$O(^DGCR(399,IBIFN,"RC",Z)) Q:'Z  S Z0=$P(^(Z,0),U,7) I Z0,Z0'=Z1 S MULT=1 Q
    22         . S Z=0 F  S Z=$O(^DGCR(399,IBIFN,"CP",Z)) Q:'Z  S Z0=$P(^(Z,0),U,6) I Z0,Z0'=Z1 S MULT=2 Q
    23         I 'Z1 S MULT=3
    24         Q MULT
    25         ;
    26         ;; PREGNANCY DX CODES: V22**-V24**, V27**-V28**, 630**-677**
    27         ;; FLU SHOTS PROCEDURE CODES: 90724, G0008, 90732, G0009
    28         ;
    29         ; Check for required NPIs
    30 NPICHK  ;
    31         N IBNPIS,IBNONPI,IBNPIREQ,Z
    32         S IBNPIREQ=$$NPIREQ^IBCEP81(DT)  ; Check if NPI is required
    33         ; Check providers
    34         S IBNPIS=$$PROVNPI^IBCEF73A(IBIFN,.IBNONPI)
    35         I $L(IBNONPI) F Z=1:1:$L(IBNONPI,U) D
    36         . I IBNPIREQ S IBER=IBER_"IB"_(140+$P(IBNONPI,U,Z))_";" Q  ; If required, set error
    37         . D WARN("NPI for the "_$P("referring^operating^rendering^attending^supervising^^^^other",U,$P(IBNONPI,U,Z))_" provider has no value")  ; Else, set warning
    38         ; Check organizations
    39         S IBNONPI=""
    40         S IBNPIS=$$ORGNPI^IBCEF73A(IBIFN,.IBNONPI)
    41         I $L(IBNONPI) F Z=1:1:$L(IBNONPI,U) D
    42         . ; Turn IB161, IB162 to a warning
    43         . I IBNPIREQ,$P(IBNONPI,U,Z)=3 S IBER=IBER_"IB163;" Q
    44         . ; PRXM/KJH - Changed descriptions.
    45         . D WARN("NPI for the "_$P("Division^Non-VA Service Facility^Billing Provider",U,$P(IBNONPI,U,Z))_" has no value")  ; Else, set warning
    46         Q
    47         ;
    48         ; Check for required taxonomies
    49 TAXCHK  ;
    50         N IBTAXS,IBNOTAX,IBTAXREQ,Z
    51         S IBTAXREQ=$$TAXREQ^IBCEP81(DT)  ; Check if taxonomy is required
    52         ; Check providers
    53         S IBTAXS=$$PROVTAX^IBCEF73A(IBIFN,.IBNOTAX)
    54         I $L(IBNOTAX) F Z=1:1:$L(IBNOTAX,U) D
    55         . ; Only Referring, Rendering and Attending are currently sent to the payer
    56         . I IBTAXREQ,"134"[$P(IBNOTAX,U,Z) S IBER=IBER_"IB"_(250+$P(IBNOTAX,U,Z))_";" Q  ; If required, set error
    57         . D WARN("Taxonomy for the "_$P("referring^operating^rendering^attending^supervising^^^^other",U,$P(IBNOTAX,U,Z))_" provider has no value")  ; Else, set warning
    58         ; Check organizations
    59         S IBNOTAX=""
    60         S IBTAXS=$$ORGTAX^IBCEF73A(IBIFN,.IBNOTAX)
    61         I $L(IBNOTAX) F Z=1:1:$L(IBNOTAX,U) D
    62         . ; Turn IB165, IB166 to a warning
    63         . I IBTAXREQ,$P(IBNOTAX,U,Z)=3 S IBER=IBER_"IB167;" Q
    64         . ; PRXM/KJH - Changed descriptions.
    65         . D WARN("Taxonomy for the "_$P("Division^Non-VA Service Facility^Billing Provider",U,$P(IBNOTAX,U,Z))_" has no value")  ; Else, set warning
    66         Q
    67         ;
    68 VALNDC(IBIFN,IBDFN)     ; IB*2*363 - validate NDC# between PRESCRIPTION file (#52)
    69         ; and IB BILL/CLAIMS PRESCRIPTION REFILL file (#362.4)
    70         ; input - IBIFN = internal entry number of the billing record in the BILL/CLAIMS file (#399)
    71         ;         IBDFN = internal entry number of patient record in the PATIENT file (#2)
    72         N IBX,IBRXCOL
    73         ; call program that determines if NDC differences exist
    74         D VALNDC^IBEFUNC3(IBIFN,IBDFN,.IBRXCOL)
    75         Q:'$D(IBRXCOL)
    76         ; at least one RX on the IB record has an NDC discrepancy
    77         S IBX=0 F  S IBX=$O(IBRXCOL(IBX)) Q:'IBX  D WARN("NDC# on Bill does not equal the NDC# on Rx "_IBRXCOL(IBX))
    78         Q
    79         ;
    80 PRIIDCHK        ; Check for required Pimarary ID (SSN/EIN)
    81         ; If the provider is on the claim, he must have one
    82         ;
    83         N IBI,IBZ
    84         I $$TXMT^IBCEF4(IBIFN) D
    85         . D F^IBCEF("N-ALL ATT/REND PROV SSN/EI","IBZ",,IBIFN)
    86         . S IBI="" F  S IBI=$O(^DGCR(399,IBIFN,"PRV","B",IBI)) Q:IBI=""  D
    87         .. I $P(IBZ,U,IBI)="" S IBER=IBER_$S(IBI=1:"IB151;",IBI=2:"IB152;",IBI=3!(IBI=4):"IB321;",IBI=5:"IB153;",IBI=9:"IB154;",1:"")
    88         Q
    89         ;
    90 RXNPI(IBIFN)    ; check for multiple pharmacy npi's on the same bill
    91         N IBORG,IBRXNPI,IBX,IBY
    92         S IBORG=$$RXSITE^IBCEF73A(IBIFN,.IBORG)
    93         S IBX=0 F  S IBX=$O(IBORG(IBX)) Q:'IBX  S IBY=0 F  S IBY=$O(IBORG(IBX,IBY)) Q:'IBY  S IBRXNPI(+IBORG(IBX,IBY))=""
    94         S (IBX,IBY)=0 F  S IBX=$O(IBRXNPI(IBX)) Q:'IBX  S IBY=IBY+1
    95         I IBY>1 D WARN("Bill has prescriptions resulting from "_IBY_" different NPI locations")
    96         Q
     1IBCBB11 ;ALB/AAS - CONTINUATION OF EDIT CHECK ROUTINE ;12 Jun 2006  3:45 PM
     2 ;;2.0;INTEGRATED BILLING;**51,343,363**;21-MAR-94;Build 35
     3 ;;Per VHA Directive 2004-038, this routine should not be modified.
     4 ;
     5WARN(IBDISP) ; Set warning in global
     6 ; DISP = warning text to display
     7 ;
     8 N Z
     9 S Z=+$O(^TMP($J,"BILL-WARN",""),-1)
     10 I Z=0 S ^TMP($J,"BILL-WARN",1)=$J("",5)_"**Warnings**:",Z=1
     11 S Z=Z+1,^TMP($J,"BILL-WARN",Z)=$J("",5)_IBDISP
     12 Q
     13 ;
     14MULTDIV(IBIFN,IBND0) ; Check for multiple divisions on a bill ien IBIFN
     15 ; IBND0 = 0-node of bill
     16 ;
     17 ;  Function returns 1 if more than 1 division found on bill
     18 N Z,Z0,Z1,MULT
     19 S MULT=0,Z1=$P(IBND0,U,22)
     20 I Z1 D
     21 . S Z=0 F  S Z=$O(^DGCR(399,IBIFN,"RC",Z)) Q:'Z  S Z0=$P(^(Z,0),U,7) I Z0,Z0'=Z1 S MULT=1 Q
     22 . S Z=0 F  S Z=$O(^DGCR(399,IBIFN,"CP",Z)) Q:'Z  S Z0=$P(^(Z,0),U,6) I Z0,Z0'=Z1 S MULT=2 Q
     23 I 'Z1 S MULT=3
     24 Q MULT
     25 ;
     26 ;; PREGNANCY DX CODES: V22**-V24**, V27**-V28**, 630**-677**
     27 ;; FLU SHOTS PROCEDURE CODES: 90724, G0008, 90732, G0009
     28 ;
     29 ; Check for required NPIs
     30NPICHK ;
     31 N IBNPIS,IBNONPI,IBNPIREQ,Z
     32 S IBNPIREQ=$$NPIREQ^IBCEP81(DT)  ; Check if NPI is required
     33 ; Check providers
     34 S IBNPIS=$$PROVNPI^IBCEF73A(IBIFN,.IBNONPI)
     35 I $L(IBNONPI) F Z=1:1:$L(IBNONPI,U) D
     36 . I IBNPIREQ S IBER=IBER_"IB"_(140+$P(IBNONPI,U,Z))_";" Q  ; If required, set error
     37 . D WARN("NPI for the "_$P("referring^operating^rendering^attending^supervising^^^^other",U,$P(IBNONPI,U,Z))_" provider has no value")  ; Else, set warning
     38 ; Check organizations
     39 S IBNONPI=""
     40 S IBNPIS=$$ORGNPI^IBCEF73A(IBIFN,.IBNONPI)
     41 I $L(IBNONPI) F Z=1:1:$L(IBNONPI,U) D
     42 . I IBNPIREQ S IBER=IBER_"IB"_(160+$P(IBNONPI,U,Z))_";" Q  ; If required, set error
     43 . ; PRXM/KJH - Changed descriptions.
     44 . D WARN("NPI for the "_$P("Division^Non-VA Service Facility^Billing Provider",U,$P(IBNONPI,U,Z))_" has no value")  ; Else, set warning
     45 Q
     46 ;
     47 ; Check for required taxonomies
     48TAXCHK ;
     49 N IBTAXS,IBNOTAX,IBTAXREQ,Z
     50 S IBTAXREQ=$$TAXREQ^IBCEP81(DT)  ; Check if taxonomy is required
     51 ; Check providers
     52 S IBTAXS=$$PROVTAX^IBCEF73A(IBIFN,.IBNOTAX)
     53 I $L(IBNOTAX) F Z=1:1:$L(IBNOTAX,U) D
     54 . I IBTAXREQ S IBER=IBER_"IB"_(250+$P(IBNOTAX,U,Z))_";" Q  ; If required, set error
     55 . D WARN("Taxonomy for the "_$P("referring^operating^rendering^attending^supervising^^^^other",U,$P(IBNOTAX,U,Z))_" provider has no value")  ; Else, set warning
     56 ; Check organizations
     57 S IBNOTAX=""
     58 S IBTAXS=$$ORGTAX^IBCEF73A(IBIFN,.IBNOTAX)
     59 I $L(IBNOTAX) F Z=1:1:$L(IBNOTAX,U) D
     60 . I IBTAXREQ S IBER=IBER_"IB"_(164+$P(IBNOTAX,U,Z))_";" Q  ; If required, set error
     61 . ; PRXM/KJH - Changed descriptions.
     62 . D WARN("Taxonomy for the "_$P("Division^Non-VA Service Facility^Billing Provider",U,$P(IBNOTAX,U,Z))_" has no value")  ; Else, set warning
     63 Q
     64 ;
     65VALNDC(IBIFN,IBDFN) ; IB*2*363 - validate NDC# between PRESCRIPTION file (#52)
     66 ; and IB BILL/CLAIMS PRESCRIPTION REFILL file (#362.4)
     67 ; input - IBIFN = internal entry number of the billing record in the BILL/CLAIMS file (#399)
     68 ;         IBDFN = internal entry number of patient record in the PATIENT file (#2)
     69 N IBX,IBRXCOL
     70 ; call program that determines if NDC differences exist
     71 D VALNDC^IBEFUNC3(IBIFN,IBDFN,.IBRXCOL)
     72 Q:'$D(IBRXCOL)
     73 ; at least one RX on the IB record has an NDC discrepancy
     74 S IBX=0 F  S IBX=$O(IBRXCOL(IBX)) Q:'IBX  D WARN("NDC# on Bill does not equal the NDC# on Rx "_IBRXCOL(IBX))
     75 Q

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCBB2.m

    r613 r623  
    1 IBCBB2  ;ALB/ARH - CONTINUATION OF EDIT CHECKS ROUTINE (CMS-1500) ;04/14/92
    2         ;;2.0;INTEGRATED BILLING;**51,137,210,245,232,296,320,349,371**;21-MAR-94;Build 57
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5         ;MAP TO DGCRBB2
    6         ;
    7 EN      ;
    8         N IBI,IBJ,IBN,IBY,IBDX,IBDXO,IBDXL,IBCPT,IBCPTL,IBOLAB,Z,IBXSAVE,IBLOC,IBTX,IBPS,IBSP,IBLCT,IBNVFLG,IBU3
    9         I '$D(IBER) S IBER=""
    10         S IBTX=$$TXMT^IBCEF4(IBIFN)
    11         ;
    12         ; Max 4 modifiers per CPT code allowed before warning
    13         K IBXDATA
    14         D F^IBCEF("N-HCFA 1500 MODIFIERS",,,IBIFN) ;Get modifiers
    15         ;
    16         S Z=0 F  S Z=$O(IBZPRC92(Z)) Q:'Z  I $P(IBZPRC92(Z),U)["ICPT(",$L($P(IBZPRC92(Z),U,15),",")>4 S IBI="Proc "_$$PRCD^IBCEF1($P(IBZPRC92(Z),U))_" has > 4 modifiers - only first 4 will be used" D WARN^IBCBB11(IBI)
    17         ; ICD-9 diagnosis, at least 1 required
    18         D SET^IBCSC4D(IBIFN,.IBDX,.IBDXO) I '$P(IBDX,U,2) S IBER=IBER_"IB071;"
    19         S IBI=$O(IBDXO(0))
    20         I IBI,$$INPAT^IBCEF(IBIFN,1),$E($$ICD9^IBACSV(+$P(IBDXO(IBI),U)))="V" S Z="Principal Dx V-code may not be valid" D WARN^IBCBB11(Z)
    21         ;
    22         ; CPT procs must be associated with a dx, must have a defined provider
    23         S (IBLOC,IBN,IBI,IBY)=0 F  S IBI=$O(^DGCR(399,IBIFN,"CP",IBI)) Q:IBI'?1N.N  S IBCPT=^(IBI,0) D  I +IBY S IBN=1
    24         . I 'IBLOC,$P(IBCPT,U,15)'="",IBTX S Z="At least 1 charge has local box 24K data that will not be transmitted - " S IBLOC=1 D WARN^IBCBB11(Z) S Z="  This data will only print locally" D WARN^IBCBB11(Z)
    25         . I $P(IBCPT,U)'["ICPT(" S:IBER'["IB092" IBER=IBER_"IB092;" Q
    26         . S IBY=1 F IBJ=11:1:14 I +$P(IBCPT,"^",IBJ) S IBCPTL(+$P(IBCPT,"^",IBJ))="",IBY=0
    27         I +IBN S IBER=IBER_"IB072;"
    28         ;
    29         I '$$OCC10(IBIFN,.IBDX,2) S IBER=IBER_"IB093;"
    30         ; CMS-1500: dxs associated with procs must be defined dxs for the bill
    31         S IBI=0 F  S IBI=$O(IBDX(IBI))  Q:'IBI  S IBDXL(IBDX(IBI))=""
    32         S (IBN,IBI)=0 F  S IBI=$O(IBCPTL(IBI)) Q:'IBI  I '$D(IBDXL(IBI)) S IBN=1 Q
    33         I +IBN S IBER=IBER_"IB073;"
    34         ; ejk *296* Change # of diagnoses codes from 4 to 8 on CMS-1500 Claims.
    35         I IBTX S IBI=8 F  S IBI=$O(IBDXO(IBI)) Q:'IBI  S Z=+$G(IBDX(+$G(IBDXO(IBI)))) I Z,$D(IBCPTL(Z)) D WARN^IBCBB11("Too many diagnoses for claim & will be rejected - consider printing locally")
    36         ;
    37         I $$WNRBILL^IBEFUNC(IBIFN),$$MRATYPE^IBEFUNC(IBIFN)'="B" S IBER=IBER_"IB087;"
    38         ;
    39         ; IB*320 - CLIA# error/warning - error msg for MRA claims, else warning
    40         I $P(IBNDU2,U,13)="",$$CLIAREQ^IBCEP8A(IBIFN) D
    41         . I $$REQMRA^IBEFUNC(IBIFN) S IBER=IBER_"IB235;" Q
    42         . D WARN^IBCBB11("Claim contains laboratory services. The payer may require a CLIA #.")
    43         . Q
    44         ;
    45         ; Only one occurrence code can be present for event date for box 14
    46         S Z=$$EVENT^IBCF22(IBIFN,.IBXSAVE,.IBI)
    47         I IBI S IBER=IBER_"IB099;"
    48         ;
    49         ; esg - 6/6/07 - warning if missing non-VA care type for outside facility
    50         S IBNVFLG=0
    51         I $P(IBNDU2,U,10),'$P(IBNDU2,U,11) D WARN^IBCBB11("Non-VA facility indicated, but the Non-VA Care Type field is not defined") S IBNVFLG=1
    52         ;
    53         ; unit/charge limits
    54         K IBXDATA
    55         D F^IBCEF("N-HCFA 1500 SERVICES (PRINT)",,,IBIFN) ;Get charge lines
    56         S (IBLCT,IBOLAB)=0,IBPS="",IBSP=$$BILLSPEC^IBCEU3(IBIFN)
    57         S IBI=0 F  S IBI=$O(IBXDATA(IBI)) Q:'IBI  D  Q:IBER["IB310"!(IBER["IB311")
    58         . S IBLCT=IBLCT+1
    59         . I $P(IBNDU2,U,11) D
    60         .. I '$P(IBXDATA(IBI),U,11) S IBPS=IBPS_$S(IBPS'="":",",1:"")_IBI Q
    61         .. I $P(IBXDATA(IBI),U,14),"24"'[$P(IBNDU2,U,11) D WARN^IBCBB11("Outside lab charges exist on a non-lab NON-VA bill")
    62         . I '$P(IBNDU2,U,11),$P(IBXDATA(IBI),U,11) D WARN^IBCBB11("Purchased service amounts are invalid unless this is a NON-VA bill")
    63         . I IBNVFLG,'$P(IBXDATA(IBI),U,11) D WARN^IBCBB11("Non-VA facility indicated, but no purchased service charge on line# "_IBI)
    64         . I $D(IBXDATA(IBI,"A")) S IBER=IBER_"IB310;" Q
    65         . I $D(IBXDATA(IBI,"ARX")),IBER'["311;" S IBER=IBER_"IB311;" Q
    66         . I $P(IBXDATA(IBI),U,14) S IBOLAB=IBOLAB+1
    67         . ; Place of service required
    68         . I $G(IBER)'["IB314;",$P(IBXDATA(IBI),U,3)="" S IBER=IBER_"IB314;"
    69         . ; Type of service required
    70         . I $G(IBER)'["IB313;",$P(IBXDATA(IBI),U,4)="" S IBER=IBER_"IB313;"
    71         . ; 43 and 53 are invalid types of service
    72         . I $G(IBER)'["IB110;",($P(IBXDATA(IBI),U,4)=43!($P(IBXDATA(IBI),U,4)=53)) S IBER=IBER_"IB110;"
    73         . ; Units for the line item must be less than 100/1000
    74         . I IBER'["IB088",$P(IBXDATA(IBI),U,9)'<100 D
    75         .. I $P(IBXDATA(IBI),U,4)'=7 S IBER=IBER_"IB088;" Q
    76         .. I $P(IBXDATA(IBI),U,9)'<1000 S IBER=IBER_"IB088;"
    77         . ; Line item total charge must be less than $10,000.00, greater than 0
    78         . I IBER'["IB090",$P(IBXDATA(IBI),U,9)'<10000 S IBER=IBER_"IB090;"
    79         . I '($P(IBXDATA(IBI),U,9)*$P(IBXDATA(IBI),U,8)),$$COBN^IBCEF(IBIFN)'>1 S Z="Procedure "_$P(IBXDATA(IBI),U,5)_" has a 0-charge and will not be transmitted" D WARN^IBCBB11(Z)
    80         I IBTX,IBLCT>50 D
    81         . I '$$REQMRA^IBEFUNC(IBIFN) S IBER=IBER_"IB308;" Q
    82         . I '$P(IBNDTX,U,9) S IBER=IBER_"IB325;"
    83         S IBU3=$P($G(^DGCR(399,IBIFN,"U3")),U,4,7) I $TR(IBU3,U)'="" D
    84         .I +IBSP'=35 D WARN^IBCBB11("Chiropractic service details only valid if provider specialty is '35'")
    85         .I $P(IBU3,U,2)="" S IBER=IBER_"IB137;"
    86         .I $P(IBU3,U,4)="" S IBER=IBER_"IB138;" Q
    87         .I $P(IBU3,U,3)="","AM"[$P(IBU3,U,4) S IBER=IBER_"IB139;"
    88         .Q
    89         I IBPS'="" D WARN^IBCBB11("NON-VA facility indicated, but no purchased service charge on line item"_$S(IBPS[",":"s",1:"")_" #"_IBPS)
    90         I $P(IBNDU2,U,11),$P(IBNDU2,U,11)=4,IBOLAB>1 D WARN^IBCBB11("For proper payment, you must bill each outside lab on a separate claim form")
    91         K IBXDATA
    92         ;
    93         ;       ; Check for Physician Name
    94         D F^IBCEF("N-REFERRING PROVIDER NAME",,,IBIFN)
    95         I $P($G(IBXDATA),U)]"" D
    96         .N IBZ,FUNCTION,IBINS
    97         .S FUNCTION=1
    98         .F IBINS=1:1:3 D
    99         .. S Z=$$GETTYP^IBCEP2A(IBIFN,IBINS,FUNCTION)
    100         .. I Z,$P(Z,U,2) D  ; Rendering/attending prov secondary id required
    101         ... N IBID,IBOK,Q0
    102         ... D PROVINF^IBCEF74(IBIFN,IBINS,.IBID,1,"C")  ; check all as though they were current
    103         ... S IBOK=0
    104         ... S Q0=0 F  S Q0=$O(IBID(1,FUNCTION,Q0)) Q:'Q0  I $P(IBID(1,FUNCTION,Q0),U,9)=+Z S IBOK=1 Q
    105         ... I 'IBOK S IBER=IBER_$S(IBINS=1:"IB239;",IBINS=2:"IB240;",IBINS=3:"IB241;",1:"")
    106         ;
    107         Q
    108         ;
    109 OCC10(IBIFN,IBARR,IBFT) ; Determine if occurrence code 10 exists for pregnancy dx
    110         ; IBARR=array subscripted by ien of DX code if IBFT=2 (CMS-1500 form)
    111         ;                         by seq # and = ien of DX code if IBFT'=2
    112         ;
    113         N IBN,IBI,IBXDATA,IBXSAVE,IBDX,Z
    114         S IBN=1
    115         ;
    116         I '$D(^TMP($J,"LMD")) D
    117         . D F^IBCEF("N-OCCURRENCE CODES",,,IBIFN)
    118         . S ^TMP($J,"LMD")=""
    119         . S Z=0 F  S Z=$O(IBXSAVE("OCC",Z)) Q:'Z  I +IBXSAVE("OCC",Z)=10 S ^TMP($J,"LMD")=1 Q
    120         ;
    121         I '^TMP($J,"LMD") S IBI=0 F  S IBI=$O(IBARR(IBI))  Q:'IBI  D  Q:'IBN
    122         . N Z,Z1
    123         . ; If a pregnancy DX exists, must be an occurrence code 10 for LMP date
    124         . ; dx ranges are: V22*-V24*, V27*-V28*, 630*-677*
    125         . S IBDX=$S($G(IBFT)'=2:+IBARR(IBI),1:IBI)
    126         . S Z=$E($P($$ICD9^IBACSV(IBDX),U),1,3),Z1=$E(Z,2,3)
    127         . I $S(Z'<630&(Z<678):1,$E(Z)="V":$S(Z1'<22&(Z1<25):1,1:Z1'<27&(Z1<28)),1:0) S IBN=0 ;Pregnancy Dx exists
    128         ;
    129 OCC10Q  K ^TMP($J,"LMD")
    130         Q IBN
    131         ;
     1IBCBB2 ;ALB/ARH - CONTINUATION OF EDIT CHECKS ROUTINE (CMS-1500) ;04/14/92
     2 ;;2.0;INTEGRATED BILLING;**51,137,210,245,232,296,320,349**;21-MAR-94;Build 46
     3 ;;Per VHA Directive 2004-038, this routine should not be modified.
     4 ;
     5 ;MAP TO DGCRBB2
     6 ;
     7EN ;
     8 N IBI,IBJ,IBN,IBY,IBDX,IBDXO,IBDXL,IBCPT,IBCPTL,IBOLAB,Z,IBXSAVE,IBLOC,IBTX,IBPS,IBSP,IBLCT
     9 I '$D(IBER) S IBER=""
     10 S IBTX=$$TXMT^IBCEF4(IBIFN)
     11 ;
     12 ; Warn if no group provider id (MCRWNR is a default)
     13 ; I '$$WNRBILL^IBEFUNC(IBIFN) D
     14 ; . S Z=$P($G(^DGCR(399,IBIFN,"M1")),U,$$COBN^IBCEF(IBIFN)+1)
     15 ; . I Z="" D WARN^IBCBB11("No group prov # for the current ins co - site tax id will be used")
     16 ; Max 4 modifiers per CPT code allowed before warning
     17 K IBXDATA
     18 D F^IBCEF("N-HCFA 1500 MODIFIERS",,,IBIFN) ;Get modifiers
     19 ;
     20 S Z=0 F  S Z=$O(IBZPRC92(Z)) Q:'Z  I $P(IBZPRC92(Z),U)["ICPT(",$L($P(IBZPRC92(Z),U,15),",")>4 S IBI="Proc "_$$PRCD^IBCEF1($P(IBZPRC92(Z),U))_" has > 4 modifiers - only first 4 will be used" D WARN^IBCBB11(IBI)
     21 ; ICD-9 diagnosis, at least 1 required
     22 D SET^IBCSC4D(IBIFN,.IBDX,.IBDXO) I '$P(IBDX,U,2) S IBER=IBER_"IB071;"
     23 S IBI=$O(IBDXO(0))
     24 I IBI,$$INPAT^IBCEF(IBIFN,1),$E($$ICD9^IBACSV(+$P(IBDXO(IBI),U)))="V" S Z="Principal Dx V-code may not be valid" D WARN^IBCBB11(Z)
     25 ;
     26 ; CPT procs must be associated with a dx, must have a defined provider
     27 S (IBLOC,IBN,IBI,IBY)=0 F  S IBI=$O(^DGCR(399,IBIFN,"CP",IBI)) Q:IBI'?1N.N  S IBCPT=^(IBI,0) D  I +IBY S IBN=1
     28 . ;I IBER'["IB089",$P(IBCPT,U,10)=7,$S('$P(IBCPT,U,16):1,1:$P(IBCPT,U,16)#15) S IBER=IBER_"IB089;" ;anesthesia needs minutes in multiple of 15
     29 . I 'IBLOC,$P(IBCPT,U,15)'="",IBTX S Z="At least 1 charge has local box 24K data that will not be transmitted - " S IBLOC=1 D WARN^IBCBB11(Z) S Z="  This data will only print locally" D WARN^IBCBB11(Z)
     30 . I $P(IBCPT,U)'["ICPT(" S:IBER'["IB092" IBER=IBER_"IB092;" Q
     31 . S IBY=1 F IBJ=11:1:14 I +$P(IBCPT,"^",IBJ) S IBCPTL(+$P(IBCPT,"^",IBJ))="",IBY=0
     32 . ;I '$P(IBCPT,U,18) S:IBER'["IB094;" IBER=IBER_"IB094;" Q
     33 I +IBN S IBER=IBER_"IB072;"
     34 ;
     35 I '$$OCC10(IBIFN,.IBDX,2) S IBER=IBER_"IB093;"
     36 ; CMS-1500: dxs associated with procs must be defined dxs for the bill
     37 S IBI=0 F  S IBI=$O(IBDX(IBI))  Q:'IBI  S IBDXL(IBDX(IBI))=""
     38 S (IBN,IBI)=0 F  S IBI=$O(IBCPTL(IBI)) Q:'IBI  I '$D(IBDXL(IBI)) S IBN=1 Q
     39 I +IBN S IBER=IBER_"IB073;"
     40 ; ejk *296* Change # of diagnoses codes from 4 to 8 on CMS-1500 Claims.
     41 I IBTX S IBI=8 F  S IBI=$O(IBDXO(IBI)) Q:'IBI  S Z=+$G(IBDX(+$G(IBDXO(IBI)))) I Z,$D(IBCPTL(Z)) D WARN^IBCBB11("Too many diagnoses for claim & will be rejected - consider printing locally")
     42 ;
     43 I $$WNRBILL^IBEFUNC(IBIFN),$$MRATYPE^IBEFUNC(IBIFN)'="B" S IBER=IBER_"IB087;"
     44 ;
     45 ; IB*320 - CLIA# error/warning - error msg for MRA claims, else warning
     46 I $P(IBNDU2,U,13)="",$$CLIAREQ^IBCEP8A(IBIFN) D
     47 . I $$REQMRA^IBEFUNC(IBIFN) S IBER=IBER_"IB235;" Q
     48 . D WARN^IBCBB11("Claim contains laboratory services. The payer may require a CLIA #.")
     49 . Q
     50 ;
     51 ; Only one occurrence code can be present for event date for box 14
     52 S Z=$$EVENT^IBCF22(IBIFN,.IBXSAVE,.IBI)
     53 I IBI S IBER=IBER_"IB099;"
     54 ; unit/charge limits
     55 K IBXDATA
     56 D F^IBCEF("N-HCFA 1500 SERVICES (PRINT)",,,IBIFN) ;Get charge lines
     57 S (IBLCT,IBOLAB)=0,IBPS="",IBSP=$$BILLSPEC^IBCEU3(IBIFN)
     58 S IBI=0 F  S IBI=$O(IBXDATA(IBI)) Q:'IBI  D  Q:IBER["IB310"!(IBER["IB311")
     59 . S IBLCT=IBLCT+1
     60 . I $P(IBNDU2,U,11) D
     61 .. I '$P(IBXDATA(IBI),U,11) S IBPS=IBPS_$S(IBPS'="":",",1:"")_IBI Q
     62 .. I $P(IBXDATA(IBI),U,14),"24"'[$P(IBNDU2,U,11) D WARN^IBCBB11("Outside lab charges exist on a non-lab NON-VA bill")
     63 . I '$P(IBNDU2,U,11),$P(IBXDATA(IBI),U,11) D WARN^IBCBB11("Purchased service amounts are invalid unless this is a NON-VA bill")
     64 . I $D(IBXDATA(IBI,"A")) S IBER=IBER_"IB310;" Q
     65 . I $D(IBXDATA(IBI,"ARX")),IBER'["311;" S IBER=IBER_"IB311;" Q
     66 . I $P(IBXDATA(IBI),U,14) S IBOLAB=IBOLAB+1
     67 . ; Place of service required
     68 . I $G(IBER)'["IB314;",$P(IBXDATA(IBI),U,3)="" S IBER=IBER_"IB314;"
     69 . ; Type of service required
     70 . I $G(IBER)'["IB313;",$P(IBXDATA(IBI),U,4)="" S IBER=IBER_"IB313;"
     71 . ; 43 and 53 are invalid types of service
     72 . I $G(IBER)'["IB110;",($P(IBXDATA(IBI),U,4)=43!($P(IBXDATA(IBI),U,4)=53)) S IBER=IBER_"IB110;"
     73 . ; Units for the line item must be less than 100/1000
     74 . I IBER'["IB088",$P(IBXDATA(IBI),U,9)'<100 D
     75 .. I $P(IBXDATA(IBI),U,4)'=7 S IBER=IBER_"IB088;" Q
     76 .. I $P(IBXDATA(IBI),U,9)'<1000 S IBER=IBER_"IB088;"
     77 . ; Line item total charge must be less than $10,000.00, greater than 0
     78 . I IBER'["IB090",$P(IBXDATA(IBI),U,9)'<10000 S IBER=IBER_"IB090;"
     79 . I '($P(IBXDATA(IBI),U,9)*$P(IBXDATA(IBI),U,8)),$$COBN^IBCEF(IBIFN)'>1 S Z="Procedure "_$P(IBXDATA(IBI),U,5)_" has a 0-charge and will not be transmitted" D WARN^IBCBB11(Z)
     80 . I $G(IBXDATA(IBI,"AUX"))'="",'$G(IBSP(1)),+IBSP'=35,$TR($P(IBXDATA(IBI,"AUX"),U,4,6)_$P(IBXDATA(IBI,"AUX"),U,2),U)'="" S IBSP(1)=1
     81 I IBTX,IBLCT>50 D
     82 . I '$$REQMRA^IBEFUNC(IBIFN) S IBER=IBER_"IB308;" Q
     83 . I '$P(IBNDTX,U,9) S IBER=IBER_"IB325;"
     84 I $G(IBSP(1)) D WARN^IBCBB11("Chiropractic service details only valid if provider specialty is '35'")
     85 I IBPS'="" D WARN^IBCBB11("NON-VA facility indicated, but no purchased service charge on line item"_$S(IBPS[",":"s",1:"")_" #"_IBPS)
     86 I $P(IBNDU2,U,11),$P(IBNDU2,U,11)=4,IBOLAB>1 D WARN^IBCBB11("For proper payment, you must bill each outside lab on a separate claim form")
     87 K IBXDATA
     88 ;
     89 ;       ; Check for Physician Name
     90 D F^IBCEF("N-REFERRING PROVIDER NAME",,,IBIFN)
     91 I $P($G(IBXDATA),U)]"" D
     92 .N IBZ,FUNCTION,IBINS
     93 .S FUNCTION=1
     94 .F IBINS=1:1:3 D
     95 .. S Z=$$GETTYP^IBCEP2A(IBIFN,IBINS,FUNCTION)
     96 .. I Z,$P(Z,U,2) D  ; Rendering/attending prov secondary id required
     97 ... N IBID,IBOK,Q0
     98 ... D PROVINF^IBCEF74(IBIFN,IBINS,.IBID,1,"C")  ; check all as though they were current
     99 ... S IBOK=0
     100 ... S Q0=0 F  S Q0=$O(IBID(1,FUNCTION,Q0)) Q:'Q0  I $P(IBID(1,FUNCTION,Q0),U,9)=+Z S IBOK=1 Q
     101 ... I 'IBOK S IBER=IBER_$S(IBINS=1:"IB239;",IBINS=2:"IB240;",IBINS=3:"IB241;",1:"")
     102 ;
     103 Q
     104 ;
     105OCC10(IBIFN,IBARR,IBFT) ; Determine if occurrence code 10 exists for pregnancy dx
     106 ; IBARR=array subscripted by ien of DX code if IBFT=2 (CMS-1500 form)
     107 ;                         by seq # and = ien of DX code if IBFT'=2
     108 ;
     109 N IBN,IBI,IBXDATA,IBXSAVE,IBDX,Z
     110 S IBN=1
     111 ;
     112 I '$D(^TMP($J,"LMD")) D
     113 . D F^IBCEF("N-OCCURRENCE CODES",,,IBIFN)
     114 . S ^TMP($J,"LMD")=""
     115 . S Z=0 F  S Z=$O(IBXSAVE("OCC",Z)) Q:'Z  I +IBXSAVE("OCC",Z)=10 S ^TMP($J,"LMD")=1 Q
     116 ;
     117 I '^TMP($J,"LMD") S IBI=0 F  S IBI=$O(IBARR(IBI))  Q:'IBI  D  Q:'IBN
     118 . N Z,Z1
     119 . ; If a pregnancy DX exists, must be an occurrence code 10 for LMP date
     120 . ; dx ranges are: V22*-V24*, V27*-V28*, 630*-677*
     121 . S IBDX=$S($G(IBFT)'=2:+IBARR(IBI),1:IBI)
     122 . S Z=$E($P($$ICD9^IBACSV(IBDX),U),1,3),Z1=$E(Z,2,3)
     123 . I $S(Z'<630&(Z<678):1,$E(Z)="V":$S(Z1'<22&(Z1<25):1,1:Z1'<27&(Z1<28)),1:0) S IBN=0 ;Pregnancy Dx exists
     124 ;
     125OCC10Q K ^TMP($J,"LMD")
     126 Q IBN
     127 ;

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCBB3.m

    r613 r623  
    1 IBCBB3  ;ALB/TMP - CONTINUATION OF EDIT CHECKS ROUTINE (MEDICARE) ;06/23/98
    2         ;;2.0;INTEGRATED BILLING;**51,137,155,349,371,377**;21-MAR-94;Build 23
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5 EDITMRA(IBQUIT,IBER,IBIFN,IBFT) ;
    6         ; Requires execution of GVAR^IBCBB, IBIFN defined
    7         ; File IB ERROR (350.8) contains error codes/text
    8         ;
    9         N IBMRATYP,Z,IBZP,IBZP1,IBOK
    10         S IBQUIT=0 ;Flag to say we have too many errors - quit edits
    11         ;
    12         S IBMRATYP=$$MRATYPE^IBEFUNC(IBIFN,"C")
    13         ;
    14         I IBFT=3 D
    15         . D PARTA
    16         ;
    17         I IBFT=2 D PARTB^IBCBB9
    18         ;
    19         K IBXDATA D F^IBCEF("N-ADMITTING DIAGNOSIS",,,IBIFN)
    20         ; Req. for UB-04 type of bills 11x!18x
    21         I $G(IBXDATA)="",IBFT=3 D  Q:IBQUIT
    22         . N Z
    23         . I "^11^18^"[(U_IBTOB12_U) S IBQUIT=$$IBER(.IBER,231) Q
    24         . I $$INPAT^IBCEF(IBIFN,1) S Z="Admitting Diagnosis may be required by payer, please verify" D WARN^IBCBB11(Z)
    25         ;
    26         D GETPRV^IBCEU(IBIFN,"2,3,4",.Z)
    27         S IBOK=1,Z=0,IBZP=U F  S Z=$O(Z(Z)) Q:'Z  S:$S($P($G(Z(Z,1)),U,3)["VA(200":1,1:0) IBZP=IBZP_+$P(Z(Z,1),U,3)_U
    28         D ALLPROC^IBCVA1(IBIFN,.IBZP1)
    29         S Z=0 F  S Z=$O(IBZP1(Z)) Q:'Z  I $P(IBZP1(Z),U,18),IBZP'[(U_$P(IBZP1(Z),U,18)_U) S IBOK=0 Q
    30         I 'IBOK D WARN^IBCBB11("At least one provider on a procedure does not match your "_$S(IBFT=2:"render",1:"attend")_"ing or operating provider")
    31         I IBFT=2 D EN^IBCBB2
    32         ; edit checks for UB-04 (institutional) forms
    33         I IBFT=3 D EN^IBCBB21(.IBZPRC92)
    34         ;
    35         Q
    36         ;
    37 PARTA   ; MEDICARE specific edit checks for PART A claims (UB-04 formats)
    38         ;
    39         N IBI,IBJ,IBX,IBCTYP,VADM,VAPA,IBSTOP,IBDXC,IBDXARY,IBPR,IBLABS,REQMRA
    40         N IBS,IBTUNIT,IBCAGE,IBREV1,IBOCCS,IBOCSDT,IBVALCD,IBOCCD,IBNOPR
    41         N IBCCARY1,IBPATST,IBZADMIT,IBZDISCH,IBXIEN,IBXERR,IBXDATA,IBOCSP
    42         N IBCOV,IBNCOV,IBREVC,IBREVDUP,IBBCPT,IBREVC12,IBREVTOT,IBECAT,IBINC
    43         ;
    44         ; Medicare is the current payer, but no diagnosis codes
    45         I $$WNRBILL^IBEFUNC(IBIFN) D SET^IBCSC4D(IBIFN,.IBDX,.IBDXO) I '$P(IBDX,U,2) S IBQUIT=$$IBER(.IBER,120) Q:IBQUIT
    46         ;
    47         ; Type of Bill must be three digits
    48         I IBTOB'?3N S X=$$IBER(.IBER,103) Q
    49         ;
    50         ; Covered Days
    51         S IBCTYP=0
    52         S IBCOV=$P(IBNDU2,U,2),IBNCOV=$P(IBNDU2,U,3)
    53         ;
    54         ; If interim bill, covered days must not be greater than 60
    55         I "23"[$E(IBTOB,3),IBCOV>60 S IBQUIT=$$IBER(.IBER,"096") Q:IBQUIT
    56         ;
    57         ; I bill type is 11x or 18x or 21x then we need covered days
    58         I "^11^18^21^"[(U_IBTOB12_U) S IBCTYP=1 I IBCOV="" S IBQUIT=$$IBER(.IBER,106) Q:IBQUIT
    59         ;
    60         S (IBI,IBJ)=0
    61         K IBXDATA D F^IBCEF("N-CONDITION CODES",,,IBIFN)
    62         ; Re-sort the condition codes by code
    63         S IBI=0 F  S IBI=$O(IBXDATA(IBI)) Q:'IBI  S IBCCARY1($P(IBXDATA(IBI),U))=""
    64         ;
    65         ; for condition code 40, covered days must be 0
    66         I $D(IBCCARY1(40)),IBCOV'=0 S IBQUIT=$$IBER(.IBER,107) Q:IBQUIT
    67         ;
    68         ; cov days+non=to date -from date unless the patient status = 30 (still
    69         ;  pt) or outpatient or if the to date and from date are same then add 1
    70         S IBPATST="",IBX=$P(IBNDU,U,12),IBPATST=$P($G(^DGCR(399.1,+IBX,0)),U,2)
    71         S IBINC=$S(IBPATST=30!(IBFDT=IBTDT):1,1:0)
    72         I $$INPAT^IBCEF(IBIFN,1),(IBCOV+IBNCOV)'=($$FMDIFF^XLFDT(IBTDT,IBFDT)+IBINC) S IBQUIT=$$IBER(.IBER,108) Q:IBQUIT
    73         ;
    74         ; if covered days >100 and type of bill is 21x or 18x error
    75         I IBCOV>100,(IBTOB12=18!(IBTOB12=21)) S IBQUIT=$$IBER(.IBER,109) Q:IBQUIT
    76         ;
    77         S (IBJ,IBTUNIT,IBS,IBREVTOT("AC"),IBREVTOT("AI"),IBREVTOT("AO"),IBREVTOT)=0
    78         ;
    79         K IBXDATA D F^IBCEF("N-UB-04 SERVICE LINE (EDI)",,,IBIFN) ;Get rev codes
    80         ;
    81         ; Re-sort the revenue codes by code
    82         ;>> IBREV1(rev code,x)=Rev code^ptr cpt^unit chg^units^total^tot unc
    83         ;   IBREV1(rev code) = revenue code edit category
    84         ;
    85         ; IBNOPR = flag that determines if there are revenue codes with
    86         ;          charges that do not have a procedure - no need to check
    87         ;          for billable MCR procedures if at least one RC is billable
    88         ;          1 = there is at least one billable revenue code without a
    89         ;              procedure
    90         ;
    91         S REQMRA=$$REQMRA^IBEFUNC(IBIFN)
    92         S (IBNOPR,IBI)=0
    93         F  S IBI=$O(IBXDATA(IBI)) Q:'IBI  D
    94         . I REQMRA D GYMODCHK(IBXDATA(IBI))      ; IB*2*377 GY modifier check
    95         . S IBJ=$P(IBXDATA(IBI),U),IBECAT=""
    96         . I 'IBNOPR D
    97         .. I $P(IBXDATA(IBI),U,2)'="" S IBPR($P(IBXDATA(IBI),U,2))=IBI Q
    98         .. S IBNOPR=1 K IBPR
    99         . S:$D(IBREV1(IBJ)) IBECAT=$G(IBREV1(IBJ))
    100         . I '$D(IBREV1(IBJ))!(IBECAT="") D  S IBREV1(IBJ)=IBECAT
    101         . . ;
    102         . . ; Accomodations (AC)
    103         . . I (IBJ'<100&(IBJ'>219))!(IBJ=224) S IBECAT="AC" Q
    104         . . ;
    105         . . ; Ancillary Outpatient (AO)
    106         . . I '$$INPAT^IBCEF(IBIFN,1) S IBECAT="AO" Q
    107         . . ;
    108         . . ; Ancillary Inpatient (AI)
    109         . . S IBECAT="AI"
    110         . ;
    111         . S IBREV1(IBJ,+$O(IBREV1(IBJ,""),-1)+1)=IBXDATA(IBI)
    112         . S IBREVTOT(IBECAT)=IBREVTOT(IBECAT)+$P(IBXDATA(IBI),U,6)
    113         . I IBECAT="AC" S IBTUNIT=IBTUNIT+$P(IBXDATA(IBI),U,4)
    114         ;
    115         I $$NEEDMRA^IBEFUNC(IBIFN),$O(IBPR(""))'="" D  Q:IBQUIT
    116         . ; Don't allow a bill containing only billable procedures for:
    117         . ;    Oxygen, labs, or influenza shots
    118         . ;  OR a bill with prosthetics on it
    119         . ;    to be sent to MEDICARE for an MRA
    120         . D NONMCR(.IBPR,.IBLABS) ; Remove Oxygen, labs, influenza shots
    121         . I $G(IBLABS) D WARN^IBCBB11("The only possible billable procedures on this bill are labs -"),WARN^IBCBB11(" Please verify that MEDICARE does not reimburse these labs at 100%") Q
    122         . I $O(IBPR(""))="" D
    123         .. S IBQUIT=$$IBER(.IBER,"098")
    124         ;
    125         ; covered days+non covered = units of accom rev codes
    126         ; Check room and board
    127         I IBTUNIT,IBTUNIT'=(IBCOV+IBNCOV) S IBQUIT=$$IBER(.IBER,114) Q:IBQUIT
    128         ;
    129         ; Non Covered Days
    130         ;   required when the type of bill is 11x,18x,21x or covered days=0
    131         I IBNCOV="",(IBCTYP!(IBCOV=0)) S IBQUIT=$$IBER(.IBER,115) Q:IBQUIT
    132         ;
    133         ; if cc code=40 then non-covered days must be 1
    134         I $D(IBCCARY1(40)),IBNCOV'=1 S IBQUIT=$$IBER(.IBER,116) Q:IBQUIT
    135         ;
    136         ; Patient Sex
    137         ; must be "M" or "F"
    138         D DEM^VADPT
    139         I $P(VADM(5),U)'="M",$P(VADM(5),U)'="F" S IBQUIT=$$IBER(.IBER,124) Q:IBQUIT
    140         ;
    141         ; esg - 10/17/07 - patch 371
    142         ; For Part A replacement MRA request claims, make sure
    143         ; the Medicare ICN/DCN number is present and also text in FL-80.
    144         I $$REQMRA^IBEFUNC(IBIFN),$F(".137.138.117.118.","."_IBTOB_".") D  Q:IBQUIT
    145         . N IBZ,FL80TXT
    146         . D F^IBCEF("N-CURR INS FORM LOC 64","IBZ",,IBIFN)  ; see CI3-11
    147         . I IBZ="" S IBQUIT=$$IBER(.IBER,205) Q:IBQUIT      ; missing ICN/DCN
    148         . S FL80TXT=$P($G(^DGCR(399,IBIFN,"UF2")),U,3)
    149         . I FL80TXT="" S IBQUIT=$$IBER(.IBER,206) Q:IBQUIT  ; missing FL80 text
    150         . Q
    151         ;
    152         D ^IBCBB4
    153         Q
    154         ;
    155 IBER(IBER,ERRNO)        ; Sets error list
    156         ; NOTE: add code to check error list > 20 ... If so, display message and
    157         ;   quit so we don't get too many errors at once to handle
    158         ;   Print all if printing list
    159         ;
    160         I '$G(IBQUIT) D
    161         . I ERRNO?1N.N S:$L(ERRNO)<3 ERRNO=$E("00",1,3-$L(ERRNO))_ERRNO
    162         . I $L(IBER,";")>19,'$G(IBPRT("PRT")) S IBER=IBER_"IB999;",IBQUIT=1
    163         . I $G(IBER)'[("IB"_ERRNO_";") S IBER=IBER_"IB"_ERRNO_";"
    164         Q IBQUIT
    165         ;
    166 NONMCR(IBPR,IBLABS)     ;  Delete all oxygen and lab, flu shot CPT entries from IBPR
    167         ; IBPR = array subscripted by CPT codes from bill
    168         ; IBLABS = flag returned =1 if labs found on bill
    169         N Z S IBLABS=0
    170         ; Oxygen
    171         F Z="A0422","A4575","A4616","A4619","A4620","A4621","E0455","E1353","E1355" K IBPR(Z)
    172         F Z=77:1:85 S Z0="E13"_Z K IBPR(Z0)
    173         ; Labs
    174         S Z="80000" F  S Z=$O(IBPR(Z)) Q:Z'?1"8"4N  S IBLABS=1
    175         ; Flu shots
    176         F Z="90724","G0008","90732","G0009","90657","90658","90659","90660" K IBPR(Z)
    177         Q
    178         ;
    179 MCRANUM(IBIFN)  ; Determine MEDICARE A provider ID # from bedsection for
    180         ; bill ien IBIFN
    181         N IBX
    182         ; PART A MRA (only) needed - determine if psych/non-psych claim
    183         N IBX,IBI
    184         S IBI=$P($G(^DGCR(399,IBIFN,"U")),U,11)
    185         S IBX=$S($TR($P($G(^DGCR(399.1,+IBI,0)),U),"psych","PSYCH")'["PSYCH":670899,1:674499)
    186         Q IBX
    187         ;
    188 MCRACK(IBIFN,X,IBFLD)   ; Check for MEDICARE A for bill IBIFN
    189         ; Called from CLAIM STATUS MRA field (#24) xrefs in file 399
    190         ; X = current value of field 399;24
    191         ; IBFLD = 1 for primary ins co, 2 for secondary, 3 for tertiary
    192         N IB
    193         S IB=0
    194         I +X,$$COBN^IBCEF(IBIFN)=IBFLD,$$WNRBILL^IBEFUNC(IBIFN,IBFLD),$$MRATYPE^IBEFUNC(IBIFN,"C")="A" S IB=1
    195         Q IB
    196         ;
    197 GYMODCHK(Z)     ; GY modifier check procedure.  IB*2*377 - 2/4/08
    198         ; Z is the IBXDATA(IBI) service line EDI
    199         N MODS
    200         I IBER["IB123" Q     ; error already found
    201         S MODS=$P(Z,U,9)     ; list of modifiers separated by commas
    202         I MODS'["GY" Q       ; GY modifier not here on this line item
    203         I $P(Z,U,6) Q        ; non-covered charges exist on this line item
    204         S IBQUIT=$$IBER(.IBER,123)
    205 GYMODX  ;
    206         Q
    207         ;
     1IBCBB3 ;ALB/TMP - CONTINUATION OF EDIT CHECKS ROUTINE (MEDICARE) ;06/23/98
     2 ;;2.0;INTEGRATED BILLING;**51,137,155,349**;21-MAR-94;Build 46
     3 ;;Per VHA Directive 2004-038, this routine should not be modified.
     4 ;
     5EDITMRA(IBQUIT,IBER,IBIFN,IBFT) ;
     6 ; Requires execution of GVAR^IBCBB, IBIFN defined
     7 ; File IB ERROR (350.8) contains error codes/text
     8 ;
     9 N IBMRATYP,Z,IBZP,IBZP1,IBOK
     10 S IBQUIT=0 ;Flag to say we have too many errors - quit edits
     11 ;
     12 S IBMRATYP=$$MRATYPE^IBEFUNC(IBIFN,"C")
     13 ;
     14 I IBFT=3 D
     15 . D PARTA
     16 ;
     17 I IBFT=2 D PARTB^IBCBB9
     18 ;
     19 K IBXDATA D F^IBCEF("N-ADMITTING DIAGNOSIS",,,IBIFN)
     20 ; Req. for UB-04 type of bills 11x!18x
     21 I $G(IBXDATA)="",IBFT=3 D  Q:IBQUIT
     22 . N Z
     23 . I "^11^18^"[(U_IBTOB12_U) S IBQUIT=$$IBER^IBCBB3(.IBER,231) Q
     24 . I $$INPAT^IBCEF(IBIFN,1) S Z="Admitting Diagnosis may be required by payer, please verify" D WARN^IBCBB11(Z)
     25 ;
     26 D GETPRV^IBCEU(IBIFN,"2,3,4",.Z)
     27 S IBOK=1,Z=0,IBZP=U F  S Z=$O(Z(Z)) Q:'Z  S:$S($P($G(Z(Z,1)),U,3)["VA(200":1,1:0) IBZP=IBZP_+$P(Z(Z,1),U,3)_U
     28 D ALLPROC^IBCVA1(IBIFN,.IBZP1)
     29 S Z=0 F  S Z=$O(IBZP1(Z)) Q:'Z  I $P(IBZP1(Z),U,18),(U_$P(IBZP1(Z),U,18)_U)'[IBZP S IBOK=0 Q
     30 I 'IBOK D WARN^IBCBB11("At least one provider on a procedure does not match your "_$S(IBFT=2:"render",1:"attend")_"ing or operating provider")
     31 I IBFT=2 D EN^IBCBB2
     32 ; edit checks for UB-04 (institutional) forms
     33 I IBFT=3 D EN^IBCBB21(.IBZPRC92)
     34 ;
     35 Q
     36 ;
     37PARTA ; MEDICARE specific edit checks for PART A claims (UB-04 formats)
     38 ;
     39 N IBI,IBJ,IBX,IBCTYP,VADM,VAPA,IBSTOP,IBDXC,IBDXARY,IBPR,IBLABS
     40 N IBS,IBTUNIT,IBCAGE,IBREV1,IBOCCS,IBOCSDT,IBVALCD,IBOCCD,IBNOPR
     41 N IBCCARY1,IBPATST,IBZADMIT,IBZDISCH,IBXIEN,IBXERR,IBXDATA,IBOCSP
     42 N IBCOV,IBNCOV,IBREVC,IBREVDUP,IBBCPT,IBREVC12,IBREVTOT,IBECAT,IBINC
     43 ;
     44 ; Medicare is the current payer, but no diagnosis codes
     45 I $$WNRBILL^IBEFUNC(IBIFN) D SET^IBCSC4D(IBIFN,.IBDX,.IBDXO) I '$P(IBDX,U,2) S IBQUIT=$$IBER(.IBER,120) Q:IBQUIT
     46 ;
     47 ; Type of Bill must be three digits
     48 I IBTOB'?3N S X=$$IBER(.IBER,103) Q
     49 ;
     50 ; Covered Days
     51 S IBCTYP=0
     52 S IBCOV=$P(IBNDU2,U,2),IBNCOV=$P(IBNDU2,U,3)
     53 ;
     54 ; If interim bill, covered days must not be greater than 60
     55 I "23"[$E(IBTOB,3),IBCOV>60 S IBQUIT=$$IBER(.IBER,"096") Q:IBQUIT
     56 ;
     57 ; I bill type is 11x or 18x or 21x then we need covered days
     58 I "^11^18^21^"[(U_IBTOB12_U) S IBCTYP=1 I IBCOV="" S IBQUIT=$$IBER(.IBER,106) Q:IBQUIT
     59 ;
     60 S (IBI,IBJ)=0
     61 K IBXDATA D F^IBCEF("N-CONDITION CODES",,,IBIFN)
     62 ; Re-sort the condition codes by code
     63 S IBI=0 F  S IBI=$O(IBXDATA(IBI)) Q:'IBI  S IBCCARY1($P(IBXDATA(IBI),U))=""
     64 ;
     65 ; for condition code 40, covered days must be 0
     66 I $D(IBCCARY1(40)),IBCOV'=0 S IBQUIT=$$IBER(.IBER,107) Q:IBQUIT
     67 ;
     68 ; cov days+non=to date -from date unless the patient status = 30 (still
     69 ;  pt) or outpatient or if the to date and from date are same then add 1
     70 S IBPATST="",IBX=$P(IBNDU,U,12),IBPATST=$P($G(^DGCR(399.1,+IBX,0)),U,2)
     71 S IBINC=$S(IBPATST=30!(IBFDT=IBTDT):1,1:0)
     72 I $$INPAT^IBCEF(IBIFN,1),(IBCOV+IBNCOV)'=($$FMDIFF^XLFDT(IBTDT,IBFDT)+IBINC) S IBQUIT=$$IBER(.IBER,108) Q:IBQUIT
     73 ;
     74 ; if covered days >100 and type of bill is 21x or 18x error
     75 I IBCOV>100,(IBTOB12=18!(IBTOB12=21)) S IBQUIT=$$IBER(.IBER,109) Q:IBQUIT
     76 ;
     77 S (IBJ,IBTUNIT,IBS,IBREVTOT("AC"),IBREVTOT("AI"),IBREVTOT("AO"),IBREVTOT)=0
     78 ;
     79 K IBXDATA D F^IBCEF("N-UB-04 SERVICE LINE (EDI)",,,IBIFN) ;Get rev codes
     80 ;
     81 ; Re-sort the revenue codes by code
     82 ;>> IBREV1(rev code,x)=Rev code^ptr cpt^unit chg^units^total^tot unc
     83 ;   IBREV1(rev code) = revenue code edit category
     84 ;
     85 ; IBNOPR = flag that determines if there are revenue codes with
     86 ;          charges that do not have a procedure - no need to check
     87 ;          for billable MCR procedures if at least one RC is billable
     88 ;          1 = there is at least one billable revenue code without a
     89 ;              procedure
     90 ;
     91 S (IBNOPR,IBI)=0
     92 F  S IBI=$O(IBXDATA(IBI)) Q:'IBI  D
     93 . S IBJ=$P(IBXDATA(IBI),U),IBECAT=""
     94 . I 'IBNOPR D
     95 .. I $P(IBXDATA(IBI),U,2)'="" S IBPR($P(IBXDATA(IBI),U,2))=IBI Q
     96 .. S IBNOPR=1 K IBPR
     97 . S:$D(IBREV1(IBJ)) IBECAT=$G(IBREV1(IBJ))
     98 . I '$D(IBREV1(IBJ))!(IBECAT="") D  S IBREV1(IBJ)=IBECAT
     99 . . ;
     100 . . ; Accomodations (AC)
     101 . . I (IBJ'<100&(IBJ'>219))!(IBJ=224) S IBECAT="AC" Q
     102 . . ;
     103 . . ; Ancillary Outpatient (AO)
     104 . . I '$$INPAT^IBCEF(IBIFN,1) S IBECAT="AO" Q
     105 . . ;
     106 . . ; Ancillary Inpatient (AI)
     107 . . S IBECAT="AI"
     108 . ;
     109 . S IBREV1(IBJ,+$O(IBREV1(IBJ,""),-1)+1)=IBXDATA(IBI)
     110 . S IBREVTOT(IBECAT)=IBREVTOT(IBECAT)+$P(IBXDATA(IBI),U,6)
     111 . I IBECAT="AC" S IBTUNIT=IBTUNIT+$P(IBXDATA(IBI),U,4)
     112 ;
     113 I $$NEEDMRA^IBEFUNC(IBIFN),$O(IBPR(""))'="" D  Q:IBQUIT
     114 . ; Don't allow a bill containing only billable procedures for:
     115 . ;    Oxygen, labs, or influenza shots
     116 . ;  OR a bill with prosthetics on it
     117 . ;    to be sent to MEDICARE for an MRA
     118 . D NONMCR(.IBPR,.IBLABS) ; Remove Oxygen, labs, influenza shots
     119 . ;I $O(IBPR(""))="" D
     120 . I $G(IBLABS) D WARN^IBCBB11("The only possible billable procedures on this bill are labs -"),WARN^IBCBB11(" Please verify that MEDICARE does not reimburse these labs at 100%") Q
     121 . I $O(IBPR(""))="" D
     122 .. S IBQUIT=$$IBER(.IBER,"098")
     123 ;
     124 ; covered days+non covered = units of accom rev codes
     125 ; Check room and board
     126 I IBTUNIT,IBTUNIT'=(IBCOV+IBNCOV) S IBQUIT=$$IBER(.IBER,114) Q:IBQUIT
     127 ;
     128 ; Non Covered Days
     129 ;   required when the type of bill is 11x,18x,21x or covered days=0
     130 I IBNCOV="",(IBCTYP!(IBCOV=0)) S IBQUIT=$$IBER(.IBER,115) Q:IBQUIT
     131 ;
     132 ; if cc code=40 then non-covered days must be 1
     133 I $D(IBCCARY1(40)),IBNCOV'=1 S IBQUIT=$$IBER(.IBER,116) Q:IBQUIT
     134 ;
     135 ; Patient Sex
     136 ; must be "M" or "F"
     137 D DEM^VADPT
     138 I $P(VADM(5),U)'="M",$P(VADM(5),U)'="F" S IBQUIT=$$IBER(.IBER,124) Q:IBQUIT
     139 ;
     140 D ^IBCBB4
     141 Q
     142 ;
     143IBER(IBER,ERRNO) ; Sets error list
     144 ; NOTE: add code to check error list > 20 ... If so, display message and
     145 ;   quit so we don't get too many errors at once to handle
     146 ;   Print all if printing list
     147 ;
     148 I '$G(IBQUIT) D
     149 . I ERRNO?1N.N S:$L(ERRNO)<3 ERRNO=$E("00",1,3-$L(ERRNO))_ERRNO
     150 . I $L(IBER,";")>19,'$G(IBPRT("PRT")) S IBER=IBER_"IB999;",IBQUIT=1
     151 . I $G(IBER)'[("IB"_ERRNO_";") S IBER=IBER_"IB"_ERRNO_";"
     152 Q IBQUIT
     153 ;
     154NONMCR(IBPR,IBLABS) ;  Delete all oxygen and lab, flu shot CPT entries from IBPR
     155 ; IBPR = array subscripted by CPT codes from bill
     156 ; IBLABS = flag returned =1 if labs found on bill
     157 N Z S IBLABS=0
     158 ; Oxygen
     159 F Z="A0422","A4575","A4616","A4619","A4620","A4621","E0455","E1353","E1355" K IBPR(Z)
     160 F Z=77:1:85 S Z0="E13"_Z K IBPR(Z0)
     161 ; Labs
     162 ;S Z="80000" F  S Z=$O(IBPR(Z)) Q:Z'?1"8"4N  K IBPR(Z) S IBLABS=1
     163 S Z="80000" F  S Z=$O(IBPR(Z)) Q:Z'?1"8"4N  S IBLABS=1
     164 ; Flu shots
     165 F Z="90724","G0008","90732","G0009","90657","90658","90659","90660" K IBPR(Z)
     166 Q
     167 ;
     168MCRANUM(IBIFN) ; Determine MEDICARE A provider ID # from bedsection for
     169 ; bill ien IBIFN
     170 N IBX
     171 ; PART A MRA (only) needed - determine if psych/non-psych claim
     172 N IBX,IBI
     173 S IBI=$P($G(^DGCR(399,IBIFN,"U")),U,11)
     174 S IBX=$S($TR($P($G(^DGCR(399.1,+IBI,0)),U),"psych","PSYCH")'["PSYCH":670899,1:674499)
     175 Q IBX
     176 ;
     177MCRACK(IBIFN,X,IBFLD) ; Check for MEDICARE A for bill IBIFN
     178 ; Called from CLAIM STATUS MRA field (#24) xrefs in file 399
     179 ; X = current value of field 399;24
     180 ; IBFLD = 1 for primary ins co, 2 for secondary, 3 for tertiary
     181 N IB
     182 S IB=0
     183 I +X,$$COBN^IBCEF(IBIFN)=IBFLD,$$WNRBILL^IBEFUNC(IBIFN,IBFLD),$$MRATYPE^IBEFUNC(IBIFN,"C")="A" S IB=1
     184 Q IB
     185 ;

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCBB5.m

    r613 r623  
    1 IBCBB5  ;ALB/BGA - CONT OF MEDICARE EDIT CHECKS ;08/12/98
    2         ;;2.0;INTEGRATED BILLING;**51,137,371**;21-MAR-94;Build 57
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5         D F^IBCEF("N-ADMISSION DATE","IBZADMIT",,IBIFN)
    6         D F^IBCEF("N-DISCHARGE DATE","IBZDISCH",,IBIFN)
    7         ;
    8         ; Occurrence Code and Dates
    9         ;   occ codes can not be duplicates for same dates and must have a date
    10         K IBXSAVE,IBXDATA D F^IBCEF("N-OCCURRENCE CODES",,,IBIFN)
    11         ; Returns arrays IBXSAVE("OCC",n) AND IBXSAVE("OCCS",n) =
    12         ;       code^start date^state^end date
    13         ; IBOCS=occ codes ;; IBOCSP=occ span codes
    14         ;
    15         S IBI=0 F  S IBI=$O(IBXSAVE("OCCS",IBI)) Q:'IBI  D
    16         . N IBOCSDT,IBOCSDT1,Z
    17         . S IBOCSDT=$P(IBXSAVE("OCCS",IBI),U,2),IBOCSDT1=$P(IBXSAVE("OCCS",IBI),U,3),IBOCCS=$P(IBXSAVE("OCCS",IBI),U)
    18         . S IBOCSP(IBOCCS,$O(IBOCSP(IBOCCS,""),-1)+1)=IBXSAVE("OCCS",IBI)
    19         . ; Occurrence Code End dates must be > start date and are required for OCCURANCE SPANS
    20         . I 'IBOCSDT1 S IBER=IBER_"IB155;" Q
    21         . I IBOCSDT1<IBOCSDT S IBER=IBER_"IB150;" Q
    22         ;
    23         S IBI=0 F  S IBI=$O(IBXSAVE("OCC",IBI)) Q:'IBI  D
    24         . N Z
    25         . S IBOCCD=$P(IBXSAVE("OCC",IBI),U)
    26         . S IBOCCD(IBOCCD,$O(IBOCCD(IBOCCD,""),-1)+1)=IBXSAVE("OCC",IBI)
    27         . I IBOCCD=10 S ^TMP($J,"LMD")=1
    28         Q:IBQUIT
    29         ;
    30         ; For type of admit = 1 or 2, at least one occ code 1-6, 10, or 11 req
    31         I $P(IBNDU,U,8)=1!($P(IBNDU,U,8)=2) D
    32         . N OK
    33         . S OK=0
    34         . F Z="01","02","03","04","05","06",10,11 I $D(IBOCCD(Z))!($D(IBOCCD(+Z))) S OK=1 Q
    35         . I 'OK S IBQUIT=$$IBER^IBCBB3(.IBER,133)
    36         K IBXDATA D F^IBCEF("N-VALUE CODES",,,IBIFN)
    37         S IBX=0
    38         F  S IBX=$O(IBXDATA(IBX)) Q:'IBX  D  Q:IBQUIT
    39         . I '$D(IBVALCD($P(IBXDATA(IBX),U))) S IBVALCD($P(IBXDATA(IBX),U))=$P(IBXDATA(IBX),U,2)
    40         . ; value code 01 must have a value>0
    41         . I $P(IBXDATA(IBX),U)="01",IBER'["134;",$P(IBXDATA(IBX),U,2)'>0 S IBQUIT=$$IBER^IBCBB3(.IBER,134) Q
    42         . ; value code 02 must have a value=0
    43         . I $P(IBXDATA(IBX),U)="02",IBER'["135;",+$P(IBXDATA(IBX),U,2)'=0 S IBQUIT=$$IBER^IBCBB3(.IBER,135) Q
    44         . ; code^amount^dollar amt flag (1=amt,0=quantity)
    45         . I $P(IBXDATA(IBX),U,2)="",IBER'["157;" S IBQUIT=$$IBER^IBCBB3(.IBER,157) Q
    46         . I '$$CHK^IBCVC($P(IBXDATA(IBX),U,4),$P(IBXDATA(IBX),U,2)),IBER'["158;" S IBQUIT=$$IBER^IBCBB3(.IBER,158) Q
    47         ;
    48         Q:IBQUIT
    49         ; Must have acc hr if accident is indicated on inpatient bill
    50         I $$INPAT^IBCEF(IBIFN,1) D
    51         . I $D(IBOCCD("01"))!$D(IBOCCD("02"))!$D(IBOCCD("03"))!$D(IBOCCD("04"))!$D(IBOCCD("05")) D
    52         .. I '$D(IBVALCD(45)),'$P($G(^DGCR(399,IBIFN,"U")),U,10) S IBQUIT=$$IBER^IBCBB3(.IBER,156)
    53         Q:IBQUIT
    54         ;
    55         D ^IBCBB6
    56         Q
     1IBCBB5 ;ALB/BGA - CONT OF MEDICARE EDIT CHECKS ;08/12/98
     2 ;;2.0;INTEGRATED BILLING;**51,137**;21-MAR-94
     3 ;;Per VHA Directive 10-93-142, this routine should not be modified
     4 ;
     5 D F^IBCEF("N-ADMISSION DATE","IBZADMIT",,IBIFN)
     6 D F^IBCEF("N-DISCHARGE DATE","IBZDISCH",,IBIFN)
     7 ;
     8 ; Occurrence Code and Dates
     9 ;   occ codes can not be duplicates for same dates and must have a date
     10 K IBXSAVE,IBXDATA D F^IBCEF("N-OCCURRENCE CODES",,,IBIFN)
     11 ; Returns arrays IBXSAVE("OCC",n) AND IBXSAVE("OCCS",n) =
     12 ;       code^start date^state^end date
     13 ; IBOCS=occ codes ;; IBOCSP=occ span codes
     14 ;
     15 S IBI=0 F  S IBI=$O(IBXSAVE("OCCS",IBI)) Q:'IBI  D
     16 . N IBOCSDT,IBOCSDT1,Z
     17 . S IBOCSDT=$P(IBXSAVE("OCCS",IBI),U,2),IBOCSDT1=$P(IBXSAVE("OCCS",IBI),U,4),IBOCCS=$P(IBXSAVE("OCCS",IBI),U)
     18 . S IBOCSP(IBOCCS,$O(IBOCSP(IBOCCS,""),-1)+1)=IBXSAVE("OCCS",IBI)
     19 ;
     20 S IBI=0 F  S IBI=$O(IBXSAVE("OCC",IBI)) Q:'IBI  D
     21 . N Z
     22 . S IBOCCD=$P(IBXSAVE("OCC",IBI),U)
     23 . S IBOCCD(IBOCCD,$O(IBOCCD(IBOCCD,""),-1)+1)=IBXSAVE("OCC",IBI)
     24 . I IBOCCD=10 S ^TMP($J,"LMD")=1
     25 Q:IBQUIT
     26 ;
     27 ; For type of admit = 1 or 2, at least one occ code 1-6, 10, or 11 req
     28 I $P(IBNDU,U,8)=1!($P(IBNDU,U,8)=2) D
     29 . N OK
     30 . S OK=0
     31 . F Z="01","02","03","04","05","06",10,11 I $D(IBOCCD(Z))!($D(IBOCCD(+Z))) S OK=1 Q
     32 . I 'OK S IBQUIT=$$IBER^IBCBB3(.IBER,133)
     33 K IBXDATA D F^IBCEF("N-VALUE CODES",,,IBIFN)
     34 S IBX=0
     35 F  S IBX=$O(IBXDATA(IBX)) Q:'IBX  D  Q:IBQUIT
     36 . ; value code 01 must have a value>0
     37 . I $P(IBXDATA(IBX),U)="01",IBER'["134;",$P(IBXDATA(IBX),U,2)'>0 S IBQUIT=$$IBER^IBCBB3(.IBER,134)
     38 . Q:IBQUIT
     39 . ; value code 02 must have a value=0
     40 . I $P(IBXDATA(IBX),U)="02",IBER'["135;",+$P(IBXDATA(IBX),U,2)'=0 S IBQUIT=$$IBER^IBCBB3(.IBER,135)
     41 . ; code^amount^dollar amt flag (1=amt,0=quantity)
     42 . Q:IBQUIT
     43 . I '$D(IBVALCD($P(IBXDATA(IBX),U))) S IBVALCD($P(IBXDATA(IBX),U))=$P(IBXDATA(IBX),U,2) Q
     44 ; Must have value code 01 or 02 for TOB 11X, 18X, 21X - default it
     45 ;I '$D(IBVALCD("01")),'$D(IBVALCD("02")),$S(IBTOB12="11":1,IBTOB12="18":1,1:IBTOB12="21") S IBQUIT=$$IBER^IBCBB3(.IBER,132)
     46 ;
     47 Q:IBQUIT
     48 ; Must have acc hr if accident is indicated on inpatient bill
     49 I $$INPAT^IBCEF(IBIFN,1) D
     50 . I $D(IBOCCD("01"))!$D(IBOCCD("02"))!$D(IBOCCD("03"))!$D(IBOCCD("04"))!$D(IBOCCD("05")) D
     51 .. I '$D(IBVALCD(45)),'$P($G(^DGCR(399,IBIFN,"U")),U,10) S IBQUIT=$$IBER^IBCBB3(.IBER,156)
     52 Q:IBQUIT
     53 ;
     54 D ^IBCBB6
     55 Q

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCBB9.m

    r613 r623  
    1 IBCBB9  ;ALB/BGA MEDICARE PART B EDIT CHECKS ;10/15/98
    2         ;;2.0;INTEGRATED BILLING;**51,137,155,349,371**;21-MAR-94;Build 57
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5 PARTB   ; MEDICARE specific edit checks for PART B claims (CMS-1500)
    6         ;
    7         N IBXDATA,IBXERR,IBXIEN,IBXSAVE,IBPR,IBDTFLG
    8         ;
    9         I $$NEEDMRA^IBEFUNC(IBIFN) D
    10         . K IBXDATA
    11         . D F^IBCEF("N-HCFA 1500 SERVICE LINE (EDI)",,,IBIFN)
    12         . S IBI=0
    13         . F  S IBI=$O(IBXDATA(IBI)) Q:'IBI  D
    14         .. S IBJ=$P(IBXDATA(IBI),U,5)
    15         .. I IBJ'="","^CJ^HC^"[(U_$P(IBXDATA(IBI),U,6)_U) S IBPR(IBJ)=""
    16         . I $$REQMRA^IBEFUNC(IBIFN),$O(IBXDATA(""),-1)>12 D WARN^IBCBB11("This claim will be split into multiple EOB'S since there are more than 12"),WARN^IBCBB11("service lines being submitted on the claim.")
    17         . I $$REQMRA^IBEFUNC(IBIFN),$E(IBFDT,1,3)'=$E(IBTDT,1,3) D WARN^IBCBB11("This claim will be split into multiple EOB'S due to the service dates"),WARN^IBCBB11("spanning different calendar years.")
    18         . D NONMCR^IBCBB3(.IBPR,.IBLABS) ; Oxygen, labs, influenza shots
    19         . S Z="80000" F  S Z=$O(IBPR(Z)) Q:Z'?1"8"4N  S IBLABS=1
    20         . I $G(IBLABS) D WARN^IBCBB11("The only possible billable procedures on this bill are labs -"),WARN^IBCBB11(" Please verify that MEDICARE does not reimburse these labs at 100%") Q
    21         . I $O(IBPR(""))="" S IBQUIT=$$IBER^IBCBB3(.IBER,"098")
    22         ;
    23         ; First char of the pat's first and last name must be present and
    24         ; must be an alpha
    25         K IBXDATA D F^IBCEF("N-PATIENT NAME",,,IBIFN)
    26         S IBXDATA=$$NAME^IBCEFG1(IBXDATA)
    27         I $S($G(IBXDATA)="":1,$E($P(IBXDATA,U))=" "!($E($P(IBXDATA,U))'?1A):1,$E($P(IBXDATA,U,2))=" "!($E($P(IBXDATA,U,2))'?1A):1,1:0) S IBQUIT=$$IBER^IBCBB3(.IBER,300) Q:IBQUIT
    28         ;
    29         ; Must be a valid HIC #
    30         I '$$VALID^IBCBB8(IBIFN) S IBQUIT=$$IBER^IBCBB3(.IBER,215) Q:IBQUIT
    31         ;
    32         ; Specialty code 99 is not valid for Medicare MRA request claims
    33         I $$REQMRA^IBEFUNC(IBIFN),$$BILLSPEC^IBCEU3(IBIFN)=99 S IBQUIT=$$IBER^IBCBB3(.IBER,122) Q:IBQUIT
    34         ;
    35         Q
    36         ;
     1IBCBB9 ;ALB/BGA MEDICARE PART B EDIT CHECKS ;10/15/98
     2 ;;2.0;INTEGRATED BILLING;**51,137,155,349**;21-MAR-94;Build 46
     3 ;;Per VHA Directive 2004-038, this routine should not be modified.
     4 ;
     5PARTB ; MEDICARE specific edit checks for PART B claims (CMS-1500)
     6 ;
     7 N IBXDATA,IBXERR,IBXIEN,IBXSAVE,IBPR,IBDTFLG
     8 ;
     9 I $$NEEDMRA^IBEFUNC(IBIFN) D
     10 . K IBXDATA
     11 . D F^IBCEF("N-HCFA 1500 SERVICE LINE (EDI)",,,IBIFN)
     12 . S IBI=0
     13 . F  S IBI=$O(IBXDATA(IBI)) Q:'IBI  D
     14 .. S IBJ=$P(IBXDATA(IBI),U,5)
     15 .. I IBJ'="","^CJ^HC^"[(U_$P(IBXDATA(IBI),U,6)_U) S IBPR(IBJ)=""
     16 . I $$REQMRA^IBEFUNC(IBIFN),$O(IBXDATA(""),-1)>12 D WARN^IBCBB11("This claim will be split into multiple EOB'S since there are more than 12"),WARN^IBCBB11("service lines being submitted on the claim.")
     17 . I $$REQMRA^IBEFUNC(IBIFN),$E(IBFDT,1,3)'=$E(IBTDT,1,3) D WARN^IBCBB11("This claim will be split into multiple EOB'S due to the service dates"),WARN^IBCBB11("spanning different calendar years.")
     18 . D NONMCR^IBCBB3(.IBPR,.IBLABS) ; Oxygen, labs, influenza shots
     19 . S Z="80000" F  S Z=$O(IBPR(Z)) Q:Z'?1"8"4N  S IBLABS=1
     20 . I $G(IBLABS) D WARN^IBCBB11("The only possible billable procedures on this bill are labs -"),WARN^IBCBB11(" Please verify that MEDICARE does not reimburse these labs at 100%") Q
     21 . I $O(IBPR(""))="" S IBQUIT=$$IBER^IBCBB3(.IBER,"098")
     22 ;
     23 ; First char of the pat's first and last name must be present and
     24 ; must be an alpha
     25 K IBXDATA D F^IBCEF("N-PATIENT NAME",,,IBIFN)
     26 S IBXDATA=$$NAME^IBCEFG1(IBXDATA)
     27 I $S($G(IBXDATA)="":1,$E($P(IBXDATA,U))=" "!($E($P(IBXDATA,U))'?1A):1,$E($P(IBXDATA,U,2))=" "!($E($P(IBXDATA,U,2))'?1A):1,1:0) S IBQUIT=$$IBER^IBCBB3(.IBER,300) Q:IBQUIT
     28 ;
     29 ; First char of the pat's address and city must not be a space
     30 K IBXDATA D F^IBCEF("N-PATIENT STREET ADDRESS LN 1",,,IBIFN)
     31 I $G(IBXDATA)=""!($E($G(IBXDATA))=" ") S IBQUIT=$$IBER^IBCBB3(.IBER,302) Q:IBQUIT
     32 ;
     33 K IBXDATA D F^IBCEF("N-PATIENT CITY",,,IBIFN)
     34 I $G(IBXDATA)=""!($E($G(IBXDATA))=" ") S IBQUIT=$$IBER^IBCBB3(.IBER,302) Q:IBQUIT
     35 ;
     36 ; Must be a valid HIC #
     37 I '$$VALID^IBCBB8(IBIFN) S IBQUIT=$$IBER^IBCBB3(.IBER,215) Q:IBQUIT
     38 ;
     39 ; Specialty code 99 is not valid for Medicare MRA request claims
     40 I $$REQMRA^IBEFUNC(IBIFN),$$BILLSPEC^IBCEU3(IBIFN)=99 S IBQUIT=$$IBER^IBCBB3(.IBER,122) Q:IBQUIT
     41 ;
     42 Q
     43 ;

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCC1.m

    r613 r623  
    1 IBCC1   ;ALB/MJB - CANCEL THIRD PARTY BILL ;10-OCT-94
    2         ;;2.0;INTEGRATED BILLING;**19,95,160,159,320,347,377**;21-MAR-94;Build 23
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5 RNB     ; -- Add a reason not billable to claims tracking
    6         N X,Y,DIC,DIE,I,J,DA,DR,IBTYP,IBTRE,IB,IBAPPT,IBDT,IBTALK,IBCODE,IBTRED,IBTSAV,FILL,IBRX,IBDATA,IBD,IBDT,IBQUIT,IBPRO,IBDD
    7         N ZT,TCNT,CNT
    8         Q:'$G(IBIFN)
    9         S IB(0)=$G(^DGCR(399,IBIFN,0)),IBTYP=$P(IB(0),"^",5),IBQUIT=0
    10         I '$D(DFN) S DFN=$P(IB(0),"^",2)
    11         KILL ^TMP($J,"IBCC1")
    12         ;
    13         ; -- is inpt find entry in dgpm, then in ibt(356, s da=ibtre then edit
    14 INPT    I IBTYP<3 D
    15         .S DATE=$P(IB(0),"^",3),DFN=$P(IB(0),"^",2)
    16         .S DGPM=$O(^DGPM("APTT1",DFN,DATE,0)) ; double check for asih
    17         .I DGPM S (IBTRE,IBTSAV)=$O(^IBT(356,"AD",DGPM,0))
    18         .I $G(IBTRE) D CTSET(IBTRE)
    19         .Q:IBQUIT
    20         .;
    21         .; -- alternate inpt method
    22         .S IBCODE=$O(^IBE(356.6,"ACODE",1,0))
    23         .S DATE=$P(IB(0),"^",3),DFN=$P(IB(0),"^",2)
    24         .S IBDT=(DATE-.25) F  S IBDT=$O(^IBT(356,"APTY",DFN,IBCODE,IBDT)) Q:'IBDT!(IBDT>(DATE+.24))  D
    25         ..S IBTRE=0 F  S IBTRE=$O(^IBT(356,"APTY",DFN,IBCODE,IBDT,IBTRE)) Q:IBTRE=""!(IBQUIT)  D:$G(IBTSAV)'=IBTRE CTSET(IBTRE)
    26         .Q
    27         ;
    28 OPT     ; -- is opt-find entries in IBT(356, for opt dates and then edit
    29         I IBTYP>2 S IBCODE=$O(^IBE(356.6,"ACODE",2,0)) D
    30         .S IBAPPT=0 F  S IBAPPT=$O(^DGCR(399,IBIFN,"OP",IBAPPT)) Q:'IBAPPT!(IBQUIT)  D
    31         ..S IBDT=(IBAPPT-.01) F  S IBDT=$O(^IBT(356,"APTY",DFN,IBCODE,IBDT)) Q:'IBDT!(IBDT>(IBAPPT+.24))  D
    32         ...S IBTRE=0 F  S IBTRE=$O(^IBT(356,"APTY",DFN,IBCODE,IBDT,IBTRE)) Q:IBTRE=""!(IBQUIT)  D CTSET(IBTRE)
    33         .Q
    34         ;
    35 RX      ; -- find rx's on bill
    36         S IBDD=0 F  S IBDD=$O(^IBA(362.4,"AIFN"_IBIFN,IBDD)) Q:'IBDD  S IBD=0 F  S IBD=$O(^IBA(362.4,"AIFN"_IBIFN,IBDD,IBD)) Q:'IBD!(IBQUIT)  D
    37         .S IBDATA=$G(^IBA(362.4,IBD,0)),IBRX=$P(IBDATA,"^",5),IBDT=$P(IBDATA,"^",3)
    38         .I '$G(IBRX) S DIC=52,DIC(0)="BO",X=$P(IBDATA,"^",1) D DIC^PSODI(52,.DIC,X) S IBRX=+Y K DIC,X,Y Q:IBRX=-1
    39         .S FILL="" F  S FILL=$O(^IBT(356,"ARXFL",IBRX,FILL)) Q:FILL=""!(IBQUIT)  D
    40         ..S IBTRE=0 F  S IBTRE=$O(^IBT(356,"ARXFL",IBRX,FILL,IBTRE)) Q:'IBTRE!(IBQUIT)  I $P(^IBT(356,+IBTRE,0),"^",6)=IBDT D CTSET(IBTRE)
    41         ;
    42 PRO     ; -- find prosthetics on bill
    43         S IBDD=0 F  S IBDD=$O(^IBA(362.5,"AIFN"_IBIFN,IBDD)) Q:'IBDD  S IBD=0 F  S IBD=$O(^IBA(362.5,"AIFN"_IBIFN,IBDD,IBD)) Q:'IBD!(IBQUIT)  D
    44         .S IBDATA=$G(^IBA(362.5,IBD,0)),IBPRO=$P(IBDATA,"^",4)
    45         .Q:'$G(IBPRO)
    46         .S IBTRE=0 F  S IBTRE=$O(^IBT(356,"APRO",+IBPRO,IBTRE)) Q:'IBTRE!(IBQUIT)  D CTSET(IBTRE)
    47         ;
    48         ; ----- Finished with the gathering of the CT data entries -----
    49         ;
    50         ; count up the total number of CT entries recorded in the scratch global
    51         S ZT="",TCNT=0
    52         F  S ZT=$O(^TMP($J,"IBCC1",ZT)) Q:ZT=""  S IBTRE=0 F  S IBTRE=$O(^TMP($J,"IBCC1",ZT,IBTRE)) Q:'IBTRE  S TCNT=TCNT+1
    53         ;
    54         ; loop thru all of the associated CT entries and call the RNBEDIT procedure for each one
    55         S ZT="",CNT=0
    56         F  S ZT=$O(^TMP($J,"IBCC1",ZT)) Q:ZT=""!IBQUIT  D  Q:IBQUIT
    57         . S IBTRE=0 F  S IBTRE=$O(^TMP($J,"IBCC1",ZT,IBTRE)) Q:'IBTRE!IBQUIT  S CNT=CNT+1 D RNBEDIT(IBTRE,ZT,TCNT,CNT)
    58         . Q
    59         ;
    60         ; clean-up the scratch global when completed
    61         KILL ^TMP($J,"IBCC1")
    62         Q
    63         ;
    64 CTSET(IBTRE)    ; procedure to store this CT entry in the scratch global
    65         Q:'$G(IBTRE)
    66         S ^TMP($J,"IBCC1",$$TYPE(IBTRE),IBTRE)=""
    67 CTSETX  ;
    68         Q
    69         ;
    70 RNBEDIT(IBTRE,CTTYPE,TCNT,CNT)  ; CT entry display and capture RNB data and additional comment data
    71         Q:IBQUIT
    72         I '$D(IBTALK) D
    73         . N CTZ
    74         . W !!,"Since you have canceled this bill, you may enter a Reason Not Billable and"
    75         . W !,"an Additional Comment into Claims Tracking."
    76         . W !,"This will take the care off of the UNBILLED lists."
    77         . I TCNT=1 S CTZ="Note:  There is 1 associated Claims Tracking entry."
    78         . E  S CTZ="Note:  There are "_TCNT_" associated Claims Tracking entries."
    79         . W !!,CTZ
    80         . Q
    81         ;
    82         S IBTALK=1
    83         ;
    84         N %,IBTRED,IBTRED1 S IBTRED=$G(^IBT(356,IBTRE,0)),IBTRED1=$G(^IBT(356,IBTRE,1))
    85         ;
    86         W !!,"Claims Tracking Entry [",CNT," of ",TCNT,"]"
    87         W !?7,"Entry ID#: ",+IBTRED
    88         W !?12,"Type: ",$$EXPAND^IBTRE(356,.18,$P(IBTRED,U,18))
    89         ;
    90         I CTTYPE=1 D     ; inpatient admission or scheduled admission
    91         . W !?2,"Admission Date: ",$$FMTE^XLFDT($P(IBTRED,U,6),"1P")
    92         . Q
    93         ;
    94         I CTTYPE=2 D     ; outpatient visit
    95         . N IBOE,IBOE0
    96         . W !?6,"Visit Date: ",$$FMTE^XLFDT($P(IBTRED,U,6),"1P")
    97         . S IBOE=+$P(IBTRED,U,4),IBOE0=$$SCE^IBSDU(IBOE)
    98         . W !?10,"Clinic: ",$$GET1^DIQ(44,+$P(IBOE0,U,4)_",",.01)
    99         . Q
    100         ;
    101         I CTTYPE=3 D     ; prescription refill
    102         . N PSONTALK,PSOTMP,X
    103         . S PSONTALK=1
    104         . S X=+$P(IBTRED,U,8)_U_+$P(IBTRED,U,10) D EN^PSOCPVW
    105         . ;if refill was deleted and EN^PSOCPVW doesn't return any data use IB API
    106         . I '$D(PSOTMP) D PSOCPVW^IBNCPDPC(+$P(IBTRED,U,2),+$P(IBTRED,U,8),.PSOTMP)
    107         . W !?3,"Prescription#: ",$G(PSOTMP(52,+$P(IBTRED,U,8),.01,"E"))
    108         . I '$P(IBTRED,U,10) W !?7,"Fill Date: ",$$FMTE^XLFDT($P(IBTRED,U,6),"1P")
    109         . I $P(IBTRED,U,10) W !?5,"Refill Date: ",$$FMTE^XLFDT($P(IBTRED,U,6),"1P")
    110         . W !?12,"Drug: ",$G(PSOTMP(52,+$P(IBTRED,U,8),6,"E"))
    111         . Q
    112         ;
    113         I CTTYPE=4 D     ; prosthetic item
    114         . N IBDA,IBRMPR
    115         . S IBDA=$P(IBTRED,U,9)
    116         . D PRODATA^IBTUTL1(IBDA)
    117         . W !?3,"Delivery Date: ",$$FMTE^XLFDT($P(IBTRED,U,6),"1P")
    118         . W !?12,"Item: ",$G(IBRMPR(660,+IBDA,4,"E"))
    119         . W !?5,"Description: ",$G(IBRMPR(660,+IBDA,24,"E"))
    120         . Q
    121         ;
    122         I $G(IBMCSRNB)'="",$P(IBTRED,U,19) W !," Note:  A Reason Not Billable has been previously entered",!?8,"for this Claims Tracking record."
    123         I $G(IBMCSCAC)'="",$P(IBTRED1,U,8)'="" W !," Note:  An Additional Comment has been previously entered",!?8,"for this Claims Tracking record."
    124         ;
    125         S DA=IBTRE,DIE="^IBT(356,",DR=".19"
    126         I $G(IBMCSRNB)'="" S DR=".19//"_$P(IBMCSRNB,U,2)    ; IB*320 MCS cancel - reason not billable
    127         I $G(IBMCSCAC)'="" S DR=DR_";1.08//^S X=IBMCSCAC"   ; IB*377 MCS cancel - additional comment
    128         I $G(IBMCSCAC)="" S DR=DR_";1.08"                   ; IB*377 additional comment field SRS 3.3.2.1
    129         D ^DIE
    130         ;
    131         ; - if the RNB or additional comment changed, update the user and date/time last edited
    132         I $P(IBTRED,U,19)'=$P($G(^IBT(356,IBTRE,0)),U,19)!($P(IBTRED1,U,8)'=$P($G(^IBT(356,IBTRE,1)),U,8)) D NOW^%DTC S DR="1.03///"_%_";1.04////"_DUZ D ^DIE
    133         ;
    134         ; $D(Y) indicates an up-arrow exit from the DIE call (??)
    135         I $D(Y) S DFN=+$P(^IBT(356,IBTRE,0),"^",2) D FIND^IBOHCT(DFN,IBTRE) S IBQUIT=1
    136         Q
    137         ;
    138 TYPE(Z) ; function to get the type of claims tracking entry
    139         ; Z is the ien to file 356
    140         Q +$P($G(^IBE(356.6,+$P($G(^IBT(356,+Z,0)),U,18),0)),U,3)
    141         ;
     1IBCC1 ;ALB/MJB - CANCEL UB-82 THIRD PARTY BILL ;10-OCT-94
     2 ;;2.0;INTEGRATED BILLING;**19,95,160,159,320,347**;21-MAR-94;Build 24
     3 ;;Per VHA Directive 2004-038, this routine should not be modified.
     4 ;
     5RNB ; -- Add a reason not billable to claims tracking
     6 N X,Y,DIC,DIE,I,J,DA,DR,IBTYP,IBTRE,IB,IBAPPT,IBDT,IBTALK,IBCODE,IBTRED,IBTSAV,FILL,IBRX,IBDATA,IBD,IBDT,IBQUIT,IBPRO,IBDD
     7 Q:'$G(IBIFN)
     8 S IB(0)=$G(^DGCR(399,IBIFN,0)),IBTYP=$P(IB(0),"^",5),IBQUIT=0
     9 I '$D(DFN) S DFN=$P(IB(0),"^",2)
     10 ;
     11 ; -- is inpt find entry in dgpm, then in ibt(356, s da=ibtre then edit
     12INPT I IBTYP<3 D
     13 .S DATE=$P(IB(0),"^",3),DFN=$P(IB(0),"^",2)
     14 .S DGPM=$O(^DGPM("APTT1",DFN,DATE,0)) ; double check for asih
     15 .I DGPM S (IBTRE,IBTSAV)=$O(^IBT(356,"AD",DGPM,0))
     16 .I $G(IBTRE) D RNBEDIT
     17 .Q:IBQUIT
     18 .;
     19 .; -- alternate inpt method
     20 .S IBCODE=$O(^IBE(356.6,"ACODE",1,0))
     21 .S DATE=$P(IB(0),"^",3),DFN=$P(IB(0),"^",2)
     22 .S IBDT=(DATE-.25) F  S IBDT=$O(^IBT(356,"APTY",DFN,IBCODE,IBDT)) Q:'IBDT!(IBDT>(DATE+.24))  D
     23 ..S IBTRE=0 F  S IBTRE=$O(^IBT(356,"APTY",DFN,IBCODE,IBDT,IBTRE)) Q:IBTRE=""!(IBQUIT)  D:$G(IBTSAV)'=IBTRE RNBEDIT
     24 .Q
     25 ;
     26OPT ; -- is opt-find entries in IBT(356, for opt dates and then edit
     27 I IBTYP>2 S IBCODE=$O(^IBE(356.6,"ACODE",2,0)) D
     28 .S IBAPPT=0 F  S IBAPPT=$O(^DGCR(399,IBIFN,"OP",IBAPPT)) Q:'IBAPPT!(IBQUIT)  D
     29 ..S IBDT=(IBAPPT-.01) F  S IBDT=$O(^IBT(356,"APTY",DFN,IBCODE,IBDT)) Q:'IBDT!(IBDT>(IBAPPT+.24))  D
     30 ...S IBTRE=0 F  S IBTRE=$O(^IBT(356,"APTY",DFN,IBCODE,IBDT,IBTRE)) Q:IBTRE=""!(IBQUIT)  D RNBEDIT
     31 .Q
     32 ;
     33RX ; -- find rx's on bill
     34 S IBDD=0 F  S IBDD=$O(^IBA(362.4,"AIFN"_IBIFN,IBDD)) Q:'IBDD  S IBD=0 F  S IBD=$O(^IBA(362.4,"AIFN"_IBIFN,IBDD,IBD)) Q:'IBD!(IBQUIT)  D
     35 .S IBDATA=$G(^IBA(362.4,IBD,0)),IBRX=$P(IBDATA,"^",5),IBDT=$P(IBDATA,"^",3)
     36 .I '$G(IBRX) S DIC=52,DIC(0)="BO",X=$P(IBDATA,"^",1) D DIC^PSODI(52,.DIC,X) S IBRX=+Y K DIC,X,Y Q:IBRX=-1
     37 .S FILL="" F  S FILL=$O(^IBT(356,"ARXFL",IBRX,FILL)) Q:FILL=""!(IBQUIT)  D
     38 ..S IBTRE=0 F  S IBTRE=$O(^IBT(356,"ARXFL",IBRX,FILL,IBTRE)) Q:'IBTRE!(IBQUIT)  I $P(^IBT(356,+IBTRE,0),"^",6)=IBDT D RNBEDIT
     39 ;
     40PRO ; -- find prosthetics on bill
     41 S IBDD=0 F  S IBDD=$O(^IBA(362.5,"AIFN"_IBIFN,IBDD)) Q:'IBDD  S IBD=0 F  S IBD=$O(^IBA(362.5,"AIFN"_IBIFN,IBDD,IBD)) Q:'IBD!(IBQUIT)  D
     42 .S IBDATA=$G(^IBA(362.5,IBD,0)),IBPRO=$P(IBDATA,"^",4)
     43 .Q:'$G(IBPRO)
     44 .S IBTRE=0 F  S IBTRE=$O(^IBT(356,"APRO",+IBPRO,IBTRE)) Q:'IBTRE!(IBQUIT)  D RNBEDIT
     45 Q
     46 ;
     47RNBEDIT ;
     48 Q:IBQUIT
     49 W:'$D(IBTALK) !!,"Since you have canceled this bill, you may enter a Reason Not Billable",!,"into Claims Tracking.  This will take the care off of the UNBILLED lists"
     50 S IBTALK=1
     51 ;
     52 N %,IBTRED S IBTRED=$G(^IBT(356,IBTRE,0))
     53 W !!,"Claims Tracking entry: ",+IBTRED,"  ",$$EXPAND^IBTRE(356,.18,$P(IBTRED,"^",18)),"  ",$$FMTE^XLFDT($P(IBTRED,"^",6))
     54 I $G(IBMCSRNB)'="",$P(IBTRED,U,19) W !," Note:  A Reason Not Billable has been previously entered",!?8,"for this Claims Tracking record."
     55 S DA=IBTRE,DIE="^IBT(356,",DR=".19"
     56 I $G(IBMCSRNB)'="" S DR=".19//"_$P(IBMCSRNB,U,2)    ; IB*320 MCS cancel
     57 D ^DIE
     58 ;
     59 ; - if the RNB changed, update the user and date/time last edited
     60 I $P(IBTRED,"^",19)'=$P($G(^IBT(356,IBTRE,0)),"^",19) D NOW^%DTC S DR="1.03///"_%_";1.04////"_DUZ D ^DIE
     61 ;
     62 ; $D(Y) indicates an up-arrow exit from the DIE call (??)
     63 I $D(Y) S DFN=+$P(^IBT(356,IBTRE,0),"^",2) D FIND^IBOHCT(DFN,IBTRE) S IBQUIT=1
     64 Q

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCCC2.m

    r613 r623  
    1 IBCCC2  ;ALB/AAS - CANCEL AND CLONE A BILL - CONTINUED ;6/6/03 9:56am
    2         ;;2.0;INTEGRATED BILLING;**80,106,124,138,51,151,137,161,182,211,245,155,296,320,348,349,371**;21-MAR-94;Build 57
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5         ;MAP TO DGCRCC2
    6         ;
    7         ;STEP 5 - get remainder of data to move and store in MCCR then x-ref
    8         ;STEP 6 - go to screens, come out to IBB1 or something like that
    9         ;
    10 STEP5   S IBIFN1=$P(^DGCR(399,IBIFN,0),"^",15) G END:$S(IBIFN1="":1,'$D(^DGCR(399,IBIFN1,0)):1,1:0)
    11         ;
    12         ;move pure data nodes
    13         F I="I1","I2","I3","M1" I $D(^DGCR(399,IBIFN1,I)) S ^DGCR(399,IBIFN,I)=^DGCR(399,IBIFN1,I)
    14         ;
    15         ;move top level data node. ;Do not move 'TX' node
    16         F I="U","U1","U2","U3","UF2","UF3","UF31","C","M" I $D(^DGCR(399,IBIFN1,I)) S IBND(I)=^(I) D @I
    17         ;
    18         ;move multiple level data
    19         F I="CC","OC","OP","OT","RC","CP","CV","PRV" I $D(^DGCR(399,IBIFN1,I,0)) D @I
    20         ;
    21         D FTPRV^IBCEU5(IBIFN) ; Ask change prov type if form type not the same
    22         D COBCHG(IBIFN,,.IBCOB)
    23         ;
    24         D ^IBCCC3 ; copy table files (362.3)
    25         ;
    26         S I=$G(^DGCR(399,IBIFN1,0)) I $P(I,U,13)=7,$P(I,U,20)=1 D COPYB^IBCDC(IBIFN1,IBIFN) ; update auto bill files
    27         D PRIOR(IBIFN) ; add new bill to previous bills in series, primary/secondary
    28         I +$G(IBCTCOPY) N IBAUTO S IBAUTO=1 D PROC^IBCU7A(IBIFN),BILL^IBCRBC(IBIFN),CPTMOD26^IBCU73(IBIFN) D RECALL^DILFD(399,IBIFN_",",DUZ) G END
    29         ;
    30 STEP6   N IBGOEND
    31         I '$G(IBCE("EDI"))!$G(IBCE("EDI","NEW")),'$G(IBCEAUTO) D IBSCEDT G END:$G(IBGOEND)
    32         ;
    33         ;
    34 END     K DFN,IB,IBA,IBA2,IBAD,IBADD1,IBBNO,IBCAN,IBCCC,IBDA,IBDPT,IBDR,IBDT,IBI,IBI1,IBIDS,IBIFN,IBIFN1,IBND,IBQUIT,IBU,IBUN,IBARST,IBCOB,IBCNCOPY,IBCBCOPY
    35         K IBV,IBV1,IBW,IBWW,IBYN,IBZZ,PRCASV,PRCAERCD,PRCAERR,PRCASVC,PRCAT,IBBT,IBCH,IBNDS,IBOA,IBREV,IBX,DGXRF1,VAEL,VAERR,IBAC,IBCCC,IBDD1,IBIN,DGREV,DGREV00,DGREVHDR,IBCHK
    36         K IBBS,IBLS,DGPCM,IBIP,IBND0,IBNDU,IBO,IBPTF,IBST,IBUC,IBDD,D,%,%DT,DIC,VA,VADM,X,X1,X2,X3,X4,Y,I,J,K,DGRVRCAL,DDH,DGACTDT,DGAMNT,DGBR,DGBRN,DGBSI,DGBSLOS,IBA1,IBOD,IBINS,IBN,IBPROC,DGFUNC,DGIFN
    37         Q
    38         ;
    39         ;
    40 IBSCEDT ; call the IB bill edit screens and validate the data
    41         N IBV,IBPAR,IBAC,IBHV,IBH,IBCIREDT
    42         D RECALL^DILFD(399,IBIFN_",",DUZ)
    43 ST1     S IBV=0 D ^IBCSCU,^IBCSC1 I $G(IBPOPOUT) S IBGOEND=1 G IBSCX
    44         S IBAC=1
    45         D ^IBCB1
    46         I $G(IBCIREDT) G ST1
    47 IBSCX   ;
    48         Q
    49         ;
    50         ;
    51 U       F J=3,4,6:1:17,20 I $P(IBND("U"),"^",J)]"" S $P(^DGCR(399,IBIFN,"U"),"^",J)=$P(IBND("U"),"^",J)
    52         Q
    53 U1      F J=1:1:9,13,14 I $P(IBND("U1"),"^",J)]"" S $P(^DGCR(399,IBIFN,"U1"),"^",J)=$P(IBND("U1"),"^",J)
    54         Q
    55 U2      F J=1:1:19 I $P(IBND("U2"),"^",J)]"" S $P(^DGCR(399,IBIFN,"U2"),"^",J)=$P(IBND("U2"),"^",J)
    56         Q
    57 U3      F J=1:1:7 I $P(IBND("U3"),"^",J)]"" S $P(^DGCR(399,IBIFN,"U3"),"^",J)=$P(IBND("U3"),"^",J)
    58         Q
    59 UF2     F J=1,3 I $P(IBND("UF2"),"^",J)]"" S $P(^DGCR(399,IBIFN,"UF2"),"^",J)=$P(IBND("UF2"),"^",J)
    60         Q
    61 UF3     F J=1:1:7 I $P(IBND("UF3"),"^",J)]"" S $P(^DGCR(399,IBIFN,"UF3"),"^",J)=$P(IBND("UF3"),"^",J)
    62         Q
    63 UF31    F J=1:1:3 I $P(IBND("UF31"),"^",J)]"" S $P(^DGCR(399,IBIFN,"UF31"),"^",J)=$P(IBND("UF31"),"^",J)
    64         Q
    65 C       F J=10 I $P(IBND("C"),"^",J)]"" S $P(^DGCR(399,IBIFN,"C"),"^",J)=$P(IBND("C"),"^",J)
    66         I '$D(^DGCR(399,IBIFN1,"CP")) D CP1
    67         Q
    68 M       F J=1:1:14 I $P(IBND("M"),"^",J)]"" S $P(^DGCR(399,IBIFN,"M"),"^",J)=$P(IBND("M"),"^",J)
    69         Q
    70 CC      S ^DGCR(399,IBIFN,I,0)=^DGCR(399,IBIFN1,I,0)
    71         S IBDD=399.04 F J=0:0 S J=$O(^DGCR(399,IBIFN1,I,J)) Q:'J  I $D(^(J,0)) S ^DGCR(399,IBIFN,I,J,0)=^DGCR(399,IBIFN1,I,J,0),X=$P(^(0),"^")
    72 OP      S ^DGCR(399,IBIFN,I,0)=^DGCR(399,IBIFN1,I,0)
    73         S IBDD=399.043 F J=0:0 S J=$O(^DGCR(399,IBIFN1,I,J)) Q:'J  I $D(^(J,0)) S ^DGCR(399,IBIFN,I,J,0)=^DGCR(399,IBIFN1,I,J,0),X=$P(^(0),"^")
    74         Q
    75 OC      S ^DGCR(399,IBIFN,I,0)=^DGCR(399,IBIFN1,I,0)
    76         S IBDD=399.041 F J=0:0 S J=$O(^DGCR(399,IBIFN1,I,J)) Q:'J  I $D(^(J,0)) S ^DGCR(399,IBIFN,I,J,0)=^DGCR(399,IBIFN1,I,J,0),X=$P(^(0),"^")
    77         Q
    78 OT      S ^DGCR(399,IBIFN,I,0)=^DGCR(399,IBIFN1,I,0)
    79         S IBDD=399.048 F J=0:0 S J=$O(^DGCR(399,IBIFN1,I,J)) Q:'J  I $D(^(J,0)) S ^DGCR(399,IBIFN,I,J,0)=^DGCR(399,IBIFN1,I,J,0),X=$P(^(0),"^")
    80         Q
    81 CV      ; Don't copy value codes from inpatient inst to inpatient prof bills
    82         I $$FT^IBCEF(IBIFN1)'=2,$$FT^IBCEF(IBIFN)=2 Q
    83         S ^DGCR(399,IBIFN,I,0)=^DGCR(399,IBIFN1,I,0)
    84         S IBDD=399.047 F J=0:0 S J=$O(^DGCR(399,IBIFN1,I,J)) Q:'J  I $D(^(J,0)) S ^DGCR(399,IBIFN,I,J,0)=^DGCR(399,IBIFN1,I,J,0),X=$P(^(0),"^")
    85         Q
    86 RC      S ^DGCR(399,IBIFN,I,0)=^DGCR(399,IBIFN1,I,0)
    87         S IBDD=399.042 F J=0:0 S J=$O(^DGCR(399,IBIFN1,I,J)) Q:'J  I $D(^(J,0)) S IBND("RC")=^(0) F K=1:1:15 S $P(^DGCR(399,IBIFN,I,J,0),"^",K)=$P(IBND("RC"),"^",K),X=$P(IBND("RC"),"^",K)
    88         Q
    89 CP      S ^DGCR(399,IBIFN,I,0)=^DGCR(399,IBIFN1,I,0)
    90         I +$G(IBNOCPT) Q
    91         S IBDD=399.0304 F J=0:0 S J=$O(^DGCR(399,IBIFN1,I,J)) Q:'J  I $D(^(J,0)) S IBND("CP")=^(0),IBND("CP-AUX")=$G(^("AUX")) D
    92         . F K=1:1:7,9:1:14,16:1:22 S $P(^DGCR(399,IBIFN,I,J,0),"^",K)=$P(IBND("CP"),"^",K)
    93         . ; esg - 11/2/06 - IB*2*348 - 50.09 field was added - AUX piece [9]
    94         . I IBND("CP-AUX")'="" F K=1:1:9 S $P(^DGCR(399,IBIFN,I,J,"AUX"),"^",K)=$P(IBND("CP-AUX"),"^",K)
    95         . I $D(^DGCR(399,IBIFN1,I,J,"MOD",0)) S ^DGCR(399,IBIFN,I,J,"MOD",0)=^DGCR(399,IBIFN1,I,J,"MOD",0) D
    96         .. S K=0 F  S K=$O(^DGCR(399,IBIFN1,I,J,"MOD",K)) Q:'K  D
    97         ... I $G(IBNOTC),$P($$MOD^ICPTMOD(+$P($G(^DGCR(399,IBIFN1,I,J,"MOD",K,0)),U,2),"I"),U,2)="TC" Q  ; Don't copy TC modifier from inst to prof bill
    98         ... S ^DGCR(399,IBIFN,I,J,"MOD",K,0)=^DGCR(399,IBIFN1,I,J,"MOD",K,0)
    99 CP1     S IBCOD=$P($G(^DGCR(399,IBIFN,0)),"^",9) Q:IBCOD=""!('$D(^DGCR(399,IBIFN1,"C")))
    100         I IBCOD=9 F DGI=4,5,6 I $P(^DGCR(399,IBIFN1,"C"),"^",DGI) S X=$P(^("C"),"^",DGI)_";ICD0(",DGPROCDT=$P(^("C"),"^",DGI+7) D FILE
    101         I IBCOD=4 F DGI=1,2,3 I $P(^DGCR(399,IBIFN1,"C"),"^",DGI) S X=$P(^("C"),"^",DGI)_";ICPT(",DGPROCDT=$P(^("C"),"^",DGI+10) D FILE
    102         I IBCOD=5 F DGI=7,8,9 I $P(^DGCR(399,IBIFN1,"C"),"^",DGI) S X=$P(^("C"),"^",DGI)_";ICPT(",DGPROCDT=$P(^("C"),"^",DGI+4) D FILE
    103         Q
    104         ;
    105 PRV     S ^DGCR(399,IBIFN,I,0)=^DGCR(399,IBIFN1,I,0)
    106         N Z,Z0
    107         S Z=$P($G(^DGCR(399,IBIFN,0)),U,19),Z0=$P($G(^DGCR(399,IBIFN1,0)),U,19)
    108         S IBDD=399.0222 F J=0:0 S J=$O(^DGCR(399,IBIFN1,I,J)) Q:'J  I $D(^(J,0)) D
    109         . S ^DGCR(399,IBIFN,I,J,0)=^DGCR(399,IBIFN1,I,J,0),X=$P(^(0),"^")
    110         . I Z'=Z0,$S(X=3:Z0=3,X=4:Z0=2,1:0) S $P(^DGCR(399,IBIFN,I,J,0),U)=(Z0+1)
    111         Q
    112         ;
    113 COB     S J=0 F  S J=$O(IBCOB(I,J)) Q:'J  S $P(^DGCR(399,IBIFN,I),U,J)=IBCOB(I,J)
    114         Q
    115         ;
    116 FILE    N DIC,DIE,DR,DA,X,Y,DLAYGO,DD,DO
    117         I '$D(^DGCR(399,IBIFN,"CP",0)) S DIC("P")=$$GETSPEC^IBEFUNC(399,304)
    118         S DIC(0)="L",DLAYGO=399,DA(1)=IBIFN,DIC="^DGCR(399,"_DA(1)_",""CP""," Q:X=""  D FILE^DICN K DO,DD Q:+Y<1  S DA=+Y
    119         S DIE="^DGCR(399,"_DA(1)_",""CP"",",DR="1///"_DGPROCDT D ^DIE
    120         K DGPROCDT
    121         Q
    122         ;
    123 INDEX   ;index entire file (set logic)
    124         S DIK="^DGCR(399,",DA=IBIFN D IX1^DIK K DA,DIK
    125         Q
    126         ;
    127 PRIOR(IBIFN)    ; set Secondary/Tertiary Bill #s on prior bills, if the bill is cancelled remove it from prior bills
    128         N IBSEQ,IBSEQN,IBM1,I,IBIFN1
    129         S IBSEQ=$$COB^IBCEF(IBIFN)
    130         S IBSEQN=$S(IBSEQ="S":6,IBSEQ="T":7,1:"") Q:'IBSEQN
    131         ;
    132         S IBM1=$G(^DGCR(399,IBIFN,"M1")) I +$P(^DGCR(399,IBIFN,0),U,13)=7 S IBIFN=""
    133         F I=5,6 I I<IBSEQN  S IBIFN1=+$P(IBM1,U,I) I +IBIFN1,$D(^DGCR(399,+IBIFN1,0)) S $P(^DGCR(399,IBIFN1,"M1"),U,IBSEQN)=IBIFN
    134         Q
    135         ;
    136 COBCHG(IBIFN,IBINS,IBCOB)       ; Make changes for a new COB payer for bill
    137         ; IBIFN = ien of bill in file 399
    138         ; IBINS = ien of bill's current insurance (optional)
    139         ; IBCOB = array subscripted by node,piece of COB data field change
    140         ;
    141         N I,IBFRMTYP,IBTAXLST
    142         ; Subtract the Prior Payments from the bill's Offset (these are re-added by triggers)
    143         F I=4,5,6  S $P(^DGCR(399,IBIFN,"U1"),U,2)=$P($G(^DGCR(399,IBIFN,"U1")),U,2)-$P($G(^DGCR(399,IBIFN,"U2")),U,I)
    144         ;
    145         I $G(IBINS),$$MCRWNR^IBEFUNC(IBINS) D
    146         . ;MCRWNR is current insurance ... move payer only
    147         . N IBCOBN,IBX
    148         . S IBCOBN=$$COBN^IBCEF(IBIFN)
    149         . S IBCOB(0,21)=$P("S^T^",U,IBCOBN)
    150         . S IBCOB("M1",IBCOBN+4)=IBIFN
    151         . S IBCOB("TX",1)="",IBCOB("TX",2)=""
    152         . S IBX=$$REQMRA^IBEFUNC(IBIFN)
    153         . I IBX=0 S IBCOB("TX",5)=0                         ; MRA not needed
    154         . I IBX["R" S IBCOB("TX",5)="A"                     ; MRA skipped
    155         . I IBX=1,$$CHK^IBCEMU1(IBIFN) S IBCOB("TX",5)="C"  ; MRA on file
    156         . I $G(IBPRCOB) S IBCOB("TX",5)="C"                 ; MRA being proc'd
    157         . D PRIOR(IBIFN)
    158         . Q
    159         ;
    160         ;reset fields for next Sequence Payer
    161         F I=0,"M1","U2","TX" I $D(IBCOB(I)) D COB
    162         ;
    163         ; IB*2.0*211
    164         ; save off Form Type
    165         S IBFRMTYP=$P($G(^DGCR(399,IBIFN,0)),U,19)
    166         ; Save off Taxonomies for providers.
    167         S I=0 F  S I=$O(^DGCR(399,IBIFN,"PRV",I)) Q:'I  S IBTAXLST(I)=$P($G(^DGCR(399,IBIFN,"PRV",I,0)),U,15)
    168         ;
    169         ; fire xrefs set logic
    170         D INDEX
    171         ;
    172         ; Restore Form Type if changed, but don't restore Form Type if
    173         ;   creating CMS-1500 claim from CTCOPY1^IBCCCB
    174         I $G(IBCTCOPY)'=1,IBFRMTYP'=$P($G(^DGCR(399,IBIFN,0)),U,19) N DA,DIE,DR S DA=IBIFN,DIE="^DGCR(399,",DR=".19////"_IBFRMTYP D ^DIE
    175         ;
    176         ; Restore Claim MRA Status field since triggers in fields 101 & 102
    177         ;   will overwrite the correct value when processing the MRA/EOB.
    178         ; If we're processing the MRA/EOB, then a valid MRA has been received.
    179         I $G(IBPRCOB) N DA,DIE,DR S DA=IBIFN,DIE="^DGCR(399,",DR="24////C" D ^DIE
    180         ;
    181         ; Restore Taxonomies in fields 243 and 244.
    182         S I=$P($G(IBND("U3")),U,2)
    183         I I'=$P($G(^DGCR(399,IBIFN,"U3")),U,2) D
    184         . N DA,DIE,DR S DA=IBIFN,DIE="^DGCR(399,",DR="243////"_$S(I'="":I,1:"@") D ^DIE
    185         S I=$P($G(IBND("U3")),U,3)
    186         I I'=$P($G(^DGCR(399,IBIFN,"U3")),U,3) D
    187         . N DA,DIE,DR S DA=IBIFN,DIE="^DGCR(399,",DR="244////"_$S(I'="":I,1:"@") D ^DIE
    188         ; Restore Taxonomies in field .15 in sub-file 399.0222.
    189         S IBTAXLST=0 F  S IBTAXLST=$O(IBTAXLST(IBTAXLST)) Q:'IBTAXLST  D
    190         . S I=IBTAXLST(IBTAXLST)
    191         . I I=$P($G(^DGCR(399,IBIFN,"PRV",IBTAXLST,0)),U,15) Q  ; No change
    192         . N DA,DIE,DR
    193         . S DA(1)=IBIFN,DA=IBTAXLST
    194         . S DIE="^DGCR(399,"_DA(1)_",""PRV"",",DR=".15////"_$S(I'="":I,1:"@")
    195         . D ^DIE
    196         . Q
    197         ;
    198         K IBCOB("TX")
    199         Q
    200         ;
     1IBCCC2 ;ALB/AAS - CANCEL AND CLONE A BILL - CONTINUED ;6/6/03 9:56am
     2 ;;2.0;INTEGRATED BILLING;**80,106,124,138,51,151,137,161,182,211,245,155,296,320,348,349**;21-MAR-94;Build 46
     3 ;;Per VHA Directive 2004-038, this routine should not be modified.
     4 ;
     5 ;MAP TO DGCRCC2
     6 ;
     7 ;STEP 5 - get remainder of data to move and store in MCCR then x-ref
     8 ;STEP 6 - go to screens, come out to IBB1 or something like that
     9 ;
     10STEP5 S IBIFN1=$P(^DGCR(399,IBIFN,0),"^",15) G END:$S(IBIFN1="":1,'$D(^DGCR(399,IBIFN1,0)):1,1:0)
     11 ;
     12 ;move pure data nodes
     13 F I="I1","I2","I3","M1" I $D(^DGCR(399,IBIFN1,I)) S ^DGCR(399,IBIFN,I)=^DGCR(399,IBIFN1,I)
     14 ;
     15 ;move top level data node. ;Do not move 'TX' node
     16 F I="U","U1","U2","U3","UF2","UF3","UF31","C","M" I $D(^DGCR(399,IBIFN1,I)) S IBND(I)=^(I) D @I
     17 ;
     18 ;move multiple level data
     19 F I="CC","OC","OP","OT","RC","CP","CV","PRV" I $D(^DGCR(399,IBIFN1,I,0)) D @I
     20 ;
     21 D FTPRV^IBCEU5(IBIFN) ; Ask change prov type if form type not the same
     22 D COBCHG(IBIFN,,.IBCOB)
     23 ;
     24 D ^IBCCC3 ; copy table files (362.3)
     25 ;
     26 S I=$G(^DGCR(399,IBIFN1,0)) I $P(I,U,13)=7,$P(I,U,20)=1 D COPYB^IBCDC(IBIFN1,IBIFN) ; update auto bill files
     27 D PRIOR(IBIFN) ; add new bill to previous bills in series, primary/secondary
     28 I +$G(IBCTCOPY) N IBAUTO S IBAUTO=1 D PROC^IBCU7A(IBIFN),BILL^IBCRBC(IBIFN),CPTMOD26^IBCU73(IBIFN) D RECALL^DILFD(399,IBIFN_",",DUZ) G END
     29 ;
     30STEP6 N IBGOEND
     31 I '$G(IBCE("EDI"))!$G(IBCE("EDI","NEW")),'$G(IBCEAUTO) D IBSCEDT G END:$G(IBGOEND)
     32 ;
     33 ;
     34END K DFN,IB,IBA,IBA2,IBAD,IBADD1,IBBNO,IBCAN,IBCCC,IBDA,IBDPT,IBDR,IBDT,IBI,IBI1,IBIDS,IBIFN,IBIFN1,IBND,IBQUIT,IBU,IBUN,IBARST,IBCOB,IBCNCOPY,IBCBCOPY
     35 K IBV,IBV1,IBW,IBWW,IBYN,IBZZ,PRCASV,PRCAERCD,PRCAERR,PRCASVC,PRCAT,IBBT,IBCH,IBNDS,IBOA,IBREV,IBX,DGXRF1,VAEL,VAERR,IBAC,IBCCC,IBDD1,IBIN,DGREV,DGREV00,DGREVHDR,IBCHK
     36 K IBBS,IBLS,DGPCM,IBIP,IBND0,IBNDU,IBO,IBPTF,IBST,IBUC,IBDD,D,%,%DT,DIC,VA,VADM,X,X1,X2,X3,X4,Y,I,J,K,DGRVRCAL,DDH,DGACTDT,DGAMNT,DGBR,DGBRN,DGBSI,DGBSLOS,IBA1,IBOD,IBINS,IBN,IBPROC,DGFUNC,DGIFN
     37 Q
     38 ;
     39 ;
     40IBSCEDT ; call the IB bill edit screens and validate the data
     41 N IBV,IBPAR,IBAC,IBHV,IBH,IBCIREDT
     42 D RECALL^DILFD(399,IBIFN_",",DUZ)
     43ST1 S IBV=0 D ^IBCSCU,^IBCSC1 I $G(IBPOPOUT) S IBGOEND=1 G IBSCX
     44 S IBAC=1
     45 D ^IBCB1
     46 I $G(IBCIREDT) G ST1
     47IBSCX ;
     48 Q
     49 ;
     50 ;
     51U F J=3,4,6:1:17,20 I $P(IBND("U"),"^",J)]"" S $P(^DGCR(399,IBIFN,"U"),"^",J)=$P(IBND("U"),"^",J)
     52 Q
     53U1 F J=1:1:9,13,14 I $P(IBND("U1"),"^",J)]"" S $P(^DGCR(399,IBIFN,"U1"),"^",J)=$P(IBND("U1"),"^",J)
     54 Q
     55U2 F J=1:1:19 I $P(IBND("U2"),"^",J)]"" S $P(^DGCR(399,IBIFN,"U2"),"^",J)=$P(IBND("U2"),"^",J)
     56 Q
     57U3 F J=1:1:3 I $P(IBND("U3"),"^",J)]"" S $P(^DGCR(399,IBIFN,"U3"),"^",J)=$P(IBND("U3"),"^",J)
     58 Q
     59UF2 F J=1,3 I $P(IBND("UF2"),"^",J)]"" S $P(^DGCR(399,IBIFN,"UF2"),"^",J)=$P(IBND("UF2"),"^",J)
     60 Q
     61UF3 F J=1:1:7 I $P(IBND("UF3"),"^",J)]"" S $P(^DGCR(399,IBIFN,"UF3"),"^",J)=$P(IBND("UF3"),"^",J)
     62 Q
     63UF31 F J=1:1:3 I $P(IBND("UF31"),"^",J)]"" S $P(^DGCR(399,IBIFN,"UF31"),"^",J)=$P(IBND("UF31"),"^",J)
     64 Q
     65C F J=10 I $P(IBND("C"),"^",J)]"" S $P(^DGCR(399,IBIFN,"C"),"^",J)=$P(IBND("C"),"^",J)
     66 I '$D(^DGCR(399,IBIFN1,"CP")) D CP1
     67 Q
     68M F J=1:1:14 I $P(IBND("M"),"^",J)]"" S $P(^DGCR(399,IBIFN,"M"),"^",J)=$P(IBND("M"),"^",J)
     69 Q
     70CC S ^DGCR(399,IBIFN,I,0)=^DGCR(399,IBIFN1,I,0)
     71 S IBDD=399.04 F J=0:0 S J=$O(^DGCR(399,IBIFN1,I,J)) Q:'J  I $D(^(J,0)) S ^DGCR(399,IBIFN,I,J,0)=^DGCR(399,IBIFN1,I,J,0),X=$P(^(0),"^")
     72OP S ^DGCR(399,IBIFN,I,0)=^DGCR(399,IBIFN1,I,0)
     73 S IBDD=399.043 F J=0:0 S J=$O(^DGCR(399,IBIFN1,I,J)) Q:'J  I $D(^(J,0)) S ^DGCR(399,IBIFN,I,J,0)=^DGCR(399,IBIFN1,I,J,0),X=$P(^(0),"^")
     74 Q
     75OC S ^DGCR(399,IBIFN,I,0)=^DGCR(399,IBIFN1,I,0)
     76 S IBDD=399.041 F J=0:0 S J=$O(^DGCR(399,IBIFN1,I,J)) Q:'J  I $D(^(J,0)) S ^DGCR(399,IBIFN,I,J,0)=^DGCR(399,IBIFN1,I,J,0),X=$P(^(0),"^")
     77 Q
     78OT S ^DGCR(399,IBIFN,I,0)=^DGCR(399,IBIFN1,I,0)
     79 S IBDD=399.048 F J=0:0 S J=$O(^DGCR(399,IBIFN1,I,J)) Q:'J  I $D(^(J,0)) S ^DGCR(399,IBIFN,I,J,0)=^DGCR(399,IBIFN1,I,J,0),X=$P(^(0),"^")
     80 Q
     81CV ; Don't copy value codes from inpatient inst to inpatient prof bills
     82 I $$FT^IBCEF(IBIFN1)'=2,$$FT^IBCEF(IBIFN)=2 Q
     83 S ^DGCR(399,IBIFN,I,0)=^DGCR(399,IBIFN1,I,0)
     84 S IBDD=399.047 F J=0:0 S J=$O(^DGCR(399,IBIFN1,I,J)) Q:'J  I $D(^(J,0)) S ^DGCR(399,IBIFN,I,J,0)=^DGCR(399,IBIFN1,I,J,0),X=$P(^(0),"^")
     85 Q
     86RC S ^DGCR(399,IBIFN,I,0)=^DGCR(399,IBIFN1,I,0)
     87 S IBDD=399.042 F J=0:0 S J=$O(^DGCR(399,IBIFN1,I,J)) Q:'J  I $D(^(J,0)) S IBND("RC")=^(0) F K=1:1:15 S $P(^DGCR(399,IBIFN,I,J,0),"^",K)=$P(IBND("RC"),"^",K),X=$P(IBND("RC"),"^",K)
     88 Q
     89CP S ^DGCR(399,IBIFN,I,0)=^DGCR(399,IBIFN1,I,0)
     90 I +$G(IBNOCPT) Q
     91 S IBDD=399.0304 F J=0:0 S J=$O(^DGCR(399,IBIFN1,I,J)) Q:'J  I $D(^(J,0)) S IBND("CP")=^(0),IBND("CP-AUX")=$G(^("AUX")) D
     92 . F K=1:1:7,9:1:14,16:1:22 S $P(^DGCR(399,IBIFN,I,J,0),"^",K)=$P(IBND("CP"),"^",K)
     93 . ; esg - 11/2/06 - IB*2*348 - 50.09 field was added - AUX piece [9]
     94 . I IBND("CP-AUX")'="" F K=1:1:9 S $P(^DGCR(399,IBIFN,I,J,"AUX"),"^",K)=$P(IBND("CP-AUX"),"^",K)
     95 . I $D(^DGCR(399,IBIFN1,I,J,"MOD",0)) S ^DGCR(399,IBIFN,I,J,"MOD",0)=^DGCR(399,IBIFN1,I,J,"MOD",0) D
     96 .. S K=0 F  S K=$O(^DGCR(399,IBIFN1,I,J,"MOD",K)) Q:'K  D
     97 ... I $G(IBNOTC),$P($$MOD^ICPTMOD(+$P($G(^DGCR(399,IBIFN1,I,J,"MOD",K,0)),U,2),"I"),U,2)="TC" Q  ; Don't copy TC modifier from inst to prof bill
     98 ... S ^DGCR(399,IBIFN,I,J,"MOD",K,0)=^DGCR(399,IBIFN1,I,J,"MOD",K,0)
     99CP1 S IBCOD=$P($G(^DGCR(399,IBIFN,0)),"^",9) Q:IBCOD=""!('$D(^DGCR(399,IBIFN1,"C")))
     100 I IBCOD=9 F DGI=4,5,6 I $P(^DGCR(399,IBIFN1,"C"),"^",DGI) S X=$P(^("C"),"^",DGI)_";ICD0(",DGPROCDT=$P(^("C"),"^",DGI+7) D FILE
     101 I IBCOD=4 F DGI=1,2,3 I $P(^DGCR(399,IBIFN1,"C"),"^",DGI) S X=$P(^("C"),"^",DGI)_";ICPT(",DGPROCDT=$P(^("C"),"^",DGI+10) D FILE
     102 I IBCOD=5 F DGI=7,8,9 I $P(^DGCR(399,IBIFN1,"C"),"^",DGI) S X=$P(^("C"),"^",DGI)_";ICPT(",DGPROCDT=$P(^("C"),"^",DGI+4) D FILE
     103 Q
     104 ;
     105PRV S ^DGCR(399,IBIFN,I,0)=^DGCR(399,IBIFN1,I,0)
     106 N Z,Z0
     107 S Z=$P($G(^DGCR(399,IBIFN,0)),U,19),Z0=$P($G(^DGCR(399,IBIFN1,0)),U,19)
     108 S IBDD=399.0222 F J=0:0 S J=$O(^DGCR(399,IBIFN1,I,J)) Q:'J  I $D(^(J,0)) D
     109 . S ^DGCR(399,IBIFN,I,J,0)=^DGCR(399,IBIFN1,I,J,0),X=$P(^(0),"^")
     110 . I Z'=Z0,$S(X=3:Z0=3,X=4:Z0=2,1:0) S $P(^DGCR(399,IBIFN,I,J,0),U)=(Z0+1)
     111 Q
     112 ;
     113COB S J=0 F  S J=$O(IBCOB(I,J)) Q:'J  S $P(^DGCR(399,IBIFN,I),U,J)=IBCOB(I,J)
     114 Q
     115 ;
     116FILE N DIC,DIE,DR,DA,X,Y,DLAYGO,DD,DO
     117 I '$D(^DGCR(399,IBIFN,"CP",0)) S DIC("P")=$$GETSPEC^IBEFUNC(399,304)
     118 S DIC(0)="L",DLAYGO=399,DA(1)=IBIFN,DIC="^DGCR(399,"_DA(1)_",""CP""," Q:X=""  D FILE^DICN K DO,DD Q:+Y<1  S DA=+Y
     119 S DIE="^DGCR(399,"_DA(1)_",""CP"",",DR="1///"_DGPROCDT D ^DIE
     120 K DGPROCDT
     121 Q
     122 ;
     123INDEX ;index entire file (set logic)
     124 S DIK="^DGCR(399,",DA=IBIFN D IX1^DIK K DA,DIK
     125 Q
     126 ;
     127PRIOR(IBIFN) ; set Secondary/Tertiary Bill #s on prior bills, if the bill is cancelled remove it from prior bills
     128 N IBSEQ,IBSEQN,IBM1,I,IBIFN1
     129 S IBSEQ=$$COB^IBCEF(IBIFN)
     130 S IBSEQN=$S(IBSEQ="S":6,IBSEQ="T":7,1:"") Q:'IBSEQN
     131 ;
     132 S IBM1=$G(^DGCR(399,IBIFN,"M1")) I +$P(^DGCR(399,IBIFN,0),U,13)=7 S IBIFN=""
     133 F I=5,6 I I<IBSEQN  S IBIFN1=+$P(IBM1,U,I) I +IBIFN1,$D(^DGCR(399,+IBIFN1,0)) S $P(^DGCR(399,IBIFN1,"M1"),U,IBSEQN)=IBIFN
     134 Q
     135 ;
     136COBCHG(IBIFN,IBINS,IBCOB) ; Make changes for a new COB payer for bill
     137 ; IBIFN = ien of bill in file 399
     138 ; IBINS = ien of bill's current insurance (optional)
     139 ; IBCOB = array subscripted by node,piece of COB data field change
     140 ;
     141 N I,IBFRMTYP,IBTAXLST
     142 ; Subtract the Prior Payments from the bill's Offset (these are re-added by triggers)
     143 F I=4,5,6  S $P(^DGCR(399,IBIFN,"U1"),U,2)=$P($G(^DGCR(399,IBIFN,"U1")),U,2)-$P($G(^DGCR(399,IBIFN,"U2")),U,I)
     144 ;
     145 I $G(IBINS),$$MCRWNR^IBEFUNC(IBINS) D
     146 . ;MCRWNR is current insurance ... move payer only
     147 . N IBCOBN,IBX
     148 . S IBCOBN=$$COBN^IBCEF(IBIFN)
     149 . S IBCOB(0,21)=$P("S^T^",U,IBCOBN)
     150 . S IBCOB("M1",IBCOBN+4)=IBIFN
     151 . S IBCOB("TX",1)="",IBCOB("TX",2)=""
     152 . S IBX=$$REQMRA^IBEFUNC(IBIFN)
     153 . I IBX=0 S IBCOB("TX",5)=0                         ; MRA not needed
     154 . I IBX["R" S IBCOB("TX",5)="A"                     ; MRA skipped
     155 . I IBX=1,$$CHK^IBCEMU1(IBIFN) S IBCOB("TX",5)="C"  ; MRA on file
     156 . I $G(IBPRCOB) S IBCOB("TX",5)="C"                 ; MRA being proc'd
     157 . D PRIOR(IBIFN)
     158 . Q
     159 ;
     160 ;reset fields for next Sequence Payer
     161 F I=0,"M1","U2","TX" I $D(IBCOB(I)) D COB
     162 ;
     163 ; IB*2.0*211
     164 ; save off Form Type
     165 S IBFRMTYP=$P($G(^DGCR(399,IBIFN,0)),U,19)
     166 ; Save off Taxonomies for providers.
     167 S I=0 F  S I=$O(^DGCR(399,IBIFN,"PRV",I)) Q:'I  S IBTAXLST(I)=$P($G(^DGCR(399,IBIFN,"PRV",I,0)),U,15)
     168 ;
     169 ; fire xrefs set logic
     170 D INDEX
     171 ;
     172 ; Restore Form Type if changed, but don't restore Form Type if
     173 ;   creating CMS-1500 claim from CTCOPY1^IBCCCB
     174 I $G(IBCTCOPY)'=1,IBFRMTYP'=$P($G(^DGCR(399,IBIFN,0)),U,19) N DA,DIE,DR S DA=IBIFN,DIE="^DGCR(399,",DR=".19////"_IBFRMTYP D ^DIE
     175 ;
     176 ; Restore Claim MRA Status field since triggers in fields 101 & 102
     177 ;   will overwrite the correct value when processing the MRA/EOB.
     178 ; If we're processing the MRA/EOB, then a valid MRA has been received.
     179 I $G(IBPRCOB) N DA,DIE,DR S DA=IBIFN,DIE="^DGCR(399,",DR="24////C" D ^DIE
     180 ;
     181 ; Restore Taxonomies in fields 243 and 244.
     182 S I=$P($G(IBND("U3")),U,2)
     183 I I'=$P($G(^DGCR(399,IBIFN,"U3")),U,2) D
     184 . N DA,DIE,DR S DA=IBIFN,DIE="^DGCR(399,",DR="243////"_$S(I'="":I,1:"@") D ^DIE
     185 S I=$P($G(IBND("U3")),U,3)
     186 I I'=$P($G(^DGCR(399,IBIFN,"U3")),U,3) D
     187 . N DA,DIE,DR S DA=IBIFN,DIE="^DGCR(399,",DR="244////"_$S(I'="":I,1:"@") D ^DIE
     188 ; Restore Taxonomies in field .15 in sub-file 399.0222.
     189 S IBTAXLST=0 F  S IBTAXLST=$O(IBTAXLST(IBTAXLST)) Q:'IBTAXLST  D
     190 . S I=IBTAXLST(IBTAXLST)
     191 . I I=$P($G(^DGCR(399,IBIFN,"PRV",IBTAXLST,0)),U,15) Q  ; No change
     192 . N DA,DIE,DR
     193 . S DA(1)=IBIFN,DA=IBTAXLST
     194 . S DIE="^DGCR(399,"_DA(1)_",""PRV"",",DR=".15////"_$S(I'="":I,1:"@")
     195 . D ^DIE
     196 . Q
     197 ;
     198 K IBCOB("TX")
     199 Q
     200 ;

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCCC3.m

    r613 r623  
    1 IBCCC3  ;ALB/AAS - CANCEL AND CLONE A BILL - CONTINUED ;25-JAN-90
    2         ;;2.0;INTEGRATED BILLING;**363,381,389**;21-MAR-94;Build 6
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5         ;copy entries from table files:
    6         ;passed in: IBIFN=new bill, IBIFN1=old bill
    7         ;
    8         I '$D(^DGCR(399,+$G(IBIFN),0))!'$D(^DGCR(399,+$G(IBIFN1),0)) Q
    9         N IBXR,X,Y,IBX
    10         ;
    11 DX      ;copy diagnosis' (362.3)
    12         N IBDX,IBDIFN
    13         ;copy diagnosis from old bill
    14         I $D(^IBA(362.3,"AIFN"_IBIFN1)) S IBXR="AIFN"_IBIFN1 D
    15         . S IBDX=0 F  S IBDX=$O(^IBA(362.3,IBXR,IBDX)) Q:'IBDX  D
    16         .. S IBDIFN=0 F  S IBDIFN=$O(^IBA(362.3,IBXR,IBDX,IBDIFN)) Q:'IBDIFN  D
    17         ... S IBX=$G(^IBA(362.3,IBDIFN,0)) I 'IBX!($P(IBX,U,2)'=IBIFN1) Q
    18         ... S DIC="^IBA(362.3,",DIC(0)="L",X=+IBX K DA,DO D FILE^DICN
    19         ... S DIE=DIC,DA=+Y,DR=".02////"_IBIFN_";.03////"_$P(IBX,U,3) D ^DIE K DIC,DIE,DA,DO,DR
    20         K DIE,DIC,DA,DO,DR,X,Y
    21         ;
    22 PRDX    ;repoint procedure's associated diagnosis (2,304,10-13 -> 362.3)
    23         N IBCPT,IBDIFN1,IBLN,IBI
    24         S IBCPT=0 F  S IBCPT=$O(^DGCR(399,+IBIFN,"CP",IBCPT)) Q:'IBCPT  D
    25         . S IBLN=$G(^DGCR(399,+IBIFN,"CP",IBCPT,0)) F IBI=11:1:14 S IBDIFN1=$P(IBLN,U,IBI) I +IBDIFN1 D
    26         .. S IBDX=+$G(^IBA(362.3,+IBDIFN1,0)) Q:'IBDX
    27         .. S IBDIFN=$O(^IBA(362.3,"AIFN"_IBIFN,IBDX,0)) Q:'IBDIFN
    28         .. S $P(^DGCR(399,+IBIFN,"CP",IBCPT,0),U,IBI)=IBDIFN
    29         ;
    30 RX      ;copy rx refills (362.4)
    31         N IBRX,IBRIFN,IBRXDA,IBDATE,IBNDC,IBDFN,IB3624DA
    32         ;copy rx refills from old bill
    33         ; IB*2*363 - get NDC# from PRESCRIPTION file (#52) before creating new
    34         ; record entry in 362.4
    35         I $D(^IBA(362.4,"AIFN"_IBIFN1)) S IBXR="AIFN"_IBIFN1 D
    36         . S IBRX=0 F  S IBRX=$O(^IBA(362.4,IBXR,IBRX)) Q:IBRX=""  D
    37         .. S IBRIFN=0 F  S IBRIFN=$O(^IBA(362.4,IBXR,IBRX,IBRIFN)) Q:'IBRIFN  D
    38         ... S IBX=$G(^IBA(362.4,IBRIFN,0)) I IBX=""!($P(IBX,U,2)'=IBIFN1) Q
    39         ... S DIC="^IBA(362.4,",DIC(0)="L",X=$P(IBX,U,1) K DA,DO D FILE^DICN K DA,DO Q:Y'>0
    40         ... S IB3624DA=+Y,IBRXDA=$P(IBX,U,5),IBDATE=$P(IBX,U,3),IBDFN=$$GET1^DIQ(399,IBIFN1,.02,"I")
    41         ... S IBNDC=$S(IBRXDA:$$GETNDC^IBEFUNC3(IBDFN,IBRXDA,IBDATE),1:$P(IBX,U,8))
    42         ... S DR=".02////"_IBIFN_";.03////"_IBDATE_";.04////"_$P(IBX,U,4)_";.05////"_IBRXDA_";.06////"_$P(IBX,U,6)_";.07////"_$P(IBX,U,7)_";.08////"_IBNDC
    43         ... S DIE=DIC,DA=IB3624DA D ^DIE K DIC,DIE,DA,DO,DR
    44         K DIE,DIC,DA,DO,DR,X,Y
    45         ;
    46 PROS    ;copy prosthetics (362.5)
    47         N IBPR,IBPIFN
    48         ;copy rx refills from old bill
    49         I $D(^IBA(362.5,"AIFN"_IBIFN1)) S IBXR="AIFN"_IBIFN1 D
    50         . S IBPR=0 F  S IBPR=$O(^IBA(362.5,IBXR,IBPR)) Q:IBPR=""  D
    51         .. S IBPIFN=0 F  S IBPIFN=$O(^IBA(362.5,IBXR,IBPR,IBPIFN)) Q:'IBPIFN  D
    52         ... S IBX=$G(^IBA(362.5,IBPIFN,0)) I IBX=""!($P(IBX,U,2)'=IBIFN1) Q
    53         ... S DIC="^IBA(362.5,",DIC(0)="L",X=$P(IBX,U,1) K DA,DO D FILE^DICN K DA,DO Q:Y'>0
    54         ... S DR=".02////"_IBIFN_";.04////"_$P(IBX,U,4)_";.05////^S X=$P(IBX,U,5)"
    55         ... S DIE=DIC,DA=+Y D ^DIE K DIC,DIE,DA,DO,DR
    56         K DIE,DIC,DA,DO,DR,X,Y
    57         Q
    58         ;IBCCC3
     1IBCCC3 ;ALB/AAS - CANCEL AND CLONE A BILL - CONTINUED ;25-JAN-90
     2 ;;2.0;INTEGRATED BILLING;**363,381**;21-MAR-94;Build 1
     3 ;;Per VHA Directive 2004-038, this routine should not be modified.
     4 ;
     5 ;copy entries from table files:
     6 ;passed in: IBIFN=new bill, IBIFN1=old bill
     7 ;
     8 I '$D(^DGCR(399,+$G(IBIFN),0))!'$D(^DGCR(399,+$G(IBIFN1),0)) Q
     9 N IBXR,X,Y,IBX
     10 ;
     11DX ;copy diagnosis' (362.3)
     12 N IBDX,IBDIFN
     13 ;copy diagnosis from old bill
     14 I $D(^IBA(362.3,"AIFN"_IBIFN1)) S IBXR="AIFN"_IBIFN1 D
     15 . S IBDX=0 F  S IBDX=$O(^IBA(362.3,IBXR,IBDX)) Q:'IBDX  D
     16 .. S IBDIFN=0 F  S IBDIFN=$O(^IBA(362.3,IBXR,IBDX,IBDIFN)) Q:'IBDIFN  D
     17 ... S IBX=$G(^IBA(362.3,IBDIFN,0)) I 'IBX!($P(IBX,U,2)'=IBIFN1) Q
     18 ... S DIC="^IBA(362.3,",DIC(0)="L",X=+IBX K DA,DO D FILE^DICN
     19 ... S DIE=DIC,DA=+Y,DR=".02////"_IBIFN_";.03////"_$P(IBX,U,3) D ^DIE K DIC,DIE,DA,DO,DR
     20 K DIE,DIC,DA,DO,DR,X,Y
     21 ;
     22PRDX ;repoint procedure's associated diagnosis (2,304,10-13 -> 362.3)
     23 N IBCPT,IBDIFN1,IBLN,IBI
     24 S IBCPT=0 F  S IBCPT=$O(^DGCR(399,+IBIFN,"CP",IBCPT)) Q:'IBCPT  D
     25 . S IBLN=$G(^DGCR(399,+IBIFN,"CP",IBCPT,0)) F IBI=11:1:14 S IBDIFN1=$P(IBLN,U,IBI) I +IBDIFN1 D
     26 .. S IBDX=+$G(^IBA(362.3,+IBDIFN1,0)) Q:'IBDX
     27 .. S IBDIFN=$O(^IBA(362.3,"AIFN"_IBIFN,IBDX,0)) Q:'IBDIFN
     28 .. S $P(^DGCR(399,+IBIFN,"CP",IBCPT,0),U,IBI)=IBDIFN
     29 ;
     30RX ;copy rx refills (362.4)
     31 N IBRX,IBRIFN,IBRXDA,IBDATE,IBNDC,IBDFN,IB3624DA
     32 ;copy rx refills from old bill
     33 ; IB*2*363 - get NDC# from PRESCRIPTION file (#52) before creating new
     34 ; record entry in 362.4
     35 I $D(^IBA(362.4,"AIFN"_IBIFN1)) S IBXR="AIFN"_IBIFN1 D
     36 . S IBRX=0 F  S IBRX=$O(^IBA(362.4,IBXR,IBRX)) Q:IBRX=""  D
     37 .. S IBRIFN=0 F  S IBRIFN=$O(^IBA(362.4,IBXR,IBRX,IBRIFN)) Q:'IBRIFN  D
     38 ... S IBX=$G(^IBA(362.4,IBRIFN,0)) I IBX=""!($P(IBX,U,2)'=IBIFN1) Q
     39 ... S DIC="^IBA(362.4,",DIC(0)="L",X=$P(IBX,U,1) K DA,DO D FILE^DICN K DA,DO Q:Y'>0
     40 ... S IB3624DA=+Y,IBRXDA=$P(IBX,U,5),IBDATE=$P(IBX,U,3),IBDFN=$$GET1^DIQ(399,IBIFN1,.02,"I")
     41 ... S IBNDC=$S(IBRXDA:$$GETNDC^IBEFUNC3(IBDFN,IBRXDA,IBDATE),1:$P(IBX,U,8))
     42 ... S DR=".02////"_IBIFN_";.03////"_IBDATE_";.04////"_$P(IBX,U,4)_";.05////"_IBRXDA_";.06////"_$P(IBX,U,6)_";.07////"_$P(IBX,U,7)_";.08////"_IBNDC
     43 ... S DIE=DIC,DA=IB3624DA D ^DIE K DIC,DIE,DA,DO,DR
     44 K DIE,DIC,DA,DO,DR,X,Y
     45 ;
     46PROS ;copy prosthetics (362.5)
     47 N IBPR,IBPIFN
     48 ;copy rx refills from old bill
     49 I $D(^IBA(362.5,"AIFN"_IBIFN1)) S IBXR="AIFN"_IBIFN1 D
     50 . S IBPR=0 F  S IBPR=$O(^IBA(362.5,IBXR,IBPR)) Q:IBPR=""  D
     51 .. S IBPIFN=0 F  S IBPIFN=$O(^IBA(362.5,IBXR,IBPR,IBPIFN)) Q:'IBPIFN  D
     52 ... S IBX=$G(^IBA(362.5,IBPIFN,0)) I IBX=""!($P(IBX,U,2)'=IBIFN1) Q
     53 ... S DIC="^IBA(362.5,",DIC(0)="L",X=$P(IBX,U,1) K DA,DO D FILE^DICN K DA,DO Q:Y'>0
     54 ... S DR=".02////"_IBIFN_";.03////"_$P(IBX,U,3)_";.04////"_$P(IBX,U,4)
     55 ... S DIE=DIC,DA=+Y D ^DIE K DIC,DIE,DA,DO,DR
     56 K DIE,DIC,DA,DO,DR,X,Y
     57 Q
     58 ;IBCCC3

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCE.m

    r613 r623  
    1 IBCE    ;ALB/TMP - 837 EDI TRANSMISSION UTILITIES/NIGHTLY JOB ;22-JAN-96
    2         ;;2.0;INTEGRATED BILLING;**137,283,296,371**;21-MAR-94;Build 57
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4 EN      ; Run all jobs needed for EDI processing nightly
    5         ; including transmit bills waiting for extract, batches not sent,
    6         N IBLAST,IBZ,IBZ0
    7         D NOTSENT^IBCEBUL
    8         D EN^IBCE837
    9         D EN^IBCEMPRG      ; purge status messages from file 361
    10         D PURGE^IBCEPTU    ; purge transmission detail and claims status data associated with test transmissions after 60 days
    11         S IBLAST=$G(^IBA(364.2,"ALAST")),^IBA(364.2,"ALAST")=$$NOW^XLFDT()
    12         ; Clean up ACOB xref in 364
    13         S IBZ=0
    14         F  S IBZ=$O(^IBA(364,"ACOB",IBZ)) Q:'IBZ  S IBZ0=0 F  S IBZ0=$O(^IBA(364,"ACOB",IBZ,IBZ0)) Q:'IBZ0  I '$$COBPOSS^IBCECOB(IBZ0) D UPDEDI^IBCEM(IBZ0,"N",1)
    15         Q
    16         ;
    17 EN1     ; Manual entry point for transmitting EDI bills
    18         N DIR,X,Y,IBLAST,IBTASK,IBOPTX,DTOUT,DUOUT
    19         I '$$MGCHK(1) G EN1Q
    20         S DIR("A")="Select transmit option: ",DIR("B")="S",DIR(0)="SAM^A:Transmit (A)LL bills in READY FOR EXTRACT status;S:Transmit only (S)ELECTED bills"
    21         D ^DIR K DIR
    22         I $D(DTOUT)!$D(DUOUT) G EN1Q
    23         S IBOPTX=Y
    24         I Y="A" D  G EN1Q
    25         . S DIR("A",1)="This option will run a job to transmit ALL bills ready for EDI transmission"
    26         . S DIR("A",2)="This option's last scheduled run was "_$$FMTE^XLFDT($G(^IBA(364.2,"ALAST")),2)
    27         . S DIR("A",3)=" "
    28         . S DIR("A")="Are you absolutely sure this is what you want to do? "
    29         . S DIR("B")="NO",DIR(0)="YA" D ^DIR K DIR
    30         . Q:'Y
    31         . S DIR(0)="YA",DIR("A",1)=" "
    32         . S DIR("A",2)="Transmission of ALL bills will be run now"
    33         . S DIR("A")="Is this OK? ",DIR("B")="NO"
    34         . D ^DIR K DIR
    35         . Q:'Y
    36         . D EN1^IBCE837B(.IBTASK)
    37         . I $G(IBTASK) D
    38         .. S DIR("A",1)="Task # for this job is: "_IBTASK
    39         . E  D
    40         .. I $G(IBTASK)'="" S DIR("A",1)="Error encountered in tasking job - check IRM for reported errors"
    41         .. S DIR(0)="EA",DIR("A")=" Press RETURN to continue " W !! D ^DIR K DIR
    42         I IBOPTX="S" D SUB1^IBCEM03 G EN1Q
    43 EN1Q    Q
    44         ;
    45 RESUB(IB364)    ; Manually resubmit bill for transmission (ien file 364 = IB364)
    46         N DIR,X,Y,IBBTCH,DTOUT,DUOUT,IBIFN,NEW364
    47         I '$$MGCHK(1) G RESUBQ
    48         S IBIFN=+$P($G(^IBA(364,+$G(IB364),0)),U,1) I 'IBIFN G RESUBQ
    49         S IBBTCH=""
    50         W ! S DIR(0)="SA^I:IMMEDIATE TRANSMIT;L:TRANSMIT LATER WITH REST OF READY FOR EXTRACT BILLS",DIR("A")="TRANSMIT (I)MMEDIATELY OR (L)ATER?: ",DIR("B")="L"
    51         S DIR("?",1)="IF YOU CHOOSE TO TRANSMIT IMMEDIATELY, THE BILL'S DATA WILL BE BATCHED BY",DIR("?",2)=" ITSELF AND SENT OUT IMMEDIATELY.  IF YOU CHOOSE TO TRANSMIT LATER, THE"
    52         S DIR("?",3)="  BILL'S TRANSMISSION STATUS WILL BE RESET TO 'READY FOR EXTRACT' AND THE BILL'S",DIR("?",4)="  DATA WILL BE EXTRACTED THE NEXT TIME A GENERAL TRANSMISSION OF YOUR BILLS",DIR("?")="  IN READY TO EXTRACT STATUS OCCURS"
    53         D ^DIR K DIR
    54         I $D(DTOUT)!$D(DUOUT) G RESUBQ
    55         ;
    56         ; immediate retransmission of claim
    57         I Y="I" D  G RESUBQ
    58         . S NEW364=$$ADDTBILL^IBCB1(IBIFN)    ; Add a new transmission record
    59         . I '$P(NEW364,U,3) D  Q
    60         .. S DIR("A",1)="FAILED TO ADD A NEW EDI TRANSMISSION",DIR(0)="EA",DIR("A")="PRESS ENTER TO CONTINUE " W ! D ^DIR K DIR
    61         .. Q
    62         . ;
    63         . K ^TMP("IBONE",$J),^TMP("IBSELX",$J),^TMP("IBCE-BATCH",$J)
    64         . S ^TMP("IBONE",$J,+NEW364)="",^TMP("IBONE",$J)=0,^TMP("IBSELX",$J)=""
    65         . D ONE^IBCE837
    66         . S IBBTCH=$O(^TMP("IBCE-BATCH",$J,0))                     ; external batch#
    67         . I IBBTCH'="" S IBBTCH=+$G(^TMP("IBCE-BATCH",$J,IBBTCH))  ; internal batch#
    68         . K ^TMP("IBONE",$J),^TMP("IBSELX",$J),^TMP("IBCE-BATCH",$J)
    69         . ;
    70         . I 'IBBTCH D
    71         .. S DIR("A",1)="BILL NOT RESUBMITTED - CHECK ALERTS/MAIL FOR DETAILS"
    72         . E  D
    73         .. N DIE,DR,DA
    74         .. D UPDEDI^IBCEM(IB364,"R")   ; update EDI files for old transmission
    75         .. S DIE="^IBA(364,",DR=".06////"_+IBBTCH,DA=IB364 D ^DIE
    76         .. S DIR("A",1)="BILL RESUBMITTED IN BATCH #"_$P($G(^IBA(364.1,+IBBTCH,0)),U,1)
    77         . S DIR(0)="EA",DIR("A")="PRESS ENTER TO CONTINUE " W ! D ^DIR K DIR
    78         . Q
    79         ;
    80         ; Later retransmission of claim
    81         D UPDEDI^IBCEM(IB364,"R")      ; update EDI files for old transmission record
    82         S Y=$$ADDTBILL^IBCB1(IBIFN)    ; Add a new transmission record
    83         S DIR("A",1)="BILL'S TRANSMISSION STATUS RESET TO 'READY TO EXTRACT'"
    84         S DIR(0)="EA",DIR("A")="PRESS ENTER TO CONTINUE " W ! D ^DIR K DIR
    85         ;
    86 RESUBQ  Q
    87         ;
    88 MGCHK(DSP)      ; Returns 1 if mail group IB EDI has at least 1 local member,
    89         ; 0 if none found
    90         ; DSP = flag that if =1, displays error message
    91         N IB
    92         S IB=$$GOTLOCAL^XMXAPIG("IB EDI")
    93         I 'IB,$G(DSP) D
    94         . ; No local members in mail group for EDI messages
    95         . S DIR("A",1)="YOU MUST HAVE AT LEAST 1 MEMBER IN THE 'IB EDI' MAIL GROUP TO TRANSMIT A BILL",DIR("A")="PRESS RETURN TO CONTINUE "
    96         . S DIR(0)="EA" D ^DIR K DIR
    97         Q IB
    98         ;
     1IBCE ;ALB/TMP - 837 EDI TRANSMISSION UTILITIES/NIGHTLY JOB ;22-JAN-96
     2 ;;2.0;INTEGRATED BILLING;**137,283,296**;21-MAR-94
     3EN ; Run all jobs needed for EDI processing nightly
     4 ; including transmit bills waiting for extract, batches not sent,
     5 N IBLAST,IBZ,IBZ0
     6 D NOTSENT^IBCEBUL
     7 D EN^IBCE837
     8 D EN^IBCEMPRG      ; purge status messages from file 361
     9 D PURGE^IBCEPTU    ; purge transmission detail and claims status data associated with test transmissions after 60 days
     10 S IBLAST=$G(^IBA(364.2,"ALAST")),^IBA(364.2,"ALAST")=$$NOW^XLFDT()
     11 ; Clean up ACOB xref in 364
     12 S IBZ=0
     13 F  S IBZ=$O(^IBA(364,"ACOB",IBZ)) Q:'IBZ  S IBZ0=0 F  S IBZ0=$O(^IBA(364,"ACOB",IBZ,IBZ0)) Q:'IBZ0  I '$$COBPOSS^IBCECOB(IBZ0) D UPDEDI^IBCEM(IBZ0,"N",1)
     14 Q
     15 ;
     16EN1 ; Manual entry point for transmitting EDI bills
     17 N DIR,X,Y,IBLAST,IBTASK,IBOPTX,DTOUT,DUOUT
     18 I '$$MGCHK(1) G EN1Q
     19 S DIR("A")="Select transmit option: ",DIR("B")="S",DIR(0)="SAM^A:Transmit (A)LL bills in READY FOR EXTRACT status;S:Transmit only (S)ELECTED bills"
     20 D ^DIR K DIR
     21 I $D(DTOUT)!$D(DUOUT) G EN1Q
     22 S IBOPTX=Y
     23 I Y="A" D  G EN1Q
     24 . S DIR("A",1)="This option will run a job to transmit ALL bills ready for EDI transmission"
     25 . S DIR("A",2)="This option's last scheduled run was "_$$FMTE^XLFDT($G(^IBA(364.2,"ALAST")),2)
     26 . S DIR("A",3)=" "
     27 . S DIR("A")="Are you absolutely sure this is what you want to do? "
     28 . S DIR("B")="NO",DIR(0)="YA" D ^DIR K DIR
     29 . Q:'Y
     30 . S DIR(0)="YA",DIR("A",1)=" "
     31 . S DIR("A",2)="Transmission of ALL bills will be run now"
     32 . S DIR("A")="Is this OK? ",DIR("B")="NO"
     33 . D ^DIR K DIR
     34 . Q:'Y
     35 . D EN1^IBCE837B(.IBTASK)
     36 . I $G(IBTASK) D
     37 .. S DIR("A",1)="Task # for this job is: "_IBTASK
     38 . E  D
     39 .. I $G(IBTASK)'="" S DIR("A",1)="Error encountered in tasking job - check IRM for reported errors"
     40 .. S DIR(0)="EA",DIR("A")=" Press RETURN to continue " W !! D ^DIR K DIR
     41 I IBOPTX="S" D SUB1^IBCEM03 G EN1Q
     42EN1Q Q
     43 ;
     44RESUB(IB364) ; Manually resubmit bill for transmission (ien file 364 = IB364)
     45 N DIR,X,Y,IBBTCH,DTOUT,DUOUT
     46 I '$$MGCHK(1) G RESUBQ
     47 S IBBTCH=""
     48 W ! S DIR(0)="SA^I:IMMEDIATE TRANSMIT;L:TRANSMIT LATER WITH REST OF READY FOR EXTRACT BILLS",DIR("A")="TRANSMIT (I)MMEDIATELY OR (L)ATER?: ",DIR("B")="L"
     49 S DIR("?",1)="IF YOU CHOOSE TO TRANSMIT IMMEDIATELY, THE BILL'S DATA WILL BE BATCHED BY",DIR("?",2)=" ITSELF AND SENT OUT IMMEDIATELY.  IF YOU CHOOSE TO TRANSMIT LATER, THE"
     50 S DIR("?",3)="  BILL'S TRANSMISSION STATUS WILL BE RESET TO 'READY FOR EXTRACT' AND THE BILL'S",DIR("?",4)="  DATA WILL BE EXTRACTED THE NEXT TIME A GENERAL TRANSMISSION OF YOUR BILLS",DIR("?")="  IN READY TO EXTRACT STATUS OCCURS"
     51 D ^DIR K DIR
     52 I $D(DTOUT)!$D(DUOUT) G RESUBQ
     53 I Y="I" D  G:'IBBTCH RESUBQ
     54 . N Y
     55 . K ^TMP("IBONE",$J),^TMP("IBSELX",$J),^TMP("IBCE-BATCH",$J)
     56 . S ^TMP("IBONE",$J,IB364)="",^TMP("IBONE",$J)=0,^TMP("IBSELX",$J)=""
     57 . D ONE^IBCE837
     58 . S IBBTCH=$O(^TMP("IBCE-BATCH",$J,0))                     ; external batch#
     59 . I IBBTCH'="" S IBBTCH=+$G(^TMP("IBCE-BATCH",$J,IBBTCH))  ; internal batch#
     60 . K ^TMP("IBONE",$J),^TMP("IBSELX",$J),^TMP("IBCE-BATCH",$J)
     61 . I 'IBBTCH D
     62 .. S DIR("A",1)="BILL NOT RESUBMITTED - CHECK ALERTS/MAIL FOR DETAILS"
     63 . E  D
     64 .. N DIE,DR,DA
     65 .. D UPDEDI^IBCEM(IB364,"R")
     66 .. S DIE="^IBA(364,",DR=".06////"_+IBBTCH,DA=IB364 D ^DIE
     67 .. S DIR("A",1)="BILL RESUBMITTED IN BATCH #"_$P($G(^IBA(364.1,IBBTCH,0)),U)
     68 . S DIR(0)="EA",DIR("A")="PRESS ENTER TO CONTINUE " D ^DIR K DIR
     69 I Y="L" D
     70 . N Y
     71 . D UPDEDI^IBCEM(IB364,"R")
     72 . ;Add a new transmission record
     73 . S Y=$$ADDTBILL^IBCB1($P($G(^IBA(364,+IB364,0)),U),1)
     74 . S DIR("A",1)="BILL'S TRANSMISSION STATUS RESET TO 'READY TO EXTRACT'"
     75 . S DIR(0)="EA",DIR("A")="PRESS ENTER TO CONTINUE " D ^DIR K DIR
     76 ;
     77RESUBQ Q
     78 ;
     79MGCHK(DSP) ; Returns 1 if mail group IB EDI has at least 1 local member,
     80 ; 0 if none found
     81 ; DSP = flag that if =1, displays error message
     82 N IB
     83 S IB=$$GOTLOCAL^XMXAPIG("IB EDI")
     84 I 'IB,$G(DSP) D
     85 . ; No local members in mail group for EDI messages
     86 . S DIR("A",1)="YOU MUST HAVE AT LEAST 1 MEMBER IN THE 'IB EDI' MAIL GROUP TO TRANSMIT A BILL",DIR("A")="PRESS RETURN TO CONTINUE "
     87 . S DIR(0)="EA" D ^DIR K DIR
     88 Q IB
     89 ;

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCE277.m

    r613 r623  
    1 IBCE277 ;ALB/TMP - 277 EDI CLAIM STATUS MESSAGE PROCESSING ;15-JUL-98
    2         ;;2.0;INTEGRATED BILLING;**137,155,368**;21-MAR-94;Build 21
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         Q
    5         ; MESSAGE HEADER DATA STRING =
    6         ;   type of message^msg queue^msg #^bill #^REF NUM/Batch #^date/time
    7         ;
    8 HDR(ENTITY,ENTVAL,IBTYPE,IBD)   ;Process header data
    9         ; INPUT:
    10         ;   ENTITY = "BATCH" or "CLAIM" for batch/claim level messages respectively
    11         ;   ENTVAL = claim #
    12         ;   IBTYPE = the type of status msg this piece of the message represents
    13         ;             (837REC1, 837REJ1)
    14         ;   ^TMP("IBMSGH",$J,0) = header message text
    15         ;
    16         ; OUTPUT:
    17         ;   IBD array returned with processed data
    18         ;      "DATE" = Date/Time of status (Fileman format)
    19         ;      "MRA" =  1 if MRA, 0 if not         "X12" = 1 if X12, 0 if not
    20         ;      "BATCH" = Batch ien for batch level calls
    21         ;      "SOURCE" = Source of message code^source name, if known
    22         ;
    23         ;   ^TMP("IBMSG",$J,"BATCH",batch #,0)=MESSAGE HEADER DATA STRING
    24         ;                                      if batch level message
    25         ;                                  ,"D",0,1)=header record raw data
    26         ;                                  ,line #)=batch status message lines
    27         ;
    28         ;   ^TMP("IBMSG",$J,"CLAIM",claim #,0)=MESSAGE HEADER DATA STRING
    29         ;                                      if claim level message
    30         ;                                  ,"D",0,1)=header record raw data
    31         ;                                  ,line #)=claim status message lines
    32         ;
    33         N DATA,IBD0,L,PC,X,Y
    34         S IBD0=$G(^TMP("IBMSGH",$J,0)) Q:IBD0=""
    35         S Y=0,L=1
    36         ; Convert claim date/time
    37         S X=$$DATE($P(IBD0,U,3))_"@"_$E($P(IBD0,U,4)_"0000",1,4) I X S %DT="XTS" D ^%DT
    38         ; populate IBD array
    39         S IBD("DATE")=$S(Y>0:Y,1:""),IBD("MRA")=$P(IBD0,U,5),IBD("X12")=($P(IBD0,U,2)="X")
    40         S IBD("SOURCE")=$P(IBD0,U,12,13),IBD("BATCH")=$P(IBD0,U,14)
    41         I +$TR($P(IBD0,U,6,9),U) F PC=6:1:9 D
    42         .I $P(IBD0,U,PC)'="" S DATA=$P("# Claims Submitted^# Claims Rejected^Total Charges Submitted^Total Charges Rejected",U,PC-5)_": "_$S(PC<8:+$P(IBD0,U,PC),1:$FNUMBER($P(IBD0,U,PC)/100,"",2))_"  "
    43         .I $L($G(^TMP("IBMSG-H",$J,ENTITY,ENTVAL,L)))+$L(DATA)>70 S L=L+1 ; if data doesn't fit into current line, go to the next line
    44         .S ^TMP("IBMSG-H",$J,ENTITY,ENTVAL,L)=$G(^TMP("IBMSG-H",$J,ENTITY,ENTVAL,L))_DATA ; file this piece of data
    45         .Q
    46         ; file batch ref. number
    47         S:IBD("BATCH")'="" L=L+1,^TMP("IBMSG-H",$J,ENTITY,ENTVAL,L)="Batch Reference Number: "_IBD("BATCH")
    48         I $TR($P(IBD0,U,10,13),U)'="" D
    49         .S L=L+1
    50         .; generate and file Payer Name / Payer Id line
    51         .S DATA="Payer Name: "_$S($P(IBD0,U,10)'="":$P(IBD0,U,10),1:"N/A")_"  Payer ID: "_$S($P(IBD0,U,11)'="":$P(IBD0,U,11),1:"N/A")
    52         .S ^TMP("IBMSG-H",$J,ENTITY,ENTVAL,L)=DATA
    53         .I $P(IBD0,U,12)'=""!($P(IBD0,U,13)'="") D
    54         ..; generate and file Message Source line
    55         ..S DATA="Source: "_$S($P(IBD0,U,12)="Y":"Sent by payer",$P(IBD0,U,13)'="":"Sent by non-payer ("_$P(IBD0,U,13)_")",1:"UNKNOWN")
    56         ..S L=L+1,^TMP("IBMSG-H",$J,ENTITY,ENTVAL,L)=DATA
    57         ..Q
    58         .Q
    59         S ^TMP("IBMSG",$J,ENTITY,ENTVAL,0)=IBTYPE_U_$G(IBD("MSG#"))_U_$G(IBD("SUBJ"))_U_$$GETBILL(ENTVAL)_U_U_IBD("DATE")_U_IBD("SOURCE")
    60         ; file raw data
    61         S ^TMP("IBMSG",$J,ENTITY,ENTVAL,"D",0,1)="##RAW DATA: "_IBD0
    62         Q
    63         ;
    64 9(IBD)  ; Process Message Header record
    65         ; INPUT:
    66         ;   IBD must be passed by reference = entire message line
    67         ; OUTPUT:
    68         ;   IBD array returned with processed data
    69         ;      "CLAIM" = claim #
    70         ;      "LINE" = last line # populated in the message
    71         ;
    72         ;   ^TMP("IBMSG",$J,"CLAIM",claim #,line#)= message data lines
    73         ;                                  ,"D",9,msg seq #)= raw data
    74         N ENTITY,ERR,FLD,IBCLM,IBIFN,L
    75         D STRTREC Q:IBCLM=""  ; if no claim/batch number, bail out
    76         ; make sure that we have data to file
    77         S ERR=$P(IBD,U,4) Q:ERR=""
    78         ; file error along with corresponding field number (if available)
    79         S L=L+1,FLD=$P(IBD,U,5),^TMP("IBMSG",$J,ENTITY,IBCLM,L)="Error"_$S(FLD'="":" in field "_FLD,1:"")_":"
    80         S L=L+1,^TMP("IBMSG",$J,ENTITY,IBCLM,L)=ERR
    81         D ENDREC(9)
    82         Q
    83         ;
    84 10(IBD) ; Process message data
    85         ; INPUT:
    86         ;   IBD must be passed by reference = entire message line
    87         ; OUTPUT:
    88         ;   IBD array returned with processed data
    89         ;      "CLAIM" = claim #
    90         ;      "LINE" = last line # populated in the message
    91         ;
    92         ;   ^TMP("IBMSG",$J,"CLAIM",claim #,line#)= message data lines
    93         ;                                  ,"D",10,msg seq #)= raw data
    94         ;   ^TMP("IBCONF",$J,claim #")="" for invalid claims within the batch
    95         ;
    96         N CODE,DATA,ENTITY,IBCLM,IBIFN,IBTYPE,L,Z
    97         D STRTREC Q:IBCLM=""  ; if no claim number, bail out
    98         S:$P(IBD,U,3)="R" ^TMP("IBCONF",$J,IBIFN)=""
    99         S IBTYPE=$S($P(IBD,U,3)="R":"837REJ1",1:"837REC1")
    100         ;Process header data if not already done
    101         I '$D(^TMP("IBMSG",$J,ENTITY,IBCLM,0)) D HDR(ENTITY,IBCLM,IBTYPE,.IBD)
    102         I IBTYPE="837REJ1",$P($G(^TMP("IBMSG",$J,ENTITY,IBCLM,0)),U,1)'="837REJ1" D HDR(ENTITY,IBCLM,IBTYPE,.IBD)
    103         S CODE=$P(IBD,U,4) I CODE'="",$TR($P(IBD,U,5,6),U)'="" D
    104         .S Z=CODE_$P(IBD,U,5) I Z'=$G(IBD("SCODE")) D
    105         ..; determine type of status code and file it
    106         ..S L=L+1,DATA=$S(CODE="W":"Warning",CODE="E":"Error",1:"Informational")_" "
    107         ..I $P(IBD,U,5)'="" S ^TMP("IBMSG",$J,ENTITY,IBCLM,L)=DATA_"Code: "_$P(IBD,U,5)
    108         ..I $P(IBD,U,6)'="" S:$P(IBD,U,5)'="" L=L+1 S ^TMP("IBMSG",$J,ENTITY,IBCLM,L)=DATA_"Message:",L=L+1
    109         ..S IBD("SCODE")=Z
    110         ..Q
    111         .; file status message
    112         .I $P(IBD,U,6)'="" S ^TMP("IBMSG",$J,ENTITY,IBCLM,L)=$P(IBD,U,6),L=L+1,^TMP("IBMSG",$J,ENTITY,IBCLM,L)=" "
    113         .Q
    114         D ENDREC(10)
    115         Q
    116         ;
    117 13(IBD) ; Process claim data
    118         ; Claim must have been referenced by a previous '10' level
    119         ; INPUT:
    120         ;   IBD must be passed by reference = entire message line
    121         ;
    122         ; OUTPUT:
    123         ;      IBD("LINE") = The last line # populated in the message
    124         ;
    125         ;     ^TMP("IBMSG",$J,"CLAIM",claim #,line#)=claim data lines
    126         ;                                    ,"D",13,msg seq #)=raw data
    127         ;
    128         N CTYPE,ENTITY,IBCLM,IBIFN,L,Z1,Z2
    129         D STRTREC
    130         ; quit if no claim number or no previous 'line 10' record
    131         Q:$S(IBCLM="":1,1:'$D(^TMP("IBMSG",$J,"CLAIM",IBCLM)))
    132         ; file clearinghouse trace number
    133         I $P(IBD,U,3)'="" S L=L+1,^TMP("IBMSG",$J,ENTITY,IBCLM,L)="Clearinghouse Trace Number: "_$P(IBD,U,3)
    134         ; file payer status date
    135         I $P(IBD,U,4)'="" S L=L+1,^TMP("IBMSG",$J,ENTITY,IBCLM,L)="         Payer Status Date: "_$$DATE($P(IBD,U,4))
    136         ; file payer claim number
    137         I $P(IBD,U,5)'="" S L=L+1,^TMP("IBMSG",$J,ENTITY,IBCLM,L)="        Payer Claim Number: "_$P(IBD,U,5)
    138         ; file split claim indicator
    139         I +$P(IBD,U,6)'=0 S L=L+1,^TMP("IBMSG",$J,ENTITY,IBCLM,L)="               Split Claim: "_$S(+$P(IBD,U,6)=1:"No",1:"Yes ("_+$P(IBD,U,6)_" parts)")
    140         ; file claim type if it either doesn't match value in VistA or if it's a dental claim
    141         S Z1=$P(IBD,U,7),Z2=$$FT^IBCEF(IBIFN),CTYPE=$S(Z1="P"&(Z2'=2):"Professional",Z1="I"&(Z2'=3):"Institutional",Z1="D":"Dental",1:"")
    142         S:CTYPE'="" L=L+1,^TMP("IBMSG",$J,ENTITY,IBCLM,L)="                Claim Type: "_CTYPE
    143         D ENDREC(13)
    144         Q
    145         ;
    146 15(IBD) ; Process subscriber/patient data
    147         ; Claim must have been referenced by a previous '10' level
    148         ; INPUT:
    149         ;   IBD must be passed by reference = entire message line
    150         ;
    151         ; OUTPUT:
    152         ;      IBD("LINE") = The last line # populated in the message
    153         ;
    154         ;     ^TMP("IBMSG",$J,"CLAIM",claim #,line#)=formatted service dates
    155         ;                                    ,"D",15,msg seq #)=
    156         ;                                         subscr/patient raw data
    157         ;
    158         N ENTITY,DATA,IBCLM,IBIFN,IBNM,IBNUM,IBDFN,L
    159         D STRTREC
    160         ; quit if no claim number or no previous 'line 10' record
    161         Q:$S(IBCLM="":1,1:'$D(^TMP("IBMSG",$J,"CLAIM",IBCLM)))
    162         S IBDFN=+$P(^DGCR(399,IBIFN,0),U,2)
    163         S IBNM=$S($P(IBD,U,3)'="":$P(IBD,U,3)_","_$P(IBD,U,4)_$S($P(IBD,U,5)'="":" "_$P(IBD,U,5),1:""),1:$P($G(^DPT(IBDFN,0)),U))
    164         S IBNUM=$S($P(IBD,U,6)'="":$P(IBD,U,6),1:$P($G(^DPT(IBDFN,0)),U,9))
    165         S L=L+1,^TMP("IBMSG",$J,ENTITY,IBCLM,L)="Patient: "_IBNM_"   "_IBNUM
    166         I $P(IBD,U,11) D
    167         .S DATA=$$DATE($P(IBD,U,11)),L=L+1
    168         .S ^TMP("IBMSG",$J,ENTITY,IBCLM,L)="Service Dates: "_DATA_" - "_$S($P(IBD,U,12):$$DATE($P(IBD,U,12)),1:DATA)
    169         .Q
    170         D ENDREC(15)
    171         Q
    172         ;
    173 STRTREC ; start processing of the record
    174         ;           
    175         ; OUTPUT:
    176         ;   sets the following variables
    177         ;   IBCLM = claim #
    178         ;   ENTITY = "CLAIM" (all 277STAT messages are on claim level)
    179         ;   L = last populated line number
    180         ;
    181         S IBCLM=$$GETCLM($P(IBD,U,2)),ENTITY="CLAIM",L=+$G(IBD("LINE"))
    182         S IBIFN=+$O(^DGCR(399,"B",IBCLM,0))
    183         Q
    184         ;
    185 ENDREC(TYPE)    ; finish processing of the record
    186         ; INPUT:
    187         ;   TYPE = record type (line type)
    188         ;   
    189         ; OUTPUT:
    190         ;   IBD("LINE") = is updated with last populated line number
    191         ;
    192         ;make sure all variables are set properly
    193         Q:$G(ENTITY)=""
    194         Q:$G(IBCLM)=""
    195         Q:$G(TYPE)=""
    196         ; file raw data
    197         S ^TMP("IBMSG",$J,ENTITY,IBCLM,"D",TYPE,$O(^TMP("IBMSG",$J,ENTITY,IBCLM,"D",TYPE,""),-1)+1)="##RAW DATA: "_IBD
    198         ; update line count
    199         S IBD("LINE")=$G(IBD("LINE"))+L
    200         Q
    201         ;
    202 GETBILL(CLAIM)  ; Extract transmission #
    203         N TRANS
    204         S TRANS=$$LAST364^IBCEF4(IBIFN)
    205         ; if status of the last transmission is "X" or "P", keep searching backwards through file 364 until record
    206         ; with different status is found
    207         I TRANS F  Q:"XP"'[$P(^IBA(364,TRANS,0),U,3)  S TRANS=$O(^IBA(364,"B",IBIFN,TRANS),-1) Q:TRANS=""  ;
    208         Q +TRANS
    209         ;
    210 DATE(DT)        ; Convert YYMMDD Date into MM/DD/YY or YYYYMMDD into MM/DD/YYYY
    211         N D,Y
    212         S D=DT,Y=""
    213         I $L(DT)=8 S D=$E(DT,3,8),Y=$E(DT,1,2)
    214         Q ($E(D,3,4)_"/"_$E(D,5,6)_"/"_Y_$E(D,1,2))
    215         ;
    216 GETCLM(X)       ; Extract the claim # without site id from the data in X
    217         N IBCLM
    218         S IBCLM=$P(X,"-",2) I IBCLM="",X'="" S IBCLM=$E(X,$S($L(X)>7:4,1:1),$L(X))
    219         Q IBCLM
    220         ;
     1IBCE277 ;ALB/TMP - 277 EDI CLAIM STATUS MESSAGE PROCESSING ;15-JUL-98
     2 ;;2.0;INTEGRATED BILLING;**137,155**;21-MAR-94
     3 Q
     4 ; MESSAGE HEADER DATA STRING =
     5 ;   type of message^msg queue^msg #^bill #^REF NUM/Batch #^date/time
     6 ;
     7HDR(ENTITY,ENTVAL,IBTYPE,IBD) ;Process header data
     8 ; INPUT:
     9 ;   ENTITY = "BATCH" if batch level message
     10 ;            "CLAIM" if claim level message
     11 ;   ENTVAL = batch # or claim #
     12 ;   IBTYPE = the type of status msg this piece of the message represents
     13 ;             (837REC1, 837REJ1)
     14 ;   ^TMP("IBMSGH",$J,0) = header message text
     15 ;
     16 ; OUTPUT:
     17 ;   IBD array returned with processed data
     18 ;      "LINE" = The last line # populated in the message
     19 ;      "DATE" = Date/Time of status (Fileman format)
     20 ;      "MRA" =  1 if MRA, 0 if not         "X12" = 1 if X12, 0 if not
     21 ;      "BATCH" = Batch ien for batch level calls
     22 ;      "SOURCE" = Source of message code^source name, if known
     23 ;
     24 ;   ^TMP("IBMSG",$J,"BATCH",batch #,0)=MESSAGE HEADER DATA STRING
     25 ;                                      if called from batch level
     26 ;                                  ,"D",0,1)=header record raw data
     27 ;                                  ,line #)=batch status message lines
     28 ;
     29 ;   ^TMP("IBMSG",$J,"CLAIM",claim #,0)=MESSAGE HEADER DATA STRING
     30 ;                                      if called from claim level
     31 ;                                  ,"D",0,1)=header record raw data
     32 ;                                  ,line #)=claim status message lines
     33 ;
     34 N CT,CT1,IBBILL,IBD0,L,LINE,PC,Z,X,Y
     35 S IBD0=$G(^TMP("IBMSGH",$J,0)),IBD("LINE")=0
     36 Q:IBD0=""
     37 S Y=0,X=$$DATE($P(IBD0,U,3))_"@"_$E($P(IBD0,U,4)_"0000",1,4)
     38 I X S %DT="XTS" D ^%DT
     39 S IBD("DATE")=$S(Y>0:Y,1:"")
     40 S IBD("MRA")=$P(IBD0,U,5),IBD("X12")=($P(IBD0,U,2)="X")
     41 S IBD("SOURCE")=$P(IBD0,U,12,13)
     42 S CT=0
     43 ;
     44 I ENTITY="BATCH",ENTVAL'="" D  ;Only pertinent for batch level extract
     45 . S IBD("BATCH")=$O(^IBA(364.1,"B",ENTVAL,0))
     46 . F PC=6:1:9 D
     47 .. I $P(IBD0,U,PC)'="" S DATA=$P("# Claims Submitted^# Claims Rejected^Total Charges Submitted^Total Charges Rejected",U,PC-5)_": "_$S(PC<8:+$P(IBD0,U,PC),1:$FNUMBER($P(IBD0,U,PC)/100,"",2))_"  "
     48 .. I CT,$L($G(LINE(CT)))+$L(DATA)>80 S CT=CT+1
     49 .. S:'CT CT=1 S LINE(CT)=$G(LINE(CT))_DATA
     50 ;
     51 I ENTVAL'="",$TR($P(IBD0,U,10,13),U)'="" S CT1=CT,CT=CT+1 F PC=10,11,12 D  ;Both batch, claim levels extract
     52 . Q:$P(IBD0,U,PC)=""
     53 . I PC<12 S LINE(CT)=$G(LINE(CT))_$P("Payer Name^Payer ID",U,PC-9)_": "_$P(IBD0,U,PC)_"  ",CT1=CT Q
     54 . I $P(IBD0,U,12)'=""!($P(IBD0,U,13)'="") S:$P(IBD0,U,10)'=""!($P(IBD0,U,11)'="") CT=CT+1 S LINE(CT)="Source: "_$S($P(IBD0,U,12)="Y":"Sent by payer",$P(IBD0,U,13)'="":"Sent by non-payer ("_$P(IBD0,U,13)_")",1:"UNKNOWN")_"  "
     55 ;
     56 I CT D
     57 . S (L,Z)=0
     58 . F  S Z=$O(LINE(Z)) Q:'Z  S L=L+1,^TMP("IBMSG-H",$J,ENTITY,ENTVAL,L)=LINE(Z)
     59 . ;S IBD("LINE")=$G(IBD("LINE"))+CT
     60 ;
     61 I ENTITY="CLAIM" D
     62 . N Z0
     63 . S Z0=+$O(^DGCR(399,"B",ENTVAL,0))
     64 . I $G(IBD("BATCH")) S IBBILL=$O(^IBA(364,"ABABI",+$G(IBD("BATCH")),Z0,""),-1) Q
     65 . S IBBILL=$$LAST364^IBCEF4(Z0)
     66 S ^TMP("IBMSG",$J,ENTITY,ENTVAL,0)=IBTYPE_U_$G(IBD("MSG#"))_U_$G(IBD("SUBJ"))_U_$S(ENTITY="CLAIM":IBBILL,1:"")_U_$S(ENTITY="BATCH":ENTVAL,1:"")_U_IBD("DATE")_U_IBD("SOURCE")
     67 ;
     68 S ^TMP("IBMSG",$J,ENTITY,ENTVAL,"D",0,1)="##RAW DATA: "_IBD0
     69 Q
     70 ;
     715(IBD) ; Process batch status data
     72 ; INPUT:
     73 ;   IBD must be passed by reference = entire message line
     74 ; OUTPUT:
     75 ;   IBD array returned with processed data
     76 ;      "LINE" = The last line # populated in the message
     77 ;
     78 ;   ^TMP("IBMSG",$J,"BATCH",batch #,line#)=batch status message lines
     79 ;                                  ,"D",5,msg seq #)=
     80 ;                                       batch status message raw data
     81 ;
     82 N CT,DATA,IBBTCH,IBTYPE,L,LINE,Z
     83 K ^TMP("IBCONF",$J)
     84 S IBBTCH=+$P(IBD,U,2)
     85 S IBTYPE=$S($P(IBD,U,3)="R":"837REJ1",1:"837REC1")
     86 I '$D(^TMP("IBMSG",$J,"BATCH",IBBTCH)) D HDR("BATCH",IBBTCH,IBTYPE,.IBD) ;Process header data if not already done for batch
     87 S CT=0,LINE(1)=""
     88 S DATA=$P(IBD,U,4)
     89 I DATA'="",$TR($P(IBD,U,5,7),U)'="" D
     90 . Q:$G(^TMP("IBMSG",$J,"BATCH",IBBTCH))=DATA
     91 . S:'CT CT=CT+1 S LINE(CT)=$G(LINE(CT))_$S(DATA="W":"Warning",DATA="E":"Error",1:"Informational")_"  "
     92 S ^TMP("IBMSG",$J,"BATCH",IBBTCH)=DATA
     93 I $P(IBD,U,5)'="" S:'CT CT=CT+1 S LINE(CT)=$G(LINE(CT))_"Code: "_$P(IBD,U,5)
     94 I $P(IBD,U,6)'="" S:'CT CT=CT+1 S LINE(CT)=$G(LINE(CT))_"  "_$P(IBD,U,6),CT=CT+1
     95 I $P(IBD,U,7)'="" S:'CT CT=CT+1 S LINE(CT)=$G(LINE(CT))_"  "_$P(IBD,U,7)
     96 I CT D
     97 . S L=$G(IBD("LINE")),Z=0
     98 . F  S Z=$O(LINE(Z)) Q:'Z  S L=L+1,^TMP("IBMSG",$J,"BATCH",IBBTCH,L)=LINE(Z)
     99 . S ^TMP("IBMSG",$J,"BATCH",IBBTCH,"D",5,$O(^TMP("IBMSG",$J,"BATCH",IBBTCH,"D",5,""),-1)+1)="##RAW DATA: "_IBD
     100 . S IBD("LINE")=$G(IBD("LINE"))+CT
     101 Q
     102 ;
     10310(IBD) ; Process claim status data
     104 ; INPUT:
     105 ;   IBD must be passed by reference = entire message line
     106 ; OUTPUT:
     107 ;   IBD array returned with processed data
     108 ;      "CLAIM" = The claim #
     109 ;      "LINE" = The last line # populated in the message
     110 ;
     111 ;   ^TMP("IBMSG",$J,"CLAIM",claim #,line#)=claim status message lines
     112 ;                                  ,"D",10,msg seq #)=
     113 ;                                       claim status raw data
     114 ;   ^TMP("IBCONF",$J,claim #")="" for invalid claims within the batch
     115 ;
     116 N CT,DATA,IBCLM,IBTYPE,L,LINE,Z
     117 S IBCLM=$$GETCLM($P(IBD,U,2))
     118 Q:IBCLM=""
     119 S:$P(IBD,U,3)="R" ^TMP("IBCONF",$J,+$O(^DGCR(399,"B",IBCLM,0)))=""
     120 S IBTYPE=$S($P(IBD,U,3)="R":"837REJ1",1:"837REC1")
     121 I '$D(^TMP("IBMSG",$J,"CLAIM",IBCLM)) D HDR("CLAIM",IBCLM,IBTYPE,.IBD) ;Process header data if not already done for claim
     122 I IBTYPE="837REJ1",$P($G(^TMP("IBMSG",$J,"CLAIM",IBCLM,0)),U,1)'="837REJ1" D HDR("CLAIM",IBCLM,IBTYPE,.IBD)
     123 S CT=0,DATA=$P(IBD,U,4)
     124 I DATA'="",$TR($P(IBD,U,5,7),U)'="" D
     125 . Q:$G(^TMP("IBMSG",$J,"CLAIM",IBCLM))=DATA
     126 . S ^TMP("IBMSG",$J,"CLAIM",IBCLM)=DATA
     127 . S CT=CT+1,LINE(CT)=$G(LINE(CT))_$S(DATA="W":"Warning",DATA="E":"Error",1:"Informational")_"  "
     128 I $P(IBD,U,5)'="" S CT=$S('CT:1,1:CT),LINE(CT)=$G(LINE(CT))_"Code: "_$P(IBD,U,5)
     129 I $P(IBD,U,6)'="" S CT=$S('CT:1,1:CT),LINE(CT)=$G(LINE(CT))_"  "_$P(IBD,U,6)
     130 I $P(IBD,U,7)'="" S CT=CT+1,LINE(CT)="  "_$P(IBD,U,7)
     131 I CT D
     132 . S L=$G(IBD("LINE")),Z=0
     133 . F  S Z=$O(LINE(Z)) Q:'Z  S L=L+1,^TMP("IBMSG",$J,"CLAIM",IBCLM,L)=LINE(Z)
     134 . S ^TMP("IBMSG",$J,"CLAIM",IBCLM,"D",10,$O(^TMP("IBMSG",$J,"CLAIM",IBCLM,"D",10,""),-1)+1)="##RAW DATA: "_IBD
     135 . S IBD("LINE")=$G(IBD("LINE"))+CT
     136 Q
     137 ;
     13815(IBD) ; Process subscriber/patient data
     139 ; Claim must have been referenced by a previous '10' level
     140 ; INPUT:
     141 ;   IBD must be passed by reference = entire message line
     142 ;
     143 ; OUTPUT:
     144 ;      IBD("LINE") = The last line # populated in the message
     145 ;
     146 ;     ^TMP("IBMSG",$J,"CLAIM",claim #,line#)=formatted service dates
     147 ;                                    ,"D",15,msg seq #)=
     148 ;                                         subscr/patient raw data
     149 ;
     150 N CT,Z,L,LINE,DATA,IBCLM,IBNM,IBNUM,IBDFN
     151 S IBCLM=$$GETCLM($P(IBD,U,2)),CT=0,L=$G(IBD("LINE"))
     152 Q:$S(IBCLM="":1,1:'$D(^TMP("IBMSG",$J,"CLAIM",IBCLM)))
     153 S IBDFN=+$G(^DGCR(+$O(^DGCR(399,"B",IBCLM,0)),0))
     154 S IBNM=$S($P(IBD,U,3)'="":$P(IBD,U,3)_","_$P(IBD,U,4)_$S($P(IBD,U,5)'="":" "_$P(IBD,U,5),1:""),1:$P($G(^DPT(IBDFN,0)),U))
     155 S IBNUM=$S($P(IBD,U,6)'="":$P(IBD,U,6),1:$P($G(^DPT(IBDFN,0)),U,9))
     156 S CT=CT+1,LINE(CT)="Patient: "_IBNM_"   "_IBNUM
     157 I $P(IBD,U,11) D
     158 . S DATA=$$DATE($P(IBD,U,11)),CT=CT+1
     159 . S LINE(CT)="Service Dates: "_DATA_" - "_$S($P(IBD,U,12):$$DATE($P(IBD,U,12)),1:DATA)_"  "
     160 . ; Add additional lines of display data here for record 15
     161 S Z=0 F  S Z=$O(LINE(Z)) Q:'Z  S L=L+1,^TMP("IBMSG",$J,"CLAIM",IBCLM,L)=LINE(Z)
     162 S ^TMP("IBMSG",$J,"CLAIM",IBCLM,"D",15,$O(^TMP("IBMSG",$J,"CLAIM",IBCLM,"D",15,""),-1)+1)="##RAW DATA: "_IBD
     163 S IBD("LINE")=$G(IBD("LINE"))+CT
     164 Q
     165 ;
     16620(IBD) ; Process service line status data
     167 ; Claim must have been referenced by a previous '10' level
     168 ; INPUT:
     169 ;   IBD must be passed by reference = entire message line
     170 ; OUTPUT:
     171 ;   IBD array returned with processed data
     172 ;      "LINE" = The last line # populated in the message
     173 ;      "TYPE" = The msg type of status record (Confirmation/rejection)
     174 ;             Note: returned if not already set at batch or claim level
     175 ;
     176 ;   ^TMP("IBMSG",$J,"CLAIM",claim #)=""
     177 ;                                  ,line#)=service line status msg lines
     178 ;                                  ,"D",20,msg seq #)=
     179 ;                                       service line status raw data
     180 ;
     181 N CT,DATA,L,LINE,Z,IBCLM,IBLNUM
     182 S IBCLM=$$GETCLM($P(IBD,U,2)),IBLNUM=$P(IBD,U,8)
     183 Q:'$D(^TMP("IBMSG",$J,"CLAIM",IBCLM))
     184 S CT=0
     185 I IBLNUM'="" S CT=CT+1,LINE(CT)="Claim Line: "_IBLNUM,^TMP("IBMSG",$J,"LINE",IBCLM,IBLNUM)=""
     186 S DATA=$P(IBD,U,4)
     187 I DATA'="",$TR($P(IBD,U,5,7),U)'="" S:'CT CT=CT+1 S LINE(CT)=$S(DATA="W":"Warning",DATA="E":"Error",1:"Informational")_"  "_$G(LINE(CT))
     188 S:$G(IBD("TYPE"))="" IBD("TYPE")=$S(DATA="E":"837REJ1",1:"837REC1")
     189 I $P(IBD,U,5)'="" S:'CT CT=CT+1 S LINE(CT)=LINE(CT)_$P(IBD,U,5)
     190 I $P(IBD,U,6)'="" S CT=CT+1,LINE(CT)="  "_$P(IBD,U,6)
     191 I $P(IBD,U,7)'="" S CT=CT+1,LINE(CT)="  "_$P(IBD,U,7)
     192 I CT D
     193 . S L=$G(IBD("LINE")),Z=0
     194 . F  S Z=$O(LINE(Z)) Q:'Z  S L=L+1,^TMP("IBMSG",$J,"CLAIM",IBCLM,L)=LINE(Z)
     195 . S ^TMP("IBMSG",$J,"CLAIM",IBCLM,"D",20,$O(^TMP("IBMSG",$J,"CLAIM",IBCLM,"D",20,""),-1)+1)="##RAW DATA: "_IBD
     196 . S IBD("LINE")=$G(IBD("LINE"))+CT
     197 Q
     198 ;
     19921(IBD) ; Process service line ID data
     200 ; Moved for size too big
     201 D 21^IBCE277A(IBD)
     202 Q
     203 ;
     204DATE(DT) ; Convert YYMMDD Date into MM/DD/YY or YYYYMMDD into MM/DD/YYYY
     205 N D,Y
     206 S D=DT,Y=""
     207 I $L(DT)=8 S D=$E(DT,3,8),Y=$E(DT,1,2)
     208 Q ($E(D,3,4)_"/"_$E(D,5,6)_"/"_Y_$E(D,1,2))
     209 ;
     210GETCLM(X) ; Extract the claim # without site id from the data in X
     211 N IBCLM
     212 S IBCLM=$P(X,"-",2)
     213 I IBCLM="",X'="" S IBCLM=$E(X,$S($L(X)>7:4,1:1),$L(X))
     214 ;S IBCLM=$E(X,$L(IBCLM)-6,$L(IBCLM)) ; Only take last 7 char
     215 Q IBCLM
     216 ;

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCE835.m

    r613 r623  
    1 IBCE835 ;ALB/TMP - 835 EDI EXPLANATION OF BENEFITS MSG PROCESSING ;19-JAN-99
    2         ;;2.0;INTEGRATED BILLING;**137,135,155,377**;21-MAR-94;Build 23
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5         Q
    6         ;
    7         ; MESSAGE HEADER DATA STRING =
    8         ;   type of message^msg queue^msg #^bill #^^date/time
    9         ;
    10 HDR(IBCLNO,IBD) ;Process header data
    11         ; INPUT:
    12         ;   IBCLNO = claim #
    13         ;
    14         ;   ^TMP("IBMSGH",$J,0) = header message text
    15         ;
    16         ; OUTPUT:
    17         ;   IBD array returned with processed data
    18         ;      "LINE"  = The last line # populated in the message
    19         ;      "DATE"  = Date/Time of EOB (Fileman format)
    20         ;      "MRA"   = 1 if MRA, 0 if not
    21         ;      "X12"   = 1 if X12, 0 if not
    22         ;
    23         ;   ^TMP("IBMSG",$J,"CLAIM",claim #,0)=MESSAGE HEADER DATA STRING
    24         ;                                  ,"D",0,1)=header record raw data
    25         ;                                  ,"D1",1,0)=header record raw data
    26         ;                                  ,line #)=EOB message lines
    27         ;
    28         N CT,IB399,IBD0,IBBILL,LINE,L,X,Y,Z,%DT
    29         S IBD0=$G(^TMP("IBMSGH",$J,0)),IBD("LINE")=0
    30         Q:IBD0=""
    31         S X=$P(IBD0,U,3),X=$E(X,5,8)_$E(X,1,4)_"@"_$P(IBD0,U,4)
    32         I X S %DT="XTS" D ^%DT
    33         S IBD("DATE")=$S(Y>0:Y,1:"")
    34         S IBD("MRA")=$P(IBD0,U,5)
    35         S IBD("X12")=($P(IBD0,U,2)="X")
    36         S CT=0
    37         ;
    38         I $P(IBD0,U,6)'="" S CT=CT+1 S LINE(CT)=$G(LINE(CT))_"Payer Name: "_$P(IBD0,U,6)
    39         ;
    40         I CT D
    41         . S (L,Z)=0
    42         . F  S Z=$O(LINE(Z)) Q:'Z  S L=L+1,^TMP("IBMSG",$J,"CLAIM",IBCLNO,L)=LINE(Z)
    43         . S IBD("LINE")=IBD("LINE")+CT
    44         ;
    45         S IB399=+$O(^DGCR(399,"B",$$GETCLM^IBCE277(IBCLNO),""),-1)
    46         ;
    47         S IBBILL=$$LAST364^IBCEF4(IB399)
    48         ;
    49         S ^TMP("IBMSG",$J,"CLAIM",IBCLNO,0)="835EOB"_U_$G(IBD("MSG#"))_U_$G(IBD("SUBJ"))_U_IBBILL_U_U_IBD("DATE")
    50         ;
    51         S ^TMP("IBMSG",$J,"CLAIM",IBCLNO,"D",0,1)="##RAW DATA: "_IBD0
    52         S ^TMP("IBMSG",$J,"CLAIM",IBCLNO,"D1",1,0)="##RAW DATA: "_IBD0
    53         Q
    54         ;
    55 5(IBD)  ; Process claim patient ID data
    56         ; INPUT:
    57         ;   IBD must be passed by reference = entire message line
    58         ;
    59         ; OUTPUT:
    60         ;   IBD array
    61         ;      "LINE" = the last line # populated in the message
    62         ;
    63         ;   ^TMP("IBMSG",$J,"CLAIM",claim #,line#)=claim pt id message lines
    64         ;                                  ,"D",5,msg seq #)=
    65         ;                                  ,"D1",msg seq #,5)=
    66         ;                                       claim pt id message raw data
    67         ;
    68         N IBBILL
    69         S IBBILL=$$GETCLM^IBCE277($P(IBD,U,2))
    70         ;
    71         I '$D(^TMP("IBMSG",$J,"CLAIM",IBBILL)) D HDR(IBBILL,.IBD) ;Process header data if not already done for claim
    72         ;
    73         I $P(IBD,U,9) D  ;Statement dates
    74         . S IBD("LINE")=$G(IBD("LINE"))+1
    75         . S ^TMP("IBMSG",$J,"CLAIM",IBBILL,IBD("LINE"))="Statement Dates: "_$$DATE^IBCE277($P(IBD,U,9))_" - "_$$DATE^IBCE277($P(IBD,U,10))
    76         ;
    77         S ^TMP("IBMSG",$J,"CLAIM",IBBILL,"D",5,1)="##RAW DATA: "_IBD
    78         S ^TMP("IBMSG",$J,"CLAIM",IBBILL,"D1",1,5)="##RAW DATA: "_IBD
    79         Q
    80         ;
    81 6(IBD)  ; Process 06 record type for corrected name and/or ID# - IB*2*377 - 1/14/08
    82         NEW IBCLM,Z
    83         S IBCLM=$$GETCLM^IBCE277($P(IBD,U,2))
    84         Q:IBCLM=""
    85         I '$D(^TMP("IBMSG",$J,"CLAIM",IBCLM)) D HDR(IBCLM,.IBD)   ;Process header data if not already done for claim
    86         ;
    87         S Z=$G(IBD("LINE"))
    88         I $P(IBD,U,3)'="" S Z=Z+1,^TMP("IBMSG",$J,"CLAIM",IBCLM,Z)="Corrected Patient Last Name: "_$P(IBD,U,3)
    89         I $P(IBD,U,4)'="" S Z=Z+1,^TMP("IBMSG",$J,"CLAIM",IBCLM,Z)="Corrected Patient First Name: "_$P(IBD,U,4)
    90         I $P(IBD,U,5)'="" S Z=Z+1,^TMP("IBMSG",$J,"CLAIM",IBCLM,Z)="Corrected Patient Middle Name: "_$P(IBD,U,5)
    91         I $P(IBD,U,6)'="" S Z=Z+1,^TMP("IBMSG",$J,"CLAIM",IBCLM,Z)="Corrected Patient ID#: "_$P(IBD,U,6)
    92         S IBD("LINE")=Z
    93         ;
    94         S ^TMP("IBMSG",$J,"CLAIM",IBCLM,"D",6,1)="##RAW DATA: "_IBD
    95         S ^TMP("IBMSG",$J,"CLAIM",IBCLM,"D1",1,6)="##RAW DATA: "_IBD
    96         Q
    97         ;
    98 10(IBD) ; Process claim status data
    99         ; INPUT:
    100         ;   IBD must be passed by reference = entire message line
    101         ;
    102         ; OUTPUT:
    103         ;   IBD array returned with processed data
    104         ;      "CLAIM" = The claim #
    105         ;      "LINE" = The last line # populated in the message
    106         ;
    107         ;   ^TMP("IBMSG",$J,"CLAIM",claim #,line#)=claim status message lines
    108         ;                                  ,"D",10,msg seq #)=
    109         ;                                  ,"D1",msg seq #,10)=
    110         ;                                       claim status raw data
    111         ;
    112         N IBCLM,CT,LINE,L,Z,Z0,IBDATA,IBSTAT
    113         S IBCLM=$$GETCLM^IBCE277($P(IBD,U,2))
    114         Q:IBCLM=""
    115         ;
    116         I '$D(^TMP("IBMSG",$J,"CLAIM",IBCLM)) D HDR(IBCLM,.IBD) ;Process header data if not already done for claim
    117         ;
    118         S CT=0
    119         F Z=3:1:6 I $P(IBD,U,Z)="Y" D  Q  ;Claim status
    120         . S IBSTAT=(Z-2)
    121         . S CT=CT+1,LINE(CT)="CLAIM STATUS: "_$P("PROCESSED^DENIED^PENDED^REVERSAL",U,IBSTAT)
    122         I '$G(IBSTAT) D
    123         . S CT=CT+1,LINE(CT)="CLAIM STATUS: "_$P(IBD,U,7)_" (OTHER)"
    124         ;
    125         I $P(IBD,U,8)'="" D  ;Crossed over info
    126         . S LINE(CT)=LINE(CT)_"  Crossed over to: "_$P(IBD,U,9)_"  "_$P(IBD,U,8)
    127         ;
    128         I CT D
    129         . S L=$G(IBD("LINE")),Z=0
    130         . F  S Z=$O(LINE(Z)) Q:'Z  S L=L+1,^TMP("IBMSG",$J,"CLAIM",IBCLM,L)=LINE(Z)
    131         . S ^TMP("IBMSG",$J,"CLAIM",IBCLM,"D",10,1)="##RAW DATA: "_IBD
    132         . S ^TMP("IBMSG",$J,"CLAIM",IBCLM,"D1",1,10)="##RAW DATA: "_IBD
    133         . S IBD("LINE")=$G(IBD("LINE"))+CT
    134         Q
    135         ;
    136 15(IBD) ; Process claim status data
    137         ; INPUT:
    138         ;   IBD must be passed by reference = entire message line
    139         ;
    140         ; OUTPUT:
    141         ;   IBD array
    142         ;      "LINE" = The last line # populated in the message
    143         ;
    144         ;   ^TMP("IBMSG",$J,"CLAIM",claim #,"D",15,msg seq #)=
    145         ;   ^TMP("IBMSG",$J,"CLAIM",claim #,"D1",msg seq #,15)=
    146         ;                                       claim status raw data
    147         ;
    148         N IBCLM,Z,Z0,IBDATA
    149         S IBCLM=$$GETCLM^IBCE277($P(IBD,U,2))
    150         Q:IBCLM=""
    151         ;
    152         I '$D(^TMP("IBMSG",$J,"CLAIM",IBCLM)) D HDR(IBCLM,.IBD) ;Process header data if not already done for claim
    153         ;
    154         S ^TMP("IBMSG",$J,"CLAIM",IBCLM,"D",15,1)="##RAW DATA: "_IBD
    155         S ^TMP("IBMSG",$J,"CLAIM",IBCLM,"D1",1,15)="##RAW DATA: "_IBD
    156         Q
    157         ;
    158 20(IBD) ; Process claim level adjustment data
    159         ; Claim must have been referenced by a previous '05' level
    160         ;
    161         ; INPUT:
    162         ;   IBD must be passed by reference = entire message line
    163         ;
    164         ; OUTPUT:
    165         ;    IBD("LINE") = The last line # populated in the message
    166         ;   ^TMP("IBMSG",$J,"CLAIM",claim #,line #)=claim level adjustment
    167         ;                                  ,"D",20,seq#)=
    168         ;                                  ,"D1",seq#,20)=
    169         ;                                          claim level adjust. raw data
    170         ;
    171         N IBCLM
    172         S IBCLM=$$GETCLM^IBCE277($P(IBD,U,2))
    173         Q:'$D(^TMP("IBMSG",$J,"CLAIM",IBCLM))
    174         S IBD("LINE")=$G(IBD("LINE"))+1
    175         S ^TMP("IBMSG",$J,"CLAIM",IBCLM,IBD("LINE"))="ADJUSTMENT GROUP: "_$P(IBD,U,3)_"  QTY: "_+$P(IBD,U,6)_", AMT: "_($P(IBD,U,5)/100)
    176         S IBD("LINE")=IBD("LINE")+1
    177         S ^TMP("IBMSG",$J,"CLAIM",IBCLM,IBD("LINE"))="   REASON: ("_$P(IBD,U,4)_")  "_$P(IBD,U,7)
    178         S ^TMP("IBMSG",$J,"CLAIM",IBCLM,"D",20,IBD("LINE"))="##RAW DATA: "_IBD
    179         S ^TMP("IBMSG",$J,"CLAIM",IBCLM,"D1",IBD("LINE"),20)="##RAW DATA: "_IBD
    180         Q
    181         ;
    182 37(IBD) ; Process claim level adjustment data for Inpatient MEDICARE
    183         D 37^IBCE835A(.IBD)
    184         Q
    185         ;
    186 40(IBD) ; Process service line data
    187         D 40^IBCE835A(.IBD)
    188         Q
    189         ;
    190 45(IBD) ; Process service line adjustment data
    191         D 45^IBCE835A(.IBD)
    192         Q
    193         ;
    194 17(IBD) ; Process claim contact data segment
    195         D XX(.IBD,17)
    196         Q
    197         ;
    198 30(IBD) ; Process MEDICARE inpatient adjudication data (part 1)
    199         D XX(.IBD,30)
    200         Q
    201         ;
    202 35(IBD) ; Process MEDICARE inpatient adjudication data (part 2)
    203         D XX(.IBD,35)
    204         Q
    205         ;
    206 41(IBD) ; Process service line data (part 2)
    207         D XX(.IBD,41)
    208         Q
    209         ;
    210 42(IBD) ; Process service line data (part 3)
    211         D XX(.IBD,42)
    212         Q
    213         ;
    214 99(IBD) ; Process trailer record for non-MRA EOB
    215         D XX(.IBD,99)
    216         Q
    217         ;
    218 XX(IBD,IBID)    ; Store non-displayed data nodes in TMP array
    219         ;
    220         ; INPUT:
    221         ;   IBD must be passed by reference = entire message line
    222         ;   IBID = record id for generic store
    223         ;
    224         ; OUTPUT:
    225         ;   ^TMP("IBMSG",$J,"CLAIM",claim #,"D",IBID,msg seq #)=
    226         ;   ^TMP("IBMSG",$J,"CLAIM",claim #,"D1",msg seq #,IBID)=
    227         ;                                       claim status raw data
    228         ;    IBD("LINE") = The last line # populated in the message
    229         ;
    230         N IBCLM
    231         S IBCLM=$$GETCLM^IBCE277($P(IBD,U,2))
    232         ;
    233         S IBD("LINE")=$G(IBD("LINE"))+1
    234         S ^TMP("IBMSG",$J,"CLAIM",IBCLM,"D",IBID,IBD("LINE"))="##RAW DATA: "_IBD
    235         S ^TMP("IBMSG",$J,"CLAIM",IBCLM,"D1",IBD("LINE"),IBID)="##RAW DATA: "_IBD
    236         ;
    237         Q
    238         ;
     1IBCE835 ;ALB/TMP - 835 EDI EXPLANATION OF BENEFITS MSG PROCESSING ;19-JAN-99
     2 ;;2.0;INTEGRATED BILLING;**137,135,155**;21-MAR-94
     3 Q
     4 ;
     5 ; MESSAGE HEADER DATA STRING =
     6 ;   type of message^msg queue^msg #^bill #^^date/time
     7 ;
     8HDR(IBCLNO,IBD) ;Process header data
     9 ; INPUT:
     10 ;   IBCLNO = claim #
     11 ;
     12 ;   ^TMP("IBMSGH",$J,0) = header message text
     13 ;
     14 ; OUTPUT:
     15 ;   IBD array returned with processed data
     16 ;      "LINE"  = The last line # populated in the message
     17 ;      "DATE"  = Date/Time of EOB (Fileman format)
     18 ;      "MRA"   = 1 if MRA, 0 if not
     19 ;      "X12"   = 1 if X12, 0 if not
     20 ;
     21 ;   ^TMP("IBMSG",$J,"CLAIM",claim #,0)=MESSAGE HEADER DATA STRING
     22 ;                                  ,"D",0,1)=header record raw data
     23 ;                                  ,"D1",1,0)=header record raw data
     24 ;                                  ,line #)=EOB message lines
     25 ;
     26 N CT,IB399,IBD0,IBBILL,LINE,L,X,Y,Z,%DT
     27 S IBD0=$G(^TMP("IBMSGH",$J,0)),IBD("LINE")=0
     28 Q:IBD0=""
     29 S X=$P(IBD0,U,3),X=$E(X,5,8)_$E(X,1,4)_"@"_$P(IBD0,U,4)
     30 I X S %DT="XTS" D ^%DT
     31 S IBD("DATE")=$S(Y>0:Y,1:"")
     32 S IBD("MRA")=$P(IBD0,U,5)
     33 S IBD("X12")=($P(IBD0,U,2)="X")
     34 S CT=0
     35 ;
     36 I $P(IBD0,U,6)'="" S CT=CT+1 S LINE(CT)=$G(LINE(CT))_"Payer Name: "_$P(IBD0,U,6)
     37 ;
     38 I CT D
     39 . S (L,Z)=0
     40 . F  S Z=$O(LINE(Z)) Q:'Z  S L=L+1,^TMP("IBMSG",$J,"CLAIM",IBCLNO,L)=LINE(Z)
     41 . S IBD("LINE")=IBD("LINE")+CT
     42 ;
     43 S IB399=+$O(^DGCR(399,"B",$$GETCLM^IBCE277(IBCLNO),""),-1)
     44 ;
     45 S IBBILL=$$LAST364^IBCEF4(IB399)
     46 ;
     47 S ^TMP("IBMSG",$J,"CLAIM",IBCLNO,0)="835EOB"_U_$G(IBD("MSG#"))_U_$G(IBD("SUBJ"))_U_IBBILL_U_U_IBD("DATE")
     48 ;
     49 S ^TMP("IBMSG",$J,"CLAIM",IBCLNO,"D",0,1)="##RAW DATA: "_IBD0
     50 S ^TMP("IBMSG",$J,"CLAIM",IBCLNO,"D1",1,0)="##RAW DATA: "_IBD0
     51 Q
     52 ;
     535(IBD) ; Process claim patient ID data
     54 ; INPUT:
     55 ;   IBD must be passed by reference = entire message line
     56 ;
     57 ; OUTPUT:
     58 ;   IBD array
     59 ;      "LINE" = the last line # populated in the message
     60 ;
     61 ;   ^TMP("IBMSG",$J,"CLAIM",claim #,line#)=claim pt id message lines
     62 ;                                  ,"D",5,msg seq #)=
     63 ;                                  ,"D1",msg seq #,5)=
     64 ;                                       claim pt id message raw data
     65 ;
     66 N IBBILL
     67 S IBBILL=$$GETCLM^IBCE277($P(IBD,U,2))
     68 ;
     69 I '$D(^TMP("IBMSG",$J,"CLAIM",IBBILL)) D HDR(IBBILL,.IBD) ;Process header data if not already done for claim
     70 ;
     71 I $P(IBD,U,7)="Y"!($P(IBD,U,8)="Y") D  ;New patient name or id reported
     72 . ;
     73 . ; Alert to EDI mail group that name or ID has changed
     74 . N XQA,XQAMSG
     75 . S XQA("G.IB EDI")=""
     76 . S XQAMSG="EOB for bill # "_IBBILL_" indicates a new name or id exists for patient"
     77 . D SETUP^XQALERT
     78 . ;
     79 . S IBD("LINE")=$G(IBD("LINE"))+1
     80 . I $P(IBD,U,7)="Y" S ^TMP("IBMSG",$J,"CLAIM",IBBILL,IBD("LINE"))="New patient name: "_$P(IBD,U,3)_","_$P(IBD,U,4)_" "_$P(IBD,U,5)_"  "
     81 . I $P(IBD,U,8)="Y" S ^TMP("IBMSG",$J,"CLAIM",IBBILL,IBD("LINE"))=$G(^TMP("IBMSG",$J,"CLAIM",IBBILL,IBD("LINE")))_"New patient id: "_$P(IBD,U,6)
     82 ;
     83 I $P(IBD,U,9) D  ;Statement dates
     84 . S IBD("LINE")=$G(IBD("LINE"))+1
     85 . S ^TMP("IBMSG",$J,"CLAIM",IBBILL,IBD("LINE"))="Statement Dates: "_$$DATE^IBCE277($P(IBD,U,9))_" - "_$$DATE^IBCE277($P(IBD,U,10))
     86 ;
     87 S ^TMP("IBMSG",$J,"CLAIM",IBBILL,"D",5,1)="##RAW DATA: "_IBD
     88 S ^TMP("IBMSG",$J,"CLAIM",IBBILL,"D1",1,5)="##RAW DATA: "_IBD
     89 Q
     90 ;
     9110(IBD) ; Process claim status data
     92 ; INPUT:
     93 ;   IBD must be passed by reference = entire message line
     94 ;
     95 ; OUTPUT:
     96 ;   IBD array returned with processed data
     97 ;      "CLAIM" = The claim #
     98 ;      "LINE" = The last line # populated in the message
     99 ;
     100 ;   ^TMP("IBMSG",$J,"CLAIM",claim #,line#)=claim status message lines
     101 ;                                  ,"D",10,msg seq #)=
     102 ;                                  ,"D1",msg seq #,10)=
     103 ;                                       claim status raw data
     104 ;
     105 N IBCLM,CT,LINE,L,Z,Z0,IBDATA,IBSTAT
     106 S IBCLM=$$GETCLM^IBCE277($P(IBD,U,2))
     107 Q:IBCLM=""
     108 ;
     109 I '$D(^TMP("IBMSG",$J,"CLAIM",IBCLM)) D HDR(IBCLM,.IBD) ;Process header data if not already done for claim
     110 ;
     111 S CT=0
     112 F Z=3:1:6 I $P(IBD,U,Z)="Y" D  Q  ;Claim status
     113 . S IBSTAT=(Z-2)
     114 . S CT=CT+1,LINE(CT)="CLAIM STATUS: "_$P("PROCESSED^DENIED^PENDED^REVERSAL",U,IBSTAT)
     115 I '$G(IBSTAT) D
     116 . S CT=CT+1,LINE(CT)="CLAIM STATUS: "_$P(IBD,U,7)_" (OTHER)"
     117 ;
     118 I $P(IBD,U,8)'="" D  ;Crossed over info
     119 . S LINE(CT)=LINE(CT)_"  Crossed over to: "_$P(IBD,U,9)_"  "_$P(IBD,U,8)
     120 ;
     121 I CT D
     122 . S L=$G(IBD("LINE")),Z=0
     123 . F  S Z=$O(LINE(Z)) Q:'Z  S L=L+1,^TMP("IBMSG",$J,"CLAIM",IBCLM,L)=LINE(Z)
     124 . S ^TMP("IBMSG",$J,"CLAIM",IBCLM,"D",10,1)="##RAW DATA: "_IBD
     125 . S ^TMP("IBMSG",$J,"CLAIM",IBCLM,"D1",1,10)="##RAW DATA: "_IBD
     126 . S IBD("LINE")=$G(IBD("LINE"))+CT
     127 Q
     128 ;
     12915(IBD) ; Process claim status data
     130 ; INPUT:
     131 ;   IBD must be passed by reference = entire message line
     132 ;
     133 ; OUTPUT:
     134 ;   IBD array
     135 ;      "LINE" = The last line # populated in the message
     136 ;
     137 ;   ^TMP("IBMSG",$J,"CLAIM",claim #,"D",15,msg seq #)=
     138 ;   ^TMP("IBMSG",$J,"CLAIM",claim #,"D1",msg seq #,15)=
     139 ;                                       claim status raw data
     140 ;
     141 N IBCLM,Z,Z0,IBDATA
     142 S IBCLM=$$GETCLM^IBCE277($P(IBD,U,2))
     143 Q:IBCLM=""
     144 ;
     145 I '$D(^TMP("IBMSG",$J,"CLAIM",IBCLM)) D HDR(IBCLM,.IBD) ;Process header data if not already done for claim
     146 ;
     147 S ^TMP("IBMSG",$J,"CLAIM",IBCLM,"D",15,1)="##RAW DATA: "_IBD
     148 S ^TMP("IBMSG",$J,"CLAIM",IBCLM,"D1",1,15)="##RAW DATA: "_IBD
     149 Q
     150 ;
     15120(IBD) ; Process claim level adjustment data
     152 ; Claim must have been referenced by a previous '05' level
     153 ;
     154 ; INPUT:
     155 ;   IBD must be passed by reference = entire message line
     156 ;
     157 ; OUTPUT:
     158 ;    IBD("LINE") = The last line # populated in the message
     159 ;   ^TMP("IBMSG",$J,"CLAIM",claim #,line #)=claim level adjustment
     160 ;                                  ,"D",20,seq#)=
     161 ;                                  ,"D1",seq#,20)=
     162 ;                                          claim level adjust. raw data
     163 ;
     164 N IBCLM
     165 S IBCLM=$$GETCLM^IBCE277($P(IBD,U,2))
     166 Q:'$D(^TMP("IBMSG",$J,"CLAIM",IBCLM))
     167 S IBD("LINE")=$G(IBD("LINE"))+1
     168 S ^TMP("IBMSG",$J,"CLAIM",IBCLM,IBD("LINE"))="ADJUSTMENT GROUP: "_$P(IBD,U,3)_"  QTY: "_+$P(IBD,U,6)_", AMT: "_($P(IBD,U,5)/100)
     169 S IBD("LINE")=IBD("LINE")+1
     170 S ^TMP("IBMSG",$J,"CLAIM",IBCLM,IBD("LINE"))="   REASON: ("_$P(IBD,U,4)_")  "_$P(IBD,U,7)
     171 S ^TMP("IBMSG",$J,"CLAIM",IBCLM,"D",20,IBD("LINE"))="##RAW DATA: "_IBD
     172 S ^TMP("IBMSG",$J,"CLAIM",IBCLM,"D1",IBD("LINE"),20)="##RAW DATA: "_IBD
     173 Q
     174 ;
     17537(IBD) ; Process claim level adjustment data for Inpatient MEDICARE
     176 D 37^IBCE835A(.IBD)
     177 Q
     178 ;
     17940(IBD) ; Process service line data
     180 D 40^IBCE835A(.IBD)
     181 Q
     182 ;
     18345(IBD) ; Process service line adjustment data
     184 D 45^IBCE835A(.IBD)
     185 Q
     186 ;
     18717(IBD) ; Process claim contact data segment
     188 D XX(.IBD,17)
     189 Q
     190 ;
     19130(IBD) ; Process MEDICARE inpatient adjudication data (part 1)
     192 D XX(.IBD,30)
     193 Q
     194 ;
     19535(IBD) ; Process MEDICARE inpatient adjudication data (part 2)
     196 D XX(.IBD,35)
     197 Q
     198 ;
     19941(IBD) ; Process service line data (part 2)
     200 D XX(.IBD,41)
     201 Q
     202 ;
     20342(IBD) ; Process service line data (part 3)
     204 D XX(.IBD,42)
     205 Q
     206 ;
     20799(IBD) ; Process trailer record for non-MRA EOB
     208 D XX(.IBD,99)
     209 Q
     210 ;
     211XX(IBD,IBID) ; Store non-displayed data nodes in TMP array
     212 ;
     213 ; INPUT:
     214 ;   IBD must be passed by reference = entire message line
     215 ;   IBID = record id for generic store
     216 ;
     217 ; OUTPUT:
     218 ;   ^TMP("IBMSG",$J,"CLAIM",claim #,"D",IBID,msg seq #)=
     219 ;   ^TMP("IBMSG",$J,"CLAIM",claim #,"D1",msg seq #,IBID)=
     220 ;                                       claim status raw data
     221 ;    IBD("LINE") = The last line # populated in the message
     222 ;
     223 N IBCLM
     224 S IBCLM=$$GETCLM^IBCE277($P(IBD,U,2))
     225 ;
     226 S IBD("LINE")=$G(IBD("LINE"))+1
     227 S ^TMP("IBMSG",$J,"CLAIM",IBCLM,"D",IBID,IBD("LINE"))="##RAW DATA: "_IBD
     228 S ^TMP("IBMSG",$J,"CLAIM",IBCLM,"D1",IBD("LINE"),IBID)="##RAW DATA: "_IBD
     229 ;
     230 Q
     231 ;

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCE837A.m

    r613 r623  
    1 IBCE837A        ;ALB/TMP - OUTPUT FOR 837 TRANSMISSION - CONTINUED ;8/6/03 10:50am
    2         ;;2.0;INTEGRATED BILLING;**137,191,211,232,296,377**;21-MAR-94;Build 23
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5 UPD(MSGNUM,BATCH,CNT,BILLS,DESC,IBBTYP,IBINS)   ; Upd current batch + bills w/new status
    6         ;MSGNUM = mail msg # for batch
    7         ;BATCH = batch #
    8         ;CNT = # of bills in batch
    9         ;BILLS = array BILLS(bill ien in 364) in batch
    10         ;DESC = 1-80 character description of batch
    11         ;IBBTYP = X-Y where X = P for professional or I for institution
    12         ;                   Y = 1 for test or 0 for live transmission
    13         ;                         or 2 for live claim resubmitted as test
    14         ;IBINS = ien of single insurance company for the batch (optional)
    15         ;
    16         N DIC,DIE,DR,DA,IBBATCH,IBIFN,IBIEN,IBYY,IBTXTEST,IBMRA
    17         S IBBATCH=$O(^IBA(364.1,"B",+BATCH,"")) Q:'IBBATCH
    18         S IBTXTEST=+$P(IBBTYP,"-",2)
    19         I '$P($G(^IBE(350.9,1,8)),U,7) S IBINS=""
    20         ;
    21         S DIE="^IBA(364.1,",DA=IBBATCH,DR=".02////P;.03///"_CNT_";.04///"_MSGNUM_";.05///0;.07////1;.08///^S X="""_DESC_""""_$S($G(IBINS):";.12////"_IBINS,1:"")
    22         ;
    23         I '$P($G(^TMP("IBRESUBMIT",$J)),U,3) S DR=DR_";1.01///NOW;1.02///.5"
    24         I $P($G(^TMP("IBRESUBMIT",$J)),U,2) S DR=DR_";.15////"_$P(^($J),U,2)
    25         ;
    26         S DR=DR_";.14////"_$S('IBTXTEST:0,1:1)_";.06////"_$S($E(IBBTYP)="P":2,1:3) D ^DIE ; Update batch
    27         ;
    28         I IBTXTEST=2 D ADDTXM^IBCEPTM(.BILLS,IBBATCH,$$NOW^XLFDT()) Q
    29         I IBTXTEST'=2 S IBIEN=0 F  S IBIEN=$O(BILLS(IBIEN)) Q:'IBIEN  D  ;Update each bill
    30         .S DA=IBIEN,DIE="^IBA(364,",DR=".02////"_IBBATCH_";.03///P;.04///NOW" D ^DIE
    31         .S IBIFN=+$G(^IBA(364,IBIEN,0))
    32         . ;
    33         . ; If this claim has just been retransmitted, set the .06 field for the previous transmission entry
    34         . N PRVTXI,PRVTXD
    35         . S PRVTXI=$O(^IBA(364,"B",IBIFN,IBIEN),-1)      ; previous transmission for this claim
    36         . I PRVTXI D
    37         .. S PRVTXD=$G(^IBA(364,PRVTXI,0))
    38         .. I '$F(".R.E.","."_$P(PRVTXD,U,3)_".") Q                 ; prev trans must have status of "R" or "E"
    39         .. I $P(PRVTXD,U,7,8)'=$P($G(^IBA(364,IBIEN,0)),U,7,8) Q   ; test bill and COB must be the same
    40         .. S DA=PRVTXI,DIE=364,DR=".06///"_IBBATCH D ^DIE          ; update the resubmit batch number
    41         .. Q
    42         . ;
    43         .Q:$D(^TMP("IBRESUBMIT",$J))!($P($G(^DGCR(399,IBIFN,0)),U,13)=4)!(+$$TXMT^IBCEF4(IBIEN)=2)
    44         .S IBMRA=$$NEEDMRA^IBEFUNC(IBIFN)
    45         .I IBMRA="C",$P($G(^DGCR(399,IBIFN,0)),U,13)=2 S IBMRA=1
    46         .I IBIFN D
    47         ..S (DIC,DIE)="^DGCR(399,",DA=$P($G(^IBA(364,IBIEN,0)),U),DR="[IB STATUS]",IBYY=$S('IBMRA:"@91",1:"@911") D:DA ^DIE
    48         ..D BSTAT^IBCDC(IBIFN) ; remove from AB list
    49         Q
    50         ;
    51 PRE     ; Run before processing a bill entry
    52         K IBXSAVE,IBXERR,^UTILITY("VAPA",$J),^TMP("IBXSAVE",$J),^TMP($J),^TMP("DIERR",$J)
    53         Q
    54         ;
    55 POST    ; Run after processing a bill entry for cleanup
    56         N Q
    57         I $G(IBXERR)'="" D
    58         .S ^TMP("IBXERR",$J,IBXIEN)=IBXERR K ^TMP("IBXDATA",$J)
    59         .K ^TMP("IBHDR1",$J)
    60         .I $D(^TMP("IBRESUBMIT",$J)),'$G(^TMP("IBEDI_TEST_BATCH",$J)) D  ;Set not resub flag for non-test bill
    61         ..N Z,Z0
    62         ..S Z0=$P($G(^TMP("IBRESUBMIT",$J)),U) Q:Z0=""
    63         ..S Z=$O(^IBA(364,"ABABI",+$O(^IBA(364.1,"B",Z0,"")),IBXIEN,""))
    64         ..I Z S ^TMP("IBNOT",$J,Z)=IBXIEN
    65         K IBXSAVE,IBXNOREQ,^TMP("IBXSAVE",$J),^TMP($J)
    66         S Q="VA" F  S Q=$O(^UTILITY(Q)) Q:$E(Q,1,2)'="VA"  I $D(^(Q,$J)) K ^UTILITY(Q,$J)
    67         D CLEAN^DILF
    68         Q
    69         ;
    70 MAILIT(IBQUEUE,IBBILL,IBCTM,IBDUZ,IBDESC,IBBTYP,IBINS)  ; Send mail msg, update bills
    71         ;IBQUEUE = mail queue name to send 837 transactions to
    72         ;IBBILL = array of ien's in file 364 of bills in batch - IBBILL(IEN)=""
    73         ;IBCTM = # of bills in batch, returned reset to 0
    74         ;IBDUZ = ien of user 'running' extract (if any)
    75         ;IBDESC = description of batch
    76         ;IBBTYP = X-Y where X = P for professional or I for institution
    77         ;                   Y = 1 or 2 for test or 0 for live transmission
    78         ;IBINS = ien of insurance company if only one/batch option (optional)
    79         ;
    80         N DIK,DA,XMTO,XMZ,XMBODY,XMDUZ,XMSUBJ,IBBDA,IBBNO
    81         ;
    82         S IBBNO=+$P($G(^TMP("IBHDR",$J)),U),IBBDA=$O(^IBA(364.1,"B",IBBNO,""))
    83         I '$P($G(^IBE(350.9,1,8)),U,7) S IBINS=""
    84         ;
    85         I IBCTM D
    86         . I +$G(^TMP("IBEDI_TEST_BATCH",$J)) S IBQUEUE="MCT"
    87         . I IBQUEUE'="",IBQUEUE'["@" S XMTO("XXX@Q-"_IBQUEUE_".VA.GOV")=""
    88         . I IBQUEUE["@" S XMTO(IBQUEUE)=""
    89         . S XMDUZ=$G(IBDUZ),XMBODY="^TMP(""IBXMSG"","_$J_")",XMSUBJ=$S($P(IBBTYP,U,2):"** TEST"_$S($P(IBBTYP,U,2)=2:"/RESUB OF LIVE",1:""),1:"")_" CLAIM BATCH: "_$S(IBQUEUE'["@":IBQUEUE,1:$P(IBQUEUE,"@"))_"/"_IBBNO
    90         . K XMZ
    91         . D SENDMSG^XMXAPI(XMDUZ,XMSUBJ,XMBODY,.XMTO,,.XMZ)
    92         . I $G(XMZ) D
    93         .. D UPD(XMZ,$P($G(^TMP("IBHDR",$J)),U),IBCTM,.IBBILL,IBDESC,IBBTYP,IBINS) ;Update batch/bills
    94         .. S ^TMP("IBCE-BATCH",$J,IBBNO)=IBBDA_U_IBCTM_U_$P($G(^TMP("IBRESUBMIT",$J)),U)
    95 MAILQ   S IBCTM=0
    96         D CHKBTCH(+$G(^TMP("IBHDR",$J)))
    97         K ^TMP("IBHDR",$J),^TMP("IBHDR1",$J),^TMP("IBXMSG",$J),IBBILL
    98         Q
    99         ;
    100 CHKNEW(IBQ,IBBILL,IBCTM,IBDESC,IBBTYP,IBINS,IBSITE,IBSIZE)      ;
    101         ;  Determine if ok to send msg
    102         ;  Check for one insurance per batch if IBINS defined
    103         ; Returns IBSIZE, IBCTM, IBBILL (pass by reference)
    104         ;
    105         ; IBQ = data queue name
    106         ; IBBILL = the 'list' of bill #'s in the batch
    107         ; IBCTM = the # of claims output so far to the batch
    108         ; IBDESC = the batch description text
    109         ; IBBTYP = X-Y where X = P for professional or I for institution
    110         ;                   Y = 1 for test or 0 for live transmission
    111         ; IBINS = the ien of the single insurance co. for the batch (optional)
    112         ; IBSITE = the '8' node of file 350.9 (IB PARAMETERS)
    113         ; IBSIZE = the 'running' size of the output message
    114         ;
    115         Q:$S($G(IBINS)="":0,1:'$P(IBSITE,U,7))
    116         ;
    117         ; New batch needed
    118         I IBCTM D MAILIT(IBQ,.IBBILL,.IBCTM,"",IBDESC,IBBTYP,IBINS) S IBSIZE=0
    119         Q
    120         ;
    121 ERRMSG(XMBODY)  ; Send bulletin for error message
    122         N XMTO,XMSUBJ
    123         S XMTO("I:G.IB EDI")="",XMSUBJ="EDI 837 TRANSMISSION ERRORS"
    124         ;
    125         D SENDMSG^XMXAPI(,XMSUBJ,XMBODY,.XMTO)
    126         D ALERT("One or more EDI bills were not transmitted.  Check your mail for details","G.IB EDI")
    127         Q
    128         ;
    129 CLEANUP ; Cleans up bill transmission environment
    130         ;
    131         N IBTEST
    132         S IBTEST=+$G(^TMP("IBEDI_TEST_BATCH",$J))
    133         L -^IBA(364,0)
    134         I $D(^TMP("IBRESUBMIT",$J,"IBXERR"))!$D(^TMP("IBONE",$J,"IBXERR"))!$D(^TMP("IBSELX",$J,"IBXERR")) D  ;Error message to mail group
    135         . N XMTO,XMBODY,XMDUZ,XMSUBJ,XMZ,IBFUNC
    136         . S IBFUNC=$S($D(^TMP("IBRESUBMIT",$J,"IBXERR")):$S('IBTEST:1,1:4),$D(^TMP("IBONE",$J,"IBXERR")):2,1:3)
    137         . Q:'IBFUNC
    138         . S XMTO("I:G.IB EDI")="",XMDUZ="",XMBODY="^TMP("""_$S(IBFUNC=1!(IBFUNC=4):"IBRESUBMIT",1:"IBONE")_""","_$J_",""IBXERR"")"
    139         . S XMSUBJ="EDI 837 B"_$P("ATCH^ILL^ILL(s)^ILL(s)",U,IBFUNC)_" NOT "_$S($G(^TMP("IBONE",$J)):"RE",1:"")_"SUBMITTED"_$S('IBTEST:"",1:" AS TEST CLAIMS")
    140         . D SENDMSG^XMXAPI(XMDUZ,XMSUBJ,XMBODY,.XMTO,,.XMZ)
    141         . K ^TMP("IBRESUBMIT",$J),^TMP("IBONE",$J)
    142         ;
    143         I $D(^TMP("IBRESUBMIT",$J)),'IBTEST D RESUBUP^IBCEM02 ;Upd resubmtd batch bills
    144         I '$D(^TMP("IBSELX",$J)) K ^TMP("IBCE-BATCH",$J)
    145         K ^TMP("IBXERR",$J),IBXERR
    146         I 'IBTEST D CHKBTCH(+$G(^TMP("IBHDR",$J)))
    147 CLEANP  ;  Entrypoint for extract data disply
    148         K ^TMP("IBTXMT",$J),^TMP("IBXINS",$J)
    149         K ^TMP("IBRESUBMIT",$J),^TMP("IBRESUB",$J),^TMP("IBNOT",$J),^TMP("IBONE",$J),^TMP("IBHDR",$J),^TMP("IBTX",$J),^TMP("IBEDI_TEST_BATCH",$J)
    150         K ^UTILITY("VADM",$J)
    151         D CLEAN^DILF
    152         K ZTREQ S ZTREQ="@"
    153         Q
    154         ;
    155 ALERT(XQAMSG,IBGRP)     ; Send alert message
    156         N XQA
    157         S XQA(IBGRP)=""
    158         D SETUP^XQALERT
    159         Q
    160 CHKBTCH(IBBNO)  ; Delete batch whose batch # is IBBNO if no entries in file 364
    161         ; and not a resubmitted batch
    162         N IBZ,DA,DIK
    163         S IBZ=+$O(^IBA(364.1,"B",+IBBNO,""))
    164         I IBZ,'$O(^IBA(364,"C",IBZ,0)),'$P($G(^IBA(364.1,IBZ,0)),U,14) S DA=IBZ,DIK="^IBA(364.1," D ^DIK
    165         Q
    166         ;
    167 TESTLIM(IBINS)  ; Check for test bill limit per day has been reached
    168         N IB3,DA,DIK
    169         S IB3=$G(^DIC(36,IBINS,3))
    170         I $P(IB3,U,5)'=DT S $P(IB3,U,7)=0
    171         I ($P(IB3,U,7)+$G(^TMP("IBICT",$J,IBINS))+1)>$P(IB3,U,6) D  Q
    172         . S IBINS="" ;max # hit
    173         . S DA=IBX,DIK="^IBA(364," D ^DIK
    174         S ^TMP("IBICT",$J,IBINS)=$G(^TMP("IBICT",$J,IBINS))+1
    175         Q
    176         ;
    177 SETVAR(IBXIEN,IBINS,IB0,IBSEC,IBNID,IB837R,IBDIV)       ;
    178         ; Set up variables needed for subscripts in sort global
    179         ; ejk added IBSEC logic for patch 296
    180         ; IBSEC=1 if primary bill, 2 if 2nd/non-MRA, 3 if 2nd/MRA
    181         S IBSEC=$S($$COBN^IBCEF(IBXIEN)=1:1,'$$MRASEC^IBCEF4(IBXIEN):2,1:3)
    182         S IBNID=$$PAYERID^IBCEF2(IBXIEN)
    183         S IB837R=$$RECVR^IBCEF2(IBXIEN)
    184         S IBDIV=$P($S($P(IB0,U,22):$$SITE^VASITE(DT,$P(IB0,U,22)),1:$$SITE^VASITE()),U,3)
    185         I IBNID'="","RPIHS"[$E(IBNID),$E(IBNID,2,$L(IBNID))="PRNT" S IBNID=IBNID_"*"_IBINS
    186         I IBNID="" S IBNID="*"_IBINS
    187         S $P(IBNID,"*",3)=$S($P(IB0,U,22):$P(IB0,U,22),1:"")
    188         Q
    189         ;
     1IBCE837A ;ALB/TMP - OUTPUT FOR 837 TRANSMISSION - CONTINUED ;8/6/03 10:50am
     2 ;;2.0;INTEGRATED BILLING;**137,191,211,232,296**;21-MAR-94
     3 ;
     4UPD(MSGNUM,BATCH,CNT,BILLS,DESC,IBBTYP,IBINS) ; Upd current batch + bills w/new status
     5 ;MSGNUM = mail msg # for batch
     6 ;BATCH = batch #
     7 ;CNT = # of bills in batch
     8 ;BILLS = array BILLS(bill ien in 364) in batch
     9 ;DESC = 1-80 character description of batch
     10 ;IBBTYP = X-Y where X = P for professional or I for institution
     11 ;                   Y = 1 for test or 0 for live transmission
     12 ;                         or 2 for live claim resubmitted as test
     13 ;IBINS = ien of single insurance company for the batch (optional)
     14 ;
     15 N DIC,DIE,DR,DA,IBBATCH,IBIFN,IBIEN,IBYY,IBTXTEST,IBMRA
     16 S IBBATCH=$O(^IBA(364.1,"B",+BATCH,"")) Q:'IBBATCH
     17 S IBTXTEST=+$P(IBBTYP,"-",2)
     18 I '$P($G(^IBE(350.9,1,8)),U,7) S IBINS=""
     19 ;
     20 S DIE="^IBA(364.1,",DA=IBBATCH,DR=".02////P;.03///"_CNT_";.04///"_MSGNUM_";.05///0;.07////1;.08///^S X="""_DESC_""""_$S($G(IBINS):";.12////"_IBINS,1:"")
     21 ;
     22 I '$P($G(^TMP("IBRESUBMIT",$J)),U,3) S DR=DR_";1.01///NOW;1.02///.5"
     23 I $P($G(^TMP("IBRESUBMIT",$J)),U,2) S DR=DR_";.15////"_$P(^($J),U,2)
     24 ;
     25 S DR=DR_";.14////"_$S('IBTXTEST:0,1:1)_";.06////"_$S($E(IBBTYP)="P":2,1:3) D ^DIE ; Update batch
     26 ;
     27 I IBTXTEST=2 D ADDTXM^IBCEPTM(.BILLS,IBBATCH,$$NOW^XLFDT()) Q
     28 I IBTXTEST'=2 S IBIEN=0 F  S IBIEN=$O(BILLS(IBIEN)) Q:'IBIEN  D  ;Update each bill
     29 .S DA=IBIEN,DIE="^IBA(364,",DR=".02////"_IBBATCH_";.03///P;.04///NOW" D ^DIE
     30 .S IBIFN=+$G(^IBA(364,IBIEN,0))
     31 .Q:$D(^TMP("IBRESUBMIT",$J))!($P($G(^DGCR(399,IBIFN,0)),U,13)=4)!(+$$TXMT^IBCEF4(IBIEN)=2)
     32 .S IBMRA=$$NEEDMRA^IBEFUNC(IBIFN)
     33 .I IBMRA="C",$P($G(^DGCR(399,IBIFN,0)),U,13)=2 S IBMRA=1
     34 .I IBIFN D
     35 ..S (DIC,DIE)="^DGCR(399,",DA=$P($G(^IBA(364,IBIEN,0)),U),DR="[IB STATUS]",IBYY=$S('IBMRA:"@91",1:"@911") D:DA ^DIE
     36 ..D BSTAT^IBCDC(IBIFN) ; remove from AB list
     37 Q
     38 ;
     39PRE ; Run before processing a bill entry
     40 K IBXSAVE,IBXERR,^UTILITY("VAPA",$J),^TMP("IBXSAVE",$J),^TMP($J),^TMP("DIERR",$J)
     41 Q
     42 ;
     43POST ; Run after processing a bill entry for cleanup
     44 N Q
     45 I $G(IBXERR)'="" D
     46 .S ^TMP("IBXERR",$J,IBXIEN)=IBXERR K ^TMP("IBXDATA",$J)
     47 .K ^TMP("IBHDR1",$J)
     48 .I $D(^TMP("IBRESUBMIT",$J)),'$G(^TMP("IBEDI_TEST_BATCH",$J)) D  ;Set not resub flag for non-test bill
     49 ..N Z,Z0
     50 ..S Z0=$P($G(^TMP("IBRESUBMIT",$J)),U) Q:Z0=""
     51 ..S Z=$O(^IBA(364,"ABABI",+$O(^IBA(364.1,"B",Z0,"")),IBXIEN,""))
     52 ..I Z S ^TMP("IBNOT",$J,Z)=IBXIEN
     53 K IBXSAVE,IBXNOREQ,^TMP("IBXSAVE",$J),^TMP($J)
     54 S Q="VA" F  S Q=$O(^UTILITY(Q)) Q:$E(Q,1,2)'="VA"  I $D(^(Q,$J)) K ^UTILITY(Q,$J)
     55 D CLEAN^DILF
     56 Q
     57 ;
     58MAILIT(IBQUEUE,IBBILL,IBCTM,IBDUZ,IBDESC,IBBTYP,IBINS) ; Send mail msg, update bills
     59 ;IBQUEUE = mail queue name to send 837 transactions to
     60 ;IBBILL = array of ien's in file 364 of bills in batch - IBBILL(IEN)=""
     61 ;IBCTM = # of bills in batch, returned reset to 0
     62 ;IBDUZ = ien of user 'running' extract (if any)
     63 ;IBDESC = description of batch
     64 ;IBBTYP = X-Y where X = P for professional or I for institution
     65 ;                   Y = 1 or 2 for test or 0 for live transmission
     66 ;IBINS = ien of insurance company if only one/batch option (optional)
     67 ;
     68 N DIK,DA,XMTO,XMZ,XMBODY,XMDUZ,XMSUBJ,IBBDA,IBBNO
     69 ;
     70 S IBBNO=+$P($G(^TMP("IBHDR",$J)),U),IBBDA=$O(^IBA(364.1,"B",IBBNO,""))
     71 I '$P($G(^IBE(350.9,1,8)),U,7) S IBINS=""
     72 ;
     73 I IBCTM D
     74 . I +$G(^TMP("IBEDI_TEST_BATCH",$J)) S IBQUEUE="MCT"
     75 . I IBQUEUE'="",IBQUEUE'["@" S XMTO("XXX@Q-"_IBQUEUE_".VA.GOV")=""
     76 . I IBQUEUE["@" S XMTO(IBQUEUE)=""
     77 . S XMDUZ=$G(IBDUZ),XMBODY="^TMP(""IBXMSG"","_$J_")",XMSUBJ=$S($P(IBBTYP,U,2):"** TEST"_$S($P(IBBTYP,U,2)=2:"/RESUB OF LIVE",1:""),1:"")_" CLAIM BATCH: "_$S(IBQUEUE'["@":IBQUEUE,1:$P(IBQUEUE,"@"))_"/"_IBBNO
     78 . K XMZ
     79 . D SENDMSG^XMXAPI(XMDUZ,XMSUBJ,XMBODY,.XMTO,,.XMZ)
     80 . I $G(XMZ) D
     81 .. D UPD(XMZ,$P($G(^TMP("IBHDR",$J)),U),IBCTM,.IBBILL,IBDESC,IBBTYP,IBINS) ;Update batch/bills
     82 .. S ^TMP("IBCE-BATCH",$J,IBBNO)=IBBDA_U_IBCTM_U_$P($G(^TMP("IBRESUBMIT",$J)),U)
     83MAILQ S IBCTM=0
     84 D CHKBTCH(+$G(^TMP("IBHDR",$J)))
     85 K ^TMP("IBHDR",$J),^TMP("IBHDR1",$J),^TMP("IBXMSG",$J),IBBILL
     86 Q
     87 ;
     88CHKNEW(IBQ,IBBILL,IBCTM,IBDESC,IBBTYP,IBINS,IBSITE,IBSIZE) ;
     89 ;  Determine if ok to send msg
     90 ;  Check for one insurance per batch if IBINS defined
     91 ; Returns IBSIZE, IBCTM, IBBILL (pass by reference)
     92 ;
     93 ; IBQ = data queue name
     94 ; IBBILL = the 'list' of bill #'s in the batch
     95 ; IBCTM = the # of claims output so far to the batch
     96 ; IBDESC = the batch description text
     97 ; IBBTYP = X-Y where X = P for professional or I for institution
     98 ;                   Y = 1 for test or 0 for live transmission
     99 ; IBINS = the ien of the single insurance co. for the batch (optional)
     100 ; IBSITE = the '8' node of file 350.9 (IB PARAMETERS)
     101 ; IBSIZE = the 'running' size of the output message
     102 ;
     103 Q:$S($G(IBINS)="":0,1:'$P(IBSITE,U,7))
     104 ;
     105 ; New batch needed
     106 I IBCTM D MAILIT(IBQ,.IBBILL,.IBCTM,"",IBDESC,IBBTYP,IBINS) S IBSIZE=0
     107 Q
     108 ;
     109ERRMSG(XMBODY) ; Send bulletin for error message
     110 N XMTO,XMSUBJ
     111 S XMTO("I:G.IB EDI")="",XMSUBJ="EDI 837 TRANSMISSION ERRORS"
     112 ;
     113 D SENDMSG^XMXAPI(,XMSUBJ,XMBODY,.XMTO)
     114 D ALERT("One or more EDI bills were not transmitted.  Check your mail for details","G.IB EDI")
     115 Q
     116 ;
     117CLEANUP ; Cleans up bill transmission environment
     118 ;
     119 N IBTEST
     120 S IBTEST=+$G(^TMP("IBEDI_TEST_BATCH",$J))
     121 L -^IBA(364,0)
     122 I $D(^TMP("IBRESUBMIT",$J,"IBXERR"))!$D(^TMP("IBONE",$J,"IBXERR"))!$D(^TMP("IBSELX",$J,"IBXERR")) D  ;Error message to mail group
     123 . N XMTO,XMBODY,XMDUZ,XMSUBJ,XMZ,IBFUNC
     124 . S IBFUNC=$S($D(^TMP("IBRESUBMIT",$J,"IBXERR")):$S('IBTEST:1,1:4),$D(^TMP("IBONE",$J,"IBXERR")):2,1:3)
     125 . Q:'IBFUNC
     126 . S XMTO("I:G.IB EDI")="",XMDUZ="",XMBODY="^TMP("""_$S(IBFUNC=1!(IBFUNC=4):"IBRESUBMIT",1:"IBONE")_""","_$J_",""IBXERR"")"
     127 . S XMSUBJ="EDI 837 B"_$P("ATCH^ILL^ILL(s)^ILL(s)",U,IBFUNC)_" NOT "_$S($G(^TMP("IBONE",$J)):"RE",1:"")_"SUBMITTED"_$S('IBTEST:"",1:" AS TEST CLAIMS")
     128 . D SENDMSG^XMXAPI(XMDUZ,XMSUBJ,XMBODY,.XMTO,,.XMZ)
     129 . K ^TMP("IBRESUBMIT",$J),^TMP("IBONE",$J)
     130 ;
     131 I $D(^TMP("IBRESUBMIT",$J)),'IBTEST D RESUBUP^IBCEM02 ;Upd resubmtd batch bills
     132 I '$D(^TMP("IBSELX",$J)) K ^TMP("IBCE-BATCH",$J)
     133 K ^TMP("IBXERR",$J),IBXERR
     134 I 'IBTEST D CHKBTCH(+$G(^TMP("IBHDR",$J)))
     135CLEANP ;  Entrypoint for extract data disply
     136 K ^TMP("IBTXMT",$J),^TMP("IBXINS",$J)
     137 K ^TMP("IBRESUBMIT",$J),^TMP("IBRESUB",$J),^TMP("IBNOT",$J),^TMP("IBONE",$J),^TMP("IBHDR",$J),^TMP("IBTX",$J),^TMP("IBEDI_TEST_BATCH",$J)
     138 K ^UTILITY("VADM",$J)
     139 D CLEAN^DILF
     140 K ZTREQ S ZTREQ="@"
     141 Q
     142 ;
     143ALERT(XQAMSG,IBGRP) ; Send alert message
     144 N XQA
     145 S XQA(IBGRP)=""
     146 D SETUP^XQALERT
     147 Q
     148CHKBTCH(IBBNO) ; Delete batch whose batch # is IBBNO if no entries in file 364
     149 ; and not a resubmitted batch
     150 N IBZ,DA,DIK
     151 S IBZ=+$O(^IBA(364.1,"B",+IBBNO,""))
     152 I IBZ,'$O(^IBA(364,"C",IBZ,0)),'$P($G(^IBA(364.1,IBZ,0)),U,14) S DA=IBZ,DIK="^IBA(364.1," D ^DIK
     153 Q
     154 ;
     155TESTLIM(IBINS) ; Check for test bill limit per day has been reached
     156 N IB3,DA,DIK
     157 S IB3=$G(^DIC(36,IBINS,3))
     158 I $P(IB3,U,5)'=DT S $P(IB3,U,7)=0
     159 I ($P(IB3,U,7)+$G(^TMP("IBICT",$J,IBINS))+1)>$P(IB3,U,6) D  Q
     160 . S IBINS="" ;max # hit
     161 . S DA=IBX,DIK="^IBA(364," D ^DIK
     162 S ^TMP("IBICT",$J,IBINS)=$G(^TMP("IBICT",$J,IBINS))+1
     163 Q
     164 ;
     165SETVAR(IBXIEN,IBINS,IB0,IBSEC,IBNID,IB837R,IBDIV) ;
     166 ; Set up variables needed for subscripts in sort global
     167 ; ejk added IBSEC logic for patch 296
     168 ; IBSEC=1 if primary bill, 2 if 2nd/non-MRA, 3 if 2nd/MRA
     169 S IBSEC=$S($$COBN^IBCEF(IBXIEN)=1:1,'$$MRASEC^IBCEF4(IBXIEN):2,1:3)
     170 S IBNID=$$PAYERID^IBCEF2(IBXIEN)
     171 S IB837R=$$RECVR^IBCEF2(IBXIEN)
     172 S IBDIV=$P($S($P(IB0,U,22):$$SITE^VASITE(DT,$P(IB0,U,22)),1:$$SITE^VASITE()),U,3)
     173 I IBNID'="","RPIHS"[$E(IBNID),$E(IBNID,2,$L(IBNID))="PRNT" S IBNID=IBNID_"*"_IBINS
     174 I IBNID="" S IBNID="*"_IBINS
     175 S $P(IBNID,"*",3)=$S($P(IB0,U,22):$P(IB0,U,22),1:"")
     176 Q
     177 ;

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEBUL.m

    r613 r623  
    1 IBCEBUL ;ALB/TMP - 837 EDI SPECIAL BULLETINS PROCESSING ;19-SEP-96
    2         ;;2.0;INTEGRATED BILLING;**137,250,377**;21-MAR-94;Build 23
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5 NOTSENT ; Check for batches in pending status (no confirmation from Austin)
    6         ;  from yesterday or before
    7         N XMTO,XMSUBJ,XMBODY,XMDUZ,IBT,IB,IBE,IBCT,IBI,IB0,IB1,Z,IBTYP
    8         K ^TMP($J,"IBNOTSENT")
    9         S (IBCT,IBI)=0
    10         F  S IBI=$O(^IBA(364.1,"ASTAT","P",IBI)) Q:'IBI  D
    11         . I $$BCHCHK(IBI) Q    ; Batch check function
    12         . S IBCT=IBCT+1
    13         . S IBTYP=$P($G(^IBA(364.1,IBI,0)),U,7)
    14         . I IBCT'>10,IBTYP'="" S ^TMP($J,"IBNOTSENT",IBTYP,IBI)=""
    15         . Q
    16         ;
    17         I IBCT D
    18         .S IBT(1)="There are "_IBCT_" EDI batch(es) still pending Austin receipt "
    19         .S IBT(2)="for more than 1 day.  Please investigate why they have not yet been confirmed"
    20         .S IBT(3)="as being received by Austin."
    21         .S IBT(4)=" "
    22         .I IBCT>10 S IBT(5)="Since there were more than 10 batches found, please run the ",IBT(6)="  EDI BATCHES PENDING RECEIPT report to get a list of these batches."
    23         .I IBCT'>10 D
    24         ..S IBT(5)="      BATCH #      PENDING SINCE             MAIL MESSAGE #",IBT(6)="",$P(IBT(6),"-",76)="",IBT(6)="  "_IBT(6),IBE=6
    25         ..S IBTYP=""
    26         ..F  S IBTYP=$O(^TMP($J,"IBNOTSENT",IBTYP)) Q:IBTYP=""  D
    27         ...S Z=$$EXPAND^IBTRE(364.1,.07,IBTYP) S:Z="" Z="??"
    28         ...I $O(^TMP($J,"IBNOTSENT",IBTYP),-1)'="" S IBE=IBE+1,IBT(IBE)=" "
    29         ...S IBE=IBE+1,IBT(IBE)="  BATCH TYPE: "_Z
    30         ...S IBI=0 F  S IBI=$O(^TMP($J,"IBNOTSENT",IBTYP,IBI)) Q:'IBI  D
    31         ....S IBE=IBE+1,IB0=$G(^IBA(364.1,IBI,0)),IB1=$G(^(1))
    32         ....S IBT(IBE)="      "_$E($P(IB0,U)_$J("",10),1,10)_"   "_$E($$FMTE^XLFDT($P(IB1,U,6),1)_$J("",20),1,20)_"      "_$P(IB0,U,4),IBE=IBE+1,IBT(IBE)=$J("",8)_$E($P(IB0,U,8),1,72)
    33         .S XMSUBJ="EDI BATCHES WAITING AUSTIN RECEIPT FOR OVER 1 DAY",XMBODY="IBT",XMDUZ="",XMTO("I:G.IB EDI")=""
    34         .D SENDMSG^XMXAPI(XMDUZ,XMSUBJ,XMBODY,.XMTO)
    35         K ^TMP($J,"IBNOTSENT")
    36         Q
    37         ;
    38 UPDBCH(BCHIEN)  ; update the status of this batch to show A0:received in Austin
    39         NEW DIE,DA,DR
    40         S DIE=364.1,DA=+BCHIEN,DR=".02///A0"
    41         I $D(^IBA(DIE,DA,0)) D ^DIE
    42 UPDBCHX ;
    43         Q
    44         ;
    45 BCHCHK(BCHIEN)  ; This function will check the EDI claims associated with this
    46         ; batch and determine if this batch has been received in Austin or not.
    47         ;
    48         ; ** This function is also called by routine IBCERP3 **
    49         ;
    50         ; Function value = 1 if we can determine that the batch was received in Austin, or
    51         ;                = 1 if there are no claims in this batch, or
    52         ;                = 1 if the batch is less than 24 hours old - too new to worry about
    53         ;                = 1 means don't display on report or MailMan message
    54         ;
    55         ; Function value = 0 if the batch has not yet been received in Austin
    56         ;                = 0 means we need to display batch on report and in MailMan message
    57         ;
    58         NEW IBEDI,IBOK,IBZ,IBIFN,IB0,AR,IBSECS
    59         S IBEDI=0,IBOK=1,BCHIEN=+$G(BCHIEN)
    60         ;
    61         ; if the batch transmission is still less than 24 hours old, skip this batch and get out
    62         S IBSECS=$$FMDIFF^XLFDT($$NOW^XLFDT,$P($G(^IBA(364.1,BCHIEN,1)),U,6),2)
    63         I IBSECS<86400 G BCHCHKX    ; # seconds in a day
    64         ;
    65         ; if no edi claims in this batch, update batch status and get out
    66         I '$O(^IBA(364,"C",BCHIEN,0)) D UPDBCH(BCHIEN) G BCHCHKX
    67         ;
    68         F  S IBEDI=$O(^IBA(364,"C",BCHIEN,IBEDI)) Q:'IBEDI  D  Q:'IBOK
    69         . S IBZ=$G(^IBA(364,IBEDI,0))
    70         . S IBIFN=+IBZ,IB0=$G(^DGCR(399,IBIFN,0))
    71         . I $P(IB0,U,13)=7 Q                    ; cancelled in IB
    72         . I $P(IBZ,U,3)'="P" Q                  ; edi claim status is not pending
    73         . S AR=$P($$BILL^RCJIBFN2(IBIFN),U,2)   ; AR status DBIA 1452
    74         . I $F(".22.26.39.","."_AR_".") Q       ; collected/closed or cancelled
    75         . ;
    76         . ; if we get to this point, then we have found an EDI claim in this batch
    77         . ; that is not cancelled in IB, the EDI claim status is "P", and the
    78         . ; AR status is not collected/closed nor cancelled in AR.  So therefore
    79         . ; this claim didn't get to Austin, so the batch didn't get to Austin.
    80         . S IBOK=0
    81         . Q
    82         ;
    83         ; If we find the batch has been received in Austin, then change the batch status.
    84         I IBOK D UPDBCH(BCHIEN)
    85         ;
    86 BCHCHKX ;
    87         Q IBOK
    88         ;
     1IBCEBUL ;ALB/TMP - 837 EDI SPECIAL BULLETINS PROCESSING ;19-SEP-96
     2 ;;2.0;INTEGRATED BILLING;**137,250**;21-MAR-94
     3 ;
     4NOTSENT ; Check for batches in pending status (no confirmation from Austin)
     5 ;  from yesterday or before
     6 N XMTO,XMSUBJ,XMBODY,XMDUZ,IBT,IB,IBE,IBCT,IBI,IB0,IB1,Z,IBDTM
     7 K ^TMP($J,"IBNOTSENT")
     8 D NOW^%DTC S IBDTM=%
     9 S (IBCT,IBI)=0
     10 F  S IBI=$O(^IBA(364.1,"ASTAT","P",IBI)) Q:'IBI  S IBTYP=$P($G(^IBA(364.1,IBI,0)),U,7),IBDAYS=(IBDTM-$P($G(^(1)),U,6)) I IBDAYS>1,IBDAYS'=IBDTM,$O(^IBA(364,"C",IBI,0)) D
     11 .S IBCT=IBCT+1,IBCT(+IBTYP)=$G(IBCT(+IBTYP))+1
     12 .I IBCT'>10 S ^TMP($J,"IBNOTSENT",IBTYP,IBI)=""
     13 I IBCT D
     14 .S IBT(1)="There are "_IBCT_" EDI batch(es) still pending Austin receipt "
     15 .S IBT(2)="for more than 1 day.  Please investigate why they have not yet been confirmed"
     16 .S IBT(3)="as being received by Austin."
     17 .S IBT(4)=" "
     18 .I IBCT>10 S IBT(5)="Since there were more than 10 batches found, please run the ",IBT(6)="  EDI BATCHES WAITING FOR AUSTIN RECEIPT OVER 1-DAY report to get a list of these batches."
     19 .I IBCT'>10 D
     20 ..S IBT(5)="      BATCH #      PENDING SINCE             MAIL MESSAGE #",IBT(6)="",$P(IBT(6),"-",76)="",IBT(6)="  "_IBT(6),IBE=6
     21 ..S IBTYP=""
     22 ..F  S IBTYP=$O(^TMP($J,"IBNOTSENT",IBTYP)) Q:IBTYP=""  D
     23 ...S Z=$$EXPAND^IBTRE(364.1,.07,IBTYP) S:Z="" Z="??"
     24 ...I $O(^TMP($J,"IBNOTSENT",IBTYP),-1)'="" S IBE=IBE+1,IBT(IBE)=" "
     25 ...S IBE=IBE+1,IBT(IBE)="  BATCH TYPE: "_Z
     26 ...S IBI=0 F  S IBI=$O(^TMP($J,"IBNOTSENT",IBTYP,IBI)) Q:'IBI  D
     27 ....S IBE=IBE+1,IB0=$G(^IBA(364.1,IBI,0)),IB1=$G(^(1))
     28 ....S IBT(IBE)="      "_$E($P(IB0,U)_$J("",10),1,10)_"   "_$E($$FMTE^XLFDT($P(IB1,U,6),1)_$J("",20),1,20)_"      "_$P(IB0,U,4),IBE=IBE+1,IBT(IBE)=$J("",8)_$E($P(IB0,U,8),1,72)
     29 .S XMSUBJ="EDI BATCHES WAITING AUSTIN RECEIPT FOR OVER 1 DAY",XMBODY="IBT",XMDUZ="",XMTO("I:G.IB EDI")=""
     30 .D SENDMSG^XMXAPI(XMDUZ,XMSUBJ,XMBODY,.XMTO,,.XMZ)
     31 K ^TMP($J,"IBNOTSENT")
     32 Q
     33 ;

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCECOB1.m

    r613 r623  
    1 IBCECOB1        ;ALB/CXW - IB COB MANAGEMENT SCREEN/REPORT ;14-JUN-99
    2         ;;2.0;INTEGRATED BILLING;**137,155,288,348,377**;21-MAR-94;Build 23
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5 BLD     ; Build list entrypoint
    6         N I,IBFND,IBB,IBIFN,IB364,IBDA1,IBDTN,IBDA,IBDAY,IBHIS,IBNDS,IBEUT,IBAPY,IBOAM,IBDT,IBMUT,IBBPY,IBINS,IBNDM,IBQ,IBNDI1,IBNDI2,IBNDI3,Z,Z0,IBSEQ,IB3611,IBINS1,IBINS2,IBEXPY,IBNBAL,IBPTRSP,IBAMT,IBMRACNT,IBPTNM,IBSRVC,IBPY,IBB364
    7         N IBEOBREV,IBDENDUP
    8         K ^TMP("IBCECOB",$J),^TMP("IBCECOB1",$J),^TMP("IBCOBST",$J),^TMP("IBCOBSTX",$J)
    9         D CLEAN^VALM10      ; kill data and video control arrays
    10         S VALMCNT=0,IBHIS=""
    11         ; since 0 is a valid Review Status, init w/null
    12         S IBEOBREV=""
    13         ; get EOB's w/Review Status of 0, 1, 1.5 or 2; If 3 or higher, not needed
    14         F  S IBEOBREV=$O(^IBM(361.1,"AMRA",1,IBEOBREV)) Q:IBEOBREV=""  Q:IBEOBREV>2  D  ;
    15         . S IBDA="A" F  S IBDA=$O(^IBM(361.1,"AMRA",1,IBEOBREV,IBDA),-1) Q:'IBDA  D BLD1
    16         ; no data accumulated
    17         I $O(^TMP("IBCOBST",$J,""))="" D NMAT Q
    18         ; display accumulated data
    19         D SCRN
    20         Q
    21 BLD1    ;
    22         I '$$ELIG(IBDA) Q
    23         S IBDENDUP=$$DENDUP^IBCEMU4(IBDA)
    24         I '$G(IBMRADUP),IBDENDUP Q     ; don't include denied MRAs for Duplicate Claim/Service
    25         S IB3611=$G(^IBM(361.1,IBDA,0))
    26         S IBIFN=+IB3611,IB364=$P(IB3611,U,19),IBDT=+$P(IB3611,U,6)
    27         I $D(^TMP("IBCOBSTX",$J,IBIFN)) Q  ;show each bill once on the worklist
    28         S IBB=$G(^DGCR(399,IBIFN,0))
    29         S IBNDS=$G(^DGCR(399,IBIFN,"S")),IBNDI1=$G(^("I1")),IBNDI2=$G(^("I2")),IBNDI3=$G(^("I3")),IBNDM=$G(^("M"))
    30         S IBMUT=+$P(IBNDS,U,8),IBEUT=+$P(IBNDS,U,2)
    31         S IBINS="",IBSEQ=$P(IB3611,U,15)
    32         F I=1:1:3 S Z="IBNDI"_I I @Z D
    33         . N Q
    34         . S Q=(IBSEQ=I)
    35         . I Q S IBINS1=+@Z_U_$P($G(^DIC(36,+@Z,0)),U)
    36         . S IBINS=IBINS_$S(IBINS="":"",1:", ")_$P($G(^DIC(36,+@Z,0)),U)
    37         ; Get the payer/insurance company that comes after Medicare WNR
    38         ; If WNR is Primary, get the secondary ins. co.
    39         ; If WNR is secondary, get the tertiary ins. co.
    40         D  I $P(IBINS2,U,2)="" S $P(IBINS2,U,2)="UNKNOWN"
    41         . I $$WNRBILL^IBEFUNC(IBIFN,1) S IBINS2=+IBNDI2_U_$P($G(^DIC(36,+IBNDI2,0)),U) Q
    42         . S IBINS2=+IBNDI3_U_$P($G(^DIC(36,+IBNDI3,0)),U)
    43         S IBFND=0
    44         ; biller entry not ALL and no biller, then get entered/edited by user
    45         I $D(^TMP("IBBIL",$J)) D  Q:'IBFND
    46         . S IBFND=$S($D(^TMP("IBBIL",$J,IBMUT)):IBMUT,$D(^TMP("IBBIL",$J,IBEUT)):IBEUT,1:0)
    47         S Z=$S(IBFND:IBFND,IBMUT:IBMUT,1:IBEUT)
    48         S IBMUT=$P($G(^VA(200,+Z,0)),U)_"~"_Z
    49         S:'$P(IBMUT,"~",2) IBMUT="UNKNOWN~0"
    50         S IBBPY=+$$COBN^IBCEF(IBIFN),IBQ=1
    51         ;IBQ;1=EOB without subsequent insurer,0=COB,2=0 balance
    52         D  ;I IBQ Q
    53         . ;Check for no reimbursable subsequent insurance
    54         .  F I=IBBPY+1:1:3 D  Q:'IBQ
    55         .. S Z="IBNDI"_I,Z=$G(@Z)
    56         .. I $P($G(^DIC(36,+Z,0)),U,2)="N" S IBQ=0 Q
    57         . ;Check if next ins doesn't exist or next bill# already created
    58         . S Z="IBNDI"_(IBBPY+1),Z=$G(@Z)
    59         . I Z,'$P($G(^DGCR(399,IBIFN,"M1")),U,5+IBBPY) S IBQ=0
    60         ;
    61         ; Days since transmission of latest bill in COB - IBDAY
    62         S IBDAY=+$P($G(^DGCR(399,IBIFN,"TX")),U,2) I IBDAY S IBDAY=$$FMDIFF^XLFDT(DT,IBDAY,1)
    63         ; if no Last Electronic Extract Date on file 399, get it from file 364
    64         I 'IBDAY D  I IBDAY S IBDAY=$$FMDIFF^XLFDT(DT,IBDAY,1) ;calc. the difference
    65         . S IBB364=$$LAST364^IBCEF4(IBIFN) I IBB364'="" S IBDAY=+$P($P($G(^IBA(364,IBB364,0)),U,4),".",1)
    66         ;
    67         S IBAPY=$$TPR^PRCAFN(IBIFN) ; payment on this bill from A/R
    68         S IBEXPY=+$G(^IBM(361.1,IBDA,1))       ; payer paid amount
    69         S IBPTRSP=$$PREOBTOT^IBCEU0(IBIFN)     ; patient resp. function
    70         S IBPY=$S(IBAPY:IBAPY,1:IBEXPY)
    71         S IBOAM=+$G(^DGCR(399,IBIFN,"U1"))     ; total charges for bill
    72         S IBNBAL=IBOAM-IBPY
    73         I IBNBAL'>0 S IBQ=2
    74         S IBPTNM=$P($G(^DPT(+$P($G(^DGCR(399,IBIFN,0)),U,2),0)),U) I IBPTNM="" S IBPTNM="UNKNOWN"
    75         S IBSRVC=$P($G(^DGCR(399,IBIFN,"U")),U)
    76         S Z0=$S(IBSRT="B":IBMUT,IBSRT="D":-IBDAY,IBSRT="I":$P(IBINS2,U,2)_"~"_$P(IBINS2,U),IBSRT="M":$$EXTERNAL^DILFD(361.1,.13,"",$P(IB3611,"^",13)),IBSRT="R":-IBPTRSP,IBSRT="P":IBPTNM,IBSRT="S":IBSRVC,1:IBDT)
    77         S ^TMP("IBCOBST",$J,Z0,IBIFN)=IBSRVC_U_IBOAM_U_IBAPY_U_$S(IBNBAL>0:IBNBAL,1:0)_U_$P(IBB,U,5)_U_$P(IBB,U,19)_U_IBBPY_U_$P(IBMUT,"~")_U_IBINS_U_IBDA_U_$$HIS(IBIFN)_U_IBDAY_U_IBDT_U_IBQ_U_IB364_U_IBSEQ_U_IBEXPY_U_IBPTRSP
    78         S ^TMP("IBCOBST",$J,Z0,IBIFN,1)=$$EXTERNAL^DILFD(361.1,.13,"",$P(IB3611,"^",13))_", "_$$FMTE^XLFDT($P($P(IB3611,"^",6),"."))_"^"_$P(IB3611,"^",16)
    79         S ^TMP("IBCOBSTX",$J,IBIFN)=IBDA  ;keep track of compiled IBIFN's
    80         ;
    81         ; Save some data when there are multiple MRA's on file for this bill
    82         S IBMRACNT=$$MRACNT^IBCEMU1(IBIFN)
    83         I IBMRACNT>1 S $P(^TMP("IBCOBST",$J,Z0,IBIFN,1),U,1)="Multiple MRA's on file"
    84         S $P(^TMP("IBCOBST",$J,Z0,IBIFN,1),U,3)=IBMRACNT
    85         S $P(^TMP("IBCOBST",$J,Z0,IBIFN,1),U,4)=IBDENDUP
    86         Q
    87         ;
    88 HIS(IBIFN)      ; COB history
    89         N A,B,IBST,IBBIL,IBHIS
    90         S IBHIS="",A=0 F  S A=$O(^IBM(361.1,"ABS",IBIFN,A)) Q:'A  S B=0 F  S B=$O(^IBM(361.1,"ABS",IBIFN,A,B)) Q:'B  D
    91         . S IBST=$P($G(^IBM(361.1,B,0)),U,4),IBBIL=$P(^DGCR(399,IBIFN,"M1"),U,4+A)
    92         . Q:IBBIL=""
    93         . S IBHIS=IBHIS_$S(IBHIS="":"",1:";")_$S(A=1:"PRIMARY",A=2:"SECONDARY",1:"TERTIARY")_" "_$S(IBST:"MRA",1:"EOB")_" RECEIVED - "_IBBIL
    94         Q IBHIS
    95         ;
    96 NMAT    ;No COB list
    97         S VALMCNT=2,IBCNT=2
    98         S ^TMP("IBCECOB",$J,1,0)=" "
    99         S ^TMP("IBCECOB",$J,2,0)="    No MRA's Matching Selection Criteria Were Found"
    100         Q
    101         ;
    102 SCRN    ;
    103         N IBX,IBCNT,IBIFN,IBDA,IB,X,IBS1,IBPAT,Z,IBK,IBFORM
    104         S IBCNT=0
    105         S IBS1=$S(IBSRT="B":"BILLER",IBSRT="D":"Days Since Last Transmission",IBSRT="L":"Date Last MRA Received",IBSRT="I":"SECONDARY INSURANCE COMPANY",IBSRT="M":"MRA Status",1:"")
    106         S IBX="" F  S IBX=$O(^TMP("IBCOBST",$J,IBX)) Q:IBX=""  D
    107         . I IBSRT="B"!(IBSRT="I")!(IBSRT="M") D
    108         .. D:IBCNT SET("",IBCNT+1)
    109         .. D SET(IBS1_": "_$P(IBX,"~"),IBCNT+1)
    110         . S IBIFN=0 F  S IBIFN=$O(^TMP("IBCOBST",$J,IBX,IBIFN)) Q:'IBIFN  D
    111         .. S IB=$G(^TMP("IBCOBST",$J,IBX,IBIFN))
    112         .. S Z=$G(^DPT(+$P($G(^DGCR(399,IBIFN,0)),U,2),0))
    113         .. S IBPAT=$$LJ^XLFSTR($E($P(Z,U),1,18),18," ")_" "_$E($P(Z,U,9),6,9)
    114         .. S IBDA=$P(IB,U,10) ;361.1-ien
    115         .. S IBQ=$P(IB,U,14),IB364=$P(IB,U,15)
    116         .. S IBFORM=$$EXTERNAL^DILFD(399,.19,,+$P(IB,U,6))
    117         .. I +$P(IB,U,6)=2 S IBFORM=1500   ; for space reasons
    118         .. S IBPTRSP=$P(IB,U,18)
    119         .. S IBAMT=$P(IB,U,2)
    120         .. S IBCNT=IBCNT+1
    121         .. S X=""
    122         .. S X=$$SETFLD^VALM1(IBCNT,X,"NUMBER")
    123         .. S X=$$SETFLD^VALM1($$BN1^PRCAFN(IBIFN)_$S($P($G(^DGCR(399,IBIFN,"TX")),U,10)=1:"*",1:""),X,"BILL")
    124         .. S X=$$SETFLD^VALM1($$DAT1^IBOUTL($P(IB,U)),X,"SERVICE")
    125         .. S X=$$SETFLD^VALM1(IBPAT,X,"PATNM")
    126         .. S X=$$SETFLD^VALM1($$RJ^XLFSTR($FN(IBPTRSP,"",2),9," "),X,"PTRESP")
    127         .. S X=$$SETFLD^VALM1($$RJ^XLFSTR($FN(IBAMT,"",2),9," "),X,"IBAMT")
    128         .. S X=$$SETFLD^VALM1($$TYPE^IBJTLA1($P(IB,U,5))_"/"_IBFORM,X,"BTYPE")
    129         .. D SET(X,IBCNT,IBIFN,IBDA,IBQ,IB364,IBX,IB)
    130         .. ;For R (Pt Resp), P (Pt Name) and S (Service Date) don't display sub-headers
    131         .. I "BIMRPS"'[IBSRT D
    132         ... S Z=$S(IBSRT="L":$$DAT1^IBOUTL(IBX),IBSRT="D":-IBX,1:IBX)
    133         ... D SET("   "_IBS1_": "_Z,IBCNT)
    134         .. S X=$$SETSTR^VALM1("Insurers:  "_$P(IB,U,9),"",7,74)
    135         .. D SET(X,IBCNT,IBIFN,IBDA,IBQ,IB364,IBX,IB)
    136         .. ;
    137         .. ; line 3 of display:  MRA status/date/split claim indicator
    138         .. S X=$$SETSTR^VALM1("MRA Status:  ","",5,13)
    139         .. S IBK=$G(^TMP("IBCOBST",$J,IBX,IBIFN,1))
    140         .. S X=$$SETSTR^VALM1($P(IBK,U,1),X,18,63)
    141         .. I $P(IBK,U,2)=2 S X=$$SETSTR^VALM1("** SPLIT CLAIM **",X,63,18)
    142         .. I $P(IBK,U,4),$P(IBK,U,2)'=2,$P(IBK,U,3)=1 S X=$$SETSTR^VALM1("** Denied for Duplicate **",X,54,27)
    143         .. D SET(X,IBCNT,IBIFN,IBDA,IBQ,IB364,IBX,IB)
    144         .. ;
    145         .. ; conditionally update video attributes of line 3
    146         .. I '$D(IOINHI) D ENS^%ZISS
    147         .. ; split claim
    148         .. I $P(IBK,U,2)=2 D CNTRL^VALM10(VALMCNT,63,17,IOINHI,IOINORM)
    149         .. ; multiple mra's on file
    150         .. I $P(IBK,U,3)>1 D CNTRL^VALM10(VALMCNT,18,22,IOINHI,IOINORM)
    151         .. ; Denied for Duplicate - no split claim and single MRA only
    152         .. I $P(IBK,U,4),$P(IBK,U,2)'=2,$P(IBK,U,3)=1 D CNTRL^VALM10(VALMCNT,54,26,IOINHI,IOINORM)
    153         .. Q
    154         Q
    155         ;
    156 SET(X,CNT,IBIFN,IBDA,IBQ,IB364,IBX,IB)  ;set up list manager screen array
    157         S VALMCNT=VALMCNT+1
    158         S ^TMP("IBCECOB",$J,VALMCNT,0)=X
    159         S ^TMP("IBCECOB",$J,"IDX",VALMCNT,CNT)=""
    160         I $G(IBIFN),$G(^TMP("IBCECOB",$J,CNT))="" S ^TMP("IBCECOB",$J,CNT)=VALMCNT_U_IBIFN_U_IB364_U_IBDA_U_IBQ_U_IBX,^TMP("IBCECOB1",$J,CNT)=IB
    161         Q
    162         ;
    163 FTYPE(Y)        ;type classification
    164         Q $E($P($G(^IBE(353,Y,0)),U),1,8)
    165         ;
    166 PTRESPI(IBEOB)  ; Function - Computes the Patient's Responsibility based on IBEOB
    167         ; of 361.1 for Claims/Bills with form type 3=UB
    168         ; Input IBEOB - a single EOB ien; Required
    169         ; Output      - Function Returns IBPTRES - Patient Responsibility Amount for the EOB
    170         ;
    171         N IBPTRES,IBC,EOBADJ
    172         S IBPTRES=0,IBEOB=+$G(IBEOB)
    173         I 'IBEOB Q IBPTRES   ;PTRESPI
    174         ;
    175         ; get claim level adjustments
    176         K EOBADJ M EOBADJ=^IBM(361.1,IBEOB,10)
    177         S IBPTRES=$$CALCPR^IBCEU0(.EOBADJ)
    178         ;
    179         ; get line level adjustments
    180         S IBC=0 F  S IBC=$O(^IBM(361.1,IBEOB,15,IBC)) Q:'IBC  D
    181         . K EOBADJ M EOBADJ=^IBM(361.1,IBEOB,15,IBC,1)
    182         . S IBPTRES=IBPTRES+$$CALCPR^IBCEU0(.EOBADJ)
    183         Q IBPTRES
    184         ;
    185 ELIG(IBEOB)     ; Function to determine if an EOB entry is eligible for
    186         ; inclusion on the MRA management worklist or not.
    187         ; IBEOB - ien into file 361.1 (required)
    188         ; Returns 1 if EOB should appear on the worklist
    189         ; Returns 0 if EOB should not appear on the worklist
    190         ;
    191         NEW ELIG,IB3611,IBIFN
    192         S ELIG=0,IBEOB=+$G(IBEOB)
    193         S IB3611=$G(^IBM(361.1,IBEOB,0))
    194         I $P(IB3611,U,4)'=1 G ELIGX    ; eob type must be Medicare MRA
    195         I $P(IB3611,U,16)>2 G ELIGX    ; review status must be <= 2
    196         S IBIFN=+IB3611
    197         I $P($G(^DGCR(399,IBIFN,0)),U,13)'=2 G ELIGX  ; Request MRA bill status
    198         I $D(^IBM(361.1,IBEOB,"ERR")) G ELIGX         ; filing errors
    199         ;
    200         S ELIG=1    ; this EOB is eligible for the worklist
    201         ;
    202 ELIGX   ;
    203         Q ELIG
    204         ;
     1IBCECOB1 ;ALB/CXW - IB COB MANAGEMENT SCREEN/REPORT ;14-JUN-99
     2 ;;2.0;INTEGRATED BILLING;**137,155,288,348**;21-MAR-94;Build 5
     3 ;
     4BLD ; Build list entrypoint
     5 N I,IBFND,IBB,IBIFN,IB364,IBDA1,IBDTN,IBDA,IBDAY,IBHIS,IBNDS,IBEUT,IBAPY,IBOAM,IBDT,IBMUT,IBBPY,IBINS,IBNDM,IBQ,IBNDI1,IBNDI2,IBNDI3,Z,Z0,IBSEQ,IB3611,IBINS1,IBINS2,IBEXPY,IBNBAL,IBPTRSP,IBAMT,IBMRACNT,IBPTNM,IBSRVC,IBPY,IBB364
     6 N IBEOBREV,IBDENDUP
     7 K ^TMP("IBCECOB",$J),^TMP("IBCECOB1",$J),^TMP("IBCOBST",$J),^TMP("IBCOBSTX",$J)
     8 D CLEAN^VALM10      ; kill data and video control arrays
     9 S VALMCNT=0,IBHIS=""
     10 ; since 0 is a valid Review Status, init w/null
     11 S IBEOBREV=""
     12 ; get EOB's w/Review Status of 0, 1, 1.5 or 2; If 3 or higher, not needed
     13 F  S IBEOBREV=$O(^IBM(361.1,"AMRA",1,IBEOBREV)) Q:IBEOBREV=""  Q:IBEOBREV>2  D  ;
     14 . S IBDA="A" F  S IBDA=$O(^IBM(361.1,"AMRA",1,IBEOBREV,IBDA),-1) Q:'IBDA  D BLD1
     15 ; no data accumulated
     16 I $O(^TMP("IBCOBST",$J,""))="" D NMAT Q
     17 ; display accumulated data
     18 D SCRN
     19 Q
     20BLD1 ;
     21 I '$$ELIG(IBDA) Q
     22 S IBDENDUP=$$DENDUP^IBCEMU4(IBDA)
     23 I '$G(IBMRADUP),IBDENDUP Q     ; don't include denied MRAs for Duplicate Claim/Service
     24 S IB3611=$G(^IBM(361.1,IBDA,0))
     25 S IBIFN=+IB3611,IB364=$P(IB3611,U,19),IBDT=+$P(IB3611,U,6)
     26 I $D(^TMP("IBCOBSTX",$J,IBIFN)) Q  ;show each bill once on the worklist
     27 S IBB=$G(^DGCR(399,IBIFN,0))
     28 S IBNDS=$G(^DGCR(399,IBIFN,"S")),IBNDI1=$G(^("I1")),IBNDI2=$G(^("I2")),IBNDI3=$G(^("I3")),IBNDM=$G(^("M"))
     29 S IBMUT=+$P(IBNDS,U,8),IBEUT=+$P(IBNDS,U,2)
     30 S IBINS="",IBSEQ=$P(IB3611,U,15)
     31 F I=1:1:3 S Z="IBNDI"_I I @Z D
     32 . N Q
     33 . S Q=(IBSEQ=I)
     34 . I Q S IBINS1=+@Z_U_$P($G(^DIC(36,+@Z,0)),U)
     35 . S IBINS=IBINS_$S(IBINS="":"",1:", ")_$P($G(^DIC(36,+@Z,0)),U)
     36 ; Get the payer/insurance company that comes after Medicare WNR
     37 ; If WNR is Primary, get the secondary ins. co.
     38 ; If WNR is secondary, get the tertiary ins. co.
     39 D  I $P(IBINS2,U,2)="" S $P(IBINS2,U,2)="UNKNOWN"
     40 . I $$WNRBILL^IBEFUNC(IBIFN,1) S IBINS2=+IBNDI2_U_$P($G(^DIC(36,+IBNDI2,0)),U) Q
     41 . S IBINS2=+IBNDI3_U_$P($G(^DIC(36,+IBNDI3,0)),U)
     42 S IBFND=0
     43 ; biller entry not ALL and no biller, then get entered/edited by user
     44 I $D(^TMP("IBBIL",$J)) D  Q:'IBFND
     45 . S IBFND=$S($D(^TMP("IBBIL",$J,IBMUT)):IBMUT,$D(^TMP("IBBIL",$J,IBEUT)):IBEUT,1:0)
     46 S Z=$S(IBFND:IBFND,IBMUT:IBMUT,1:IBEUT)
     47 S IBMUT=$P($G(^VA(200,+Z,0)),U)_"~"_Z
     48 S:'$P(IBMUT,"~",2) IBMUT="UNKNOWN~0"
     49 S IBBPY=+$$COBN^IBCEF(IBIFN),IBQ=1
     50 ;IBQ;1=EOB without subsequent insurer,0=COB,2=0 balance
     51 D  ;I IBQ Q
     52 . ;Check for no reimbursable subsequent insurance
     53 .  F I=IBBPY+1:1:3 D  Q:'IBQ
     54 .. S Z="IBNDI"_I,Z=$G(@Z)
     55 .. I $P($G(^DIC(36,+Z,0)),U,2)="N" S IBQ=0 Q
     56 . ;Check if next ins doesn't exist or next bill# already created
     57 . S Z="IBNDI"_(IBBPY+1),Z=$G(@Z)
     58 . I Z,'$P($G(^DGCR(399,IBIFN,"M1")),U,5+IBBPY) S IBQ=0
     59 ;
     60 ; Days since transmission of latest bill in COB - IBDAY
     61 S IBDAY=+$P($G(^DGCR(399,IBIFN,"TX")),U,2) I IBDAY S IBDAY=$$FMDIFF^XLFDT(DT,IBDAY,1)
     62 ; if no Last Electronic Extract Date on file 399, get it from file 364
     63 I 'IBDAY D  I IBDAY S IBDAY=$$FMDIFF^XLFDT(DT,IBDAY,1) ;calc. the difference
     64 . S IBB364=$$LAST364^IBCEF4(IBIFN) I IBB364'="" S IBDAY=+$P($P($G(^IBA(364,IBB364,0)),U,4),".",1)
     65 ;
     66 S IBAPY=$$TPR^PRCAFN(IBIFN) ; payment on this bill from A/R
     67 S IBEXPY=+$G(^IBM(361.1,IBDA,1))       ; payer paid amount
     68 S IBPTRSP=$$PREOBTOT^IBCEU0(IBIFN)     ; patient resp. function
     69 S IBPY=$S(IBAPY:IBAPY,1:IBEXPY)
     70 S IBOAM=+$G(^DGCR(399,IBIFN,"U1"))     ; total charges for bill
     71 S IBNBAL=IBOAM-IBPY
     72 I IBNBAL'>0 S IBQ=2
     73 S IBPTNM=$P($G(^DPT(+$P($G(^DGCR(399,IBIFN,0)),U,2),0)),U) I IBPTNM="" S IBPTNM="UNKNOWN"
     74 S IBSRVC=$P($G(^DGCR(399,IBIFN,"U")),U)
     75 S Z0=$S(IBSRT="B":IBMUT,IBSRT="D":-IBDAY,IBSRT="I":$P(IBINS2,U,2)_"~"_$P(IBINS2,U),IBSRT="M":$$EXTERNAL^DILFD(361.1,.13,"",$P(IB3611,"^",13)),IBSRT="R":-IBPTRSP,IBSRT="P":IBPTNM,IBSRT="S":IBSRVC,1:IBDT)
     76 S ^TMP("IBCOBST",$J,Z0,IBIFN)=IBSRVC_U_IBOAM_U_IBAPY_U_$S(IBNBAL>0:IBNBAL,1:0)_U_$P(IBB,U,5)_U_$P(IBB,U,19)_U_IBBPY_U_$P(IBMUT,"~")_U_IBINS_U_IBDA_U_$$HIS(IBIFN)_U_IBDAY_U_IBDT_U_IBQ_U_IB364_U_IBSEQ_U_IBEXPY_U_IBPTRSP
     77 S ^TMP("IBCOBST",$J,Z0,IBIFN,1)=$$EXTERNAL^DILFD(361.1,.13,"",$P(IB3611,"^",13))_", "_$$FMTE^XLFDT($P($P(IB3611,"^",6),"."))_"^"_$P(IB3611,"^",16)
     78 S ^TMP("IBCOBSTX",$J,IBIFN)=IBDA  ;keep track of compiled IBIFN's
     79 ;
     80 ; Save some data when there are multiple MRA's on file for this bill
     81 S IBMRACNT=$$MRACNT^IBCEMU1(IBIFN)
     82 I IBMRACNT>1 S $P(^TMP("IBCOBST",$J,Z0,IBIFN,1),U,1)="Multiple MRA's on file"
     83 S $P(^TMP("IBCOBST",$J,Z0,IBIFN,1),U,3)=IBMRACNT
     84 S $P(^TMP("IBCOBST",$J,Z0,IBIFN,1),U,4)=IBDENDUP
     85 Q
     86 ;
     87HIS(IBIFN) ; COB history
     88 N A,B,IBST,IBBIL,IBHIS
     89 S IBHIS="",A=0 F  S A=$O(^IBM(361.1,"ABS",IBIFN,A)) Q:'A  S B=0 F  S B=$O(^IBM(361.1,"ABS",IBIFN,A,B)) Q:'B  D
     90 . S IBST=$P($G(^IBM(361.1,B,0)),U,4),IBBIL=$P(^DGCR(399,IBIFN,"M1"),U,4+A)
     91 . Q:IBBIL=""
     92 . S IBHIS=IBHIS_$S(IBHIS="":"",1:";")_$S(A=1:"PRIMARY",A=2:"SECONDARY",1:"TERTIARY")_" "_$S(IBST:"MRA",1:"EOB")_" RECEIVED - "_IBBIL
     93 Q IBHIS
     94 ;
     95NMAT ;No COB list
     96 S VALMCNT=2,IBCNT=2
     97 S ^TMP("IBCECOB",$J,1,0)=" "
     98 S ^TMP("IBCECOB",$J,2,0)="    No MRA's Matching Selection Criteria Were Found"
     99 Q
     100 ;
     101SCRN ;
     102 N IBX,IBCNT,IBIFN,IBDA,IB,X,IBS1,IBPAT,Z,IBK,IBFORM
     103 S IBCNT=0
     104 S IBS1=$S(IBSRT="B":"BILLER",IBSRT="D":"Days Since Last Transmission",IBSRT="L":"Date Last MRA Received",IBSRT="I":"SECONDARY INSURANCE COMPANY",IBSRT="M":"MRA Status",1:"")
     105 S IBX="" F  S IBX=$O(^TMP("IBCOBST",$J,IBX)) Q:IBX=""  D
     106 . I IBSRT="B"!(IBSRT="I")!(IBSRT="M") D
     107 .. D:IBCNT SET("",IBCNT+1)
     108 .. D SET(IBS1_": "_$P(IBX,"~"),IBCNT+1)
     109 . S IBIFN=0 F  S IBIFN=$O(^TMP("IBCOBST",$J,IBX,IBIFN)) Q:'IBIFN  D
     110 .. S IB=$G(^TMP("IBCOBST",$J,IBX,IBIFN))
     111 .. S Z=$G(^DPT(+$P($G(^DGCR(399,IBIFN,0)),U,2),0))
     112 .. S IBPAT=$$LJ^XLFSTR($E($P(Z,U),1,18),18," ")_" "_$E($P(Z,U,9),6,9)
     113 .. S IBDA=$P(IB,U,10) ;361.1-ien
     114 .. S IBQ=$P(IB,U,14),IB364=$P(IB,U,15)
     115 .. S IBFORM=$$EXTERNAL^DILFD(399,.19,,+$P(IB,U,6))
     116 .. I +$P(IB,U,6)=2 S IBFORM=1500   ; for space reasons
     117 .. S IBPTRSP=$P(IB,U,18)
     118 .. S IBAMT=$P(IB,U,2)
     119 .. S IBCNT=IBCNT+1
     120 .. S X=""
     121 .. S X=$$SETFLD^VALM1(IBCNT,X,"NUMBER")
     122 .. S X=$$SETFLD^VALM1($$BN1^PRCAFN(IBIFN),X,"BILL")
     123 .. S X=$$SETFLD^VALM1($$DAT1^IBOUTL($P(IB,U)),X,"SERVICE")
     124 .. S X=$$SETFLD^VALM1(IBPAT,X,"PATNM")
     125 .. S X=$$SETFLD^VALM1($$RJ^XLFSTR($FN(IBPTRSP,"",2),9," "),X,"PTRESP")
     126 .. S X=$$SETFLD^VALM1($$RJ^XLFSTR($FN(IBAMT,"",2),9," "),X,"IBAMT")
     127 .. S X=$$SETFLD^VALM1($$TYPE^IBJTLA1($P(IB,U,5))_"/"_IBFORM,X,"BTYPE")
     128 .. D SET(X,IBCNT,IBIFN,IBDA,IBQ,IB364,IBX,IB)
     129 .. ;For R (Pt Resp), P (Pt Name) and S (Service Date) don't display sub-headers
     130 .. I "BIMRPS"'[IBSRT D
     131 ... S Z=$S(IBSRT="L":$$DAT1^IBOUTL(IBX),IBSRT="D":-IBX,1:IBX)
     132 ... D SET("   "_IBS1_": "_Z,IBCNT)
     133 .. S X=$$SETSTR^VALM1("Insurers:  "_$P(IB,U,9),"",7,74)
     134 .. D SET(X,IBCNT,IBIFN,IBDA,IBQ,IB364,IBX,IB)
     135 .. ;
     136 .. ; line 3 of display:  MRA status/date/split claim indicator
     137 .. S X=$$SETSTR^VALM1("MRA Status:  ","",5,13)
     138 .. S IBK=$G(^TMP("IBCOBST",$J,IBX,IBIFN,1))
     139 .. S X=$$SETSTR^VALM1($P(IBK,U,1),X,18,63)
     140 .. I $P(IBK,U,2)=2 S X=$$SETSTR^VALM1("** SPLIT CLAIM **",X,63,18)
     141 .. I $P(IBK,U,4),$P(IBK,U,2)'=2,$P(IBK,U,3)=1 S X=$$SETSTR^VALM1("** Denied for Duplicate **",X,54,27)
     142 .. D SET(X,IBCNT,IBIFN,IBDA,IBQ,IB364,IBX,IB)
     143 .. ;
     144 .. ; conditionally update video attributes of line 3
     145 .. I '$D(IOINHI) D ENS^%ZISS
     146 .. ; split claim
     147 .. I $P(IBK,U,2)=2 D CNTRL^VALM10(VALMCNT,63,17,IOINHI,IOINORM)
     148 .. ; multiple mra's on file
     149 .. I $P(IBK,U,3)>1 D CNTRL^VALM10(VALMCNT,18,22,IOINHI,IOINORM)
     150 .. ; Denied for Duplicate - no split claim and single MRA only
     151 .. I $P(IBK,U,4),$P(IBK,U,2)'=2,$P(IBK,U,3)=1 D CNTRL^VALM10(VALMCNT,54,26,IOINHI,IOINORM)
     152 .. Q
     153 Q
     154 ;
     155SET(X,CNT,IBIFN,IBDA,IBQ,IB364,IBX,IB) ;set up list manager screen array
     156 S VALMCNT=VALMCNT+1
     157 S ^TMP("IBCECOB",$J,VALMCNT,0)=X
     158 S ^TMP("IBCECOB",$J,"IDX",VALMCNT,CNT)=""
     159 I $G(IBIFN),$G(^TMP("IBCECOB",$J,CNT))="" S ^TMP("IBCECOB",$J,CNT)=VALMCNT_U_IBIFN_U_IB364_U_IBDA_U_IBQ_U_IBX,^TMP("IBCECOB1",$J,CNT)=IB
     160 Q
     161 ;
     162FTYPE(Y) ;type classification
     163 Q $E($P($G(^IBE(353,Y,0)),U),1,8)
     164 ;
     165PTRESPI(IBEOB) ; Function - Computes the Patient's Responsibility based on IBEOB
     166 ; of 361.1 for Claims/Bills with form type 3=UB
     167 ; Input IBEOB - a single EOB ien; Required
     168 ; Output      - Function Returns IBPTRES - Patient Responsibility Amount for the EOB
     169 ;
     170 N IBPTRES,IBC,EOBADJ
     171 S IBPTRES=0,IBEOB=+$G(IBEOB)
     172 I 'IBEOB Q IBPTRES   ;PTRESPI
     173 ;
     174 ; get claim level adjustments
     175 K EOBADJ M EOBADJ=^IBM(361.1,IBEOB,10)
     176 S IBPTRES=$$CALCPR^IBCEU0(.EOBADJ)
     177 ;
     178 ; get line level adjustments
     179 S IBC=0 F  S IBC=$O(^IBM(361.1,IBEOB,15,IBC)) Q:'IBC  D
     180 . K EOBADJ M EOBADJ=^IBM(361.1,IBEOB,15,IBC,1)
     181 . S IBPTRES=IBPTRES+$$CALCPR^IBCEU0(.EOBADJ)
     182 Q IBPTRES
     183 ;
     184ELIG(IBEOB) ; Function to determine if an EOB entry is eligible for
     185 ; inclusion on the MRA management worklist or not.
     186 ; IBEOB - ien into file 361.1 (required)
     187 ; Returns 1 if EOB should appear on the worklist
     188 ; Returns 0 if EOB should not appear on the worklist
     189 ;
     190 NEW ELIG,IB3611,IBIFN
     191 S ELIG=0,IBEOB=+$G(IBEOB)
     192 S IB3611=$G(^IBM(361.1,IBEOB,0))
     193 I $P(IB3611,U,4)'=1 G ELIGX    ; eob type must be Medicare MRA
     194 I $P(IB3611,U,16)>2 G ELIGX    ; review status must be <= 2
     195 S IBIFN=+IB3611
     196 I $P($G(^DGCR(399,IBIFN,0)),U,13)'=2 G ELIGX  ; Request MRA bill status
     197 I $D(^IBM(361.1,IBEOB,"ERR")) G ELIGX         ; filing errors
     198 ;
     199 S ELIG=1    ; this EOB is eligible for the worklist
     200 ;
     201ELIGX ;
     202 Q ELIG
     203 ;

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCECSA1.m

    r613 r623  
    1 IBCECSA1        ;ALB/CXW - IB STATUS AWAITING RESOLUTION SCREEN ;28-JUL-99
    2         ;;2.0;INTEGRATED BILLING;**137,283,288,320,368**;21-MAR-94;Build 21
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ; DBIA for $$BN1^PRCAFN()
    5         ;
    6 BLD     ; Build list entrypoint
    7         N IBDA,IBREV,IBIFN,IBPAY,IBSSN,IBSER,IB399,IBLOC,IBDIV,IBUER,IBMSG,IBERR,IBPEN,SEVERITY,A,IBOAM,IBPAT,IBSTSMSG,SV1,SV2,SV3
    8         K ^TMP("IBCECSA",$J),^TMP("IBCECSB",$J),^TMP("IBCECSD",$J)
    9         W !!,"Compiling CSA status messages ... "
    10         S IBSEV=$G(IBSEV,"R")
    11         S VALMCNT=0,IB364=""
    12         S SEVERITY=""
    13         F  S SEVERITY=$O(^IBM(361,"ACSA",SEVERITY)) Q:SEVERITY=""  I SEVERITY="R"!(IBSEV="B") S IBREV="" F  S IBREV=$O(^IBM(361,"ACSA",SEVERITY,IBREV)) Q:IBREV=""  I IBREV<2 S IBDA=0 F  S IBDA=$O(^IBM(361,"ACSA",SEVERITY,IBREV,IBDA)) Q:'IBDA  D
    14         . S IB=$G(^IBM(361,IBDA,0)),IBIFN=+IB
    15         . S IBPEN=$$FMDIFF^XLFDT(DT,$P(IB,U,2),1)
    16         . ;quit if not pending for at least the minimum # of days requested
    17         . Q:IBDAYS>IBPEN
    18         . S IB399=$G(^DGCR(399,IBIFN,0))
    19         . ;
    20         . ; no cancelled claims allowed on the CSA screen
    21         . ; if we find one, then update the appropriate EDI files
    22         . I $P(IB399,U,13)=7 D UPDEDI^IBCEM(+$P(IB,U,11),"C") Q
    23         . ;
    24         . ; automatically review this message if the claim was last printed on
    25         . ; or after the MCS - 'Resubmit by Print' date
    26         . I $P(IB,U,16),($P($G(^DGCR(399,IBIFN,"S")),U,14)\1)'<$P(IB,U,16) D UPDEDI^IBCEM(+$P(IB,U,11),"P") Q
    27         . ;
    28         . S IBDIV=+$P(IB399,U,22)
    29         . S IBUER=+$P($G(^DGCR(399,IBIFN,"S")),U,11)
    30         . ;
    31         . ; If Request MRA bill, pull the MRA Requestor user instead
    32         . I 'IBUER,$P(IB399,U,13)=2 S IBUER=+$P($G(^DGCR(399,IBIFN,"S")),U,8)
    33         . I $D(^TMP("IBBIL",$J)),'$D(^TMP("IBBIL",$J,IBUER)) Q  ; User not selected
    34         . I $D(^TMP("IBDIV",$J)),'$D(^TMP("IBDIV",$J,IBDIV)) Q  ; Div not selected
    35         . ;
    36         . S IBPAY=$P($G(^DIC(36,+$P($G(^DGCR(399,IBIFN,"MP")),U),0)),U)
    37         . I IBPAY="" S IBPAY=$P($G(^DIC(36,+$$CURR^IBCEF2(IBIFN),0)),U)
    38         . I IBPAY="" S IBPAY="UNKNOWN PAYER"
    39         . S IBPAT=$G(^DPT(+$P(IB399,U,2),0))
    40         . S IBSSN=$E($P(IBPAT,U,9),6,9) I IBSSN="" S IBSSN="~unk"
    41         . S IBPAT=$P(IBPAT,U,1) I IBPAT="" S IBPAT="~UNKNOWN PATIENT NAME"
    42         . S IBSER=$P($G(^DGCR(399,IBIFN,"U")),U)
    43         . S IBLOC=$P(IB399,U,4)
    44         . S IBLOC=$S(IBLOC=1:"HOSPITAL",IBLOC=2:"SKILLED NURSING",1:"CLINIC")
    45         . I IBDIV S IBDIV=$P($G(^DG(40.8,IBDIV,0)),U)
    46         . I IBDIV=""!(IBDIV=0) S IBDIV="UNSPECIFIED"
    47         . S IBMSG=$S($P(IB,U,8):"PAYER",1:"NON-PAYER")
    48         . S IBUER=$S(IBUER:$P($G(^VA(200,IBUER,0)),U),1:"UNKNOWN")_"~"_IBUER
    49         . S IB364=$P(IB,U,11)
    50         . S IBOAM=$G(^DGCR(399,IBIFN,"U1"))
    51         . S IBOAM=$P(IBOAM,U,1)-$P(IBOAM,U,2)     ; current balance (total charges - offset)
    52         . ;
    53         . S IBSTSMSG=$$TXT(IBDA)       ; status message text
    54         . S IBERR=$E(IBSTSMSG,1,60)
    55         . I IBERR="" S IBERR="-"
    56         . ;
    57         . S IB=$$BN1^PRCAFN(IBIFN)     ; external bill#
    58         . S A=IBIFN_U_IBPAY_U_IBPAT_U_IBSSN_U_IBSER_U_IBOAM_U_IBLOC_U_IBDIV_U_IBUER_U_IBMSG_U_IBPEN_U_$S(IBREV:"*",1:"")_U_IB364_U_IB
    59         . ;
    60         . S SV1=$$SRTV($G(IBSORT1),IBDA)
    61         . S SV2=$$SRTV($G(IBSORT2),IBDA)
    62         . S SV3=$$SRTV($G(IBSORT3),IBDA)
    63         . S ^TMP("IBCECSB",$J,SV1,SV2,SV3,IBDA)=A
    64         . S ^TMP("IBCECSB",$J,SV1,SV2,SV3,IBDA,"MSG")=IBSTSMSG
    65         . Q
    66         ;
    67         I '$D(^TMP("IBCECSB",$J)) D NMAT Q
    68         D SCRN
    69         Q
    70         ;
    71 NMAT    ;No CSA list
    72         S VALMCNT=2,IBCNT=2
    73         S ^TMP("IBCECSA",$J,1,0)=" "
    74         S ^TMP("IBCECSA",$J,2,0)="No Messages Matching Selection Criteria Found"
    75         Q
    76         ;
    77 SRTV(SORT,IBDA) ; sort value calculation given the sort code letter
    78         I SORT="" Q IBDA
    79         Q $$SV^IBCECSA(SORT)
    80         ;
    81 SCRN    ;
    82         NEW IBSRT1,IBSRT2,IBSRT3,IBX,IBCNT,IBIFN,IBDA,IB,INFX,DAT,X
    83         W !,"Building the CSA list display ... "
    84         S IBCNT=0,IBSRT1=""
    85         F  S IBSRT1=$O(^TMP("IBCECSB",$J,IBSRT1)) Q:IBSRT1=""  D
    86         . D SRTBRK(1,$G(IBSORT1),IBSRT1)
    87         . S IBSRT2=""
    88         . F  S IBSRT2=$O(^TMP("IBCECSB",$J,IBSRT1,IBSRT2)) Q:IBSRT2=""  D
    89         .. D SRTBRK(2,$G(IBSORT2),IBSRT2)
    90         .. S IBSRT3=""
    91         .. F  S IBSRT3=$O(^TMP("IBCECSB",$J,IBSRT1,IBSRT2,IBSRT3)) Q:IBSRT3=""  D
    92         ... D SRTBRK(3,$G(IBSORT3),IBSRT3)
    93         ... S IBDA=0
    94         ... F  S IBDA=$O(^TMP("IBCECSB",$J,IBSRT1,IBSRT2,IBSRT3,IBDA)) Q:'IBDA  D
    95         .... S IB=$G(^TMP("IBCECSB",$J,IBSRT1,IBSRT2,IBSRT3,IBDA))
    96         .... S IBSTSMSG=$G(^TMP("IBCECSB",$J,IBSRT1,IBSRT2,IBSRT3,IBDA,"MSG"))
    97         .... S IBIFN=+IB
    98         .... S IB364=$P(IB,U,13)
    99         .... S DAT=IBIFN_U_IBDA_U_IBSRT1_U_IBSRT2_U_IB364_U_IBSRT3
    100         .... ;
    101         .... S IBCNT=IBCNT+1
    102         .... S X=$$SETFLD^VALM1($J(IBCNT,3),"","NUMBER")
    103         .... D SETL1(IB,.X)
    104         .... D SET(X,IBCNT,DAT)
    105         .... ;
    106         .... S X=$$SETSTR^VALM1(IBSTSMSG,"",6,75)
    107         .... D SET(X,IBCNT,DAT)
    108         .... Q
    109         ... Q
    110         .. Q
    111         . Q
    112         Q
    113         ;
    114 SRTBRK(LVL,SORT,IBSRT)  ; sort break for display of certain sort data
    115         ; LVL   - sort level
    116         ; SORT  - sort letter code
    117         ; IBSRT - subscript data
    118         ;
    119         NEW IBS,DSPDATA
    120         I '$F(".A.D.N.","."_$G(SORT)_".") G SRTBRKX
    121         S IBS=$$SD^IBCECSA(SORT)
    122         S DSPDATA=IBSRT
    123         I SORT="A" S DSPDATA=$P(DSPDATA,"~",1)      ; biller name
    124         I SORT="N" S DSPDATA=-DSPDATA               ; number of days pending
    125         D SET($J("",LVL-1)_IBS_": "_DSPDATA,IBCNT,"")
    126 SRTBRKX ;
    127         Q
    128         ;
    129 SET(X,CNT,DAT)  ;set up list manager screen array
    130         S VALMCNT=VALMCNT+1
    131         I 'CNT S CNT=1
    132         S ^TMP("IBCECSA",$J,VALMCNT,0)=X
    133         S ^TMP("IBCECSA",$J,"IDX",VALMCNT,CNT)=""
    134         I DAT'="" S ^TMP("IBCECSA",$J,CNT)=VALMCNT_U_DAT
    135         Q
    136         ;
    137 SETL1(IB,X)     ;
    138         S X=$$SETFLD^VALM1($P($G(^DGCR(399,+IB,0)),U,1)_$P(IB,U,12),X,"BILL")
    139         S X=$$SETFLD^VALM1($P(IB,U,2),X,"PNAME")
    140         S X=$$SETFLD^VALM1($P(IB,U,3),X,"PANAME")
    141         S X=$$SETFLD^VALM1($P(IB,U,4),X,"SSN")
    142         S X=$$SETFLD^VALM1($$FMTE^XLFDT($P(IB,U,5),"2Z"),X,"SERVICE")
    143         S X=$$SETFLD^VALM1($J("$"_$FN($P(IB,U,6),"",2),10),X,"CURBAL")
    144         Q
    145         ;
    146 TXT(IBDA,LEN)   ; Return a string of status message text
    147         ; IBDA - ien to file 361
    148         ;  LEN - desired maximum length of combined text string
    149         NEW MSG,LN,STOP,TX,HLN,REFN,DELIM
    150         S MSG="",LN=0,LEN=$G(LEN,75),STOP=0
    151         F  S LN=$O(^IBM(361,+$G(IBDA),1,LN)) Q:'LN  D  Q:STOP
    152         . S TX=$G(^IBM(361,IBDA,1,LN,0))
    153         . S TX=$$TRIM^XLFSTR(TX)
    154         . ; Don't include parts added by ^IBCE277
    155         . Q:TX="Informational Message:"
    156         . Q:TX="Warning Message:"
    157         . Q:TX="Error Message:"
    158         . I $E(TX,1,27)="Clearinghouse Trace Number:" S STOP=1 Q
    159         . I $E(TX,1,18)="Payer Status Date:" S STOP=1 Q
    160         . I $E(TX,1,19)="Payer Claim Number:" S STOP=1 Q
    161         . I $E(TX,1,12)="Split Claim:" S STOP=1 Q
    162         . I $E(TX,1,11)="Claim Type:" S STOP=1 Q
    163         . I $E(TX,1,8)="Patient:" S STOP=1 Q
    164         . I $E(TX,1,14)="Service Dates:" S STOP=1 Q
    165         . I $E(TX,1,11)="Payer Name:" S STOP=1 Q
    166         . I $E(TX,1,7)="Source:" S STOP=1 Q
    167         . I TX["HL=" S HLN=+$P(TX,"HL=",2),DELIM="HL="_HLN,TX=$P(TX,DELIM,1)_"HL= "_$P(TX,DELIM,2,9)
    168         . I TX["ENVOY REF: " S REFN=$E($P(TX,"ENVOY REF: ",2),1,14),DELIM="ENVOY REF: "_REFN,TX=$P(TX,DELIM,1)_"ENVOY REF: "_$P(TX,DELIM,2,9)
    169         . I ($L(MSG)+$L(TX))>500 S STOP=1 Q
    170         . S MSG=MSG_$S(MSG="":"",1:" ")_TX
    171         . I $L(MSG)>LEN S STOP=1
    172         . Q
    173         Q $E(MSG,1,LEN)
    174         ;
     1IBCECSA1 ;ALB/CXW - IB STATUS AWAITING RESOLUTION SCREEN ;28-JUL-99
     2 ;;2.0;INTEGRATED BILLING;**137,283,288,320**;21-MAR-94
     3 ; DBIA for $$BN1^PRCAFN()
     4 ;
     5BLD ; Build list entrypoint
     6 N IBDA,IBREV,IBIFN,IBPAY,IBSSN,IBSER,IB399,IBLOC,IBDIV,IBUER,IBMSG,IBERR,IBPEN,SEVERITY,A,IBOAM,IBPAT,IBSTSMSG,SV1,SV2,SV3
     7 K ^TMP("IBCECSA",$J),^TMP("IBCECSB",$J),^TMP("IBCECSD",$J)
     8 W !!,"Compiling CSA status messages ... "
     9 S IBSEV=$G(IBSEV,"R")
     10 S VALMCNT=0,IB364=""
     11 S SEVERITY=""
     12 F  S SEVERITY=$O(^IBM(361,"ACSA",SEVERITY)) Q:SEVERITY=""  I SEVERITY="R"!(IBSEV="B") S IBREV="" F  S IBREV=$O(^IBM(361,"ACSA",SEVERITY,IBREV)) Q:IBREV=""  I IBREV<2 S IBDA=0 F  S IBDA=$O(^IBM(361,"ACSA",SEVERITY,IBREV,IBDA)) Q:'IBDA  D
     13 . S IB=$G(^IBM(361,IBDA,0)),IBIFN=+IB
     14 . S IBPEN=$$FMDIFF^XLFDT(DT,$P(IB,U,2),1)
     15 . ;quit if not pending for at least the minimum # of days requested
     16 . Q:IBDAYS>IBPEN
     17 . S IB399=$G(^DGCR(399,IBIFN,0))
     18 . ;
     19 . ; no cancelled claims allowed on the CSA screen
     20 . ; if we find one, then update the appropriate EDI files
     21 . I $P(IB399,U,13)=7 D UPDEDI^IBCEM(+$P(IB,U,11),"C") Q
     22 . ;
     23 . ; automatically review this message if the claim was last printed on
     24 . ; or after the MCS - 'Resubmit by Print' date
     25 . I $P(IB,U,16),($P($G(^DGCR(399,IBIFN,"S")),U,14)\1)'<$P(IB,U,16) D UPDEDI^IBCEM(+$P(IB,U,11),"P") Q
     26 . ;
     27 . S IBDIV=+$P(IB399,U,22)
     28 . S IBUER=+$P($G(^DGCR(399,IBIFN,"S")),U,11)
     29 . ;
     30 . ; If Request MRA bill, pull the MRA Requestor user instead
     31 . I 'IBUER,$P(IB399,U,13)=2 S IBUER=+$P($G(^DGCR(399,IBIFN,"S")),U,8)
     32 . I $D(^TMP("IBBIL",$J)),'$D(^TMP("IBBIL",$J,IBUER)) Q  ; User not selected
     33 . I $D(^TMP("IBDIV",$J)),'$D(^TMP("IBDIV",$J,IBDIV)) Q  ; Div not selected
     34 . ;
     35 . S IBPAY=$P($G(^DIC(36,+$P($G(^DGCR(399,IBIFN,"MP")),U),0)),U)
     36 . I IBPAY="" S IBPAY=$P($G(^DIC(36,+$$CURR^IBCEF2(IBIFN),0)),U)
     37 . I IBPAY="" S IBPAY="UNKNOWN PAYER"
     38 . S IBPAT=$G(^DPT(+$P(IB399,U,2),0))
     39 . S IBSSN=$E($P(IBPAT,U,9),6,9) I IBSSN="" S IBSSN="~unk"
     40 . S IBPAT=$P(IBPAT,U,1) I IBPAT="" S IBPAT="~UNKNOWN PATIENT NAME"
     41 . S IBSER=$P($G(^DGCR(399,IBIFN,"U")),U)
     42 . S IBLOC=$P(IB399,U,4)
     43 . S IBLOC=$S(IBLOC=1:"HOSPITAL",IBLOC=2:"SKILLED NURSING",1:"CLINIC")
     44 . I IBDIV S IBDIV=$P($G(^DG(40.8,IBDIV,0)),U)
     45 . I IBDIV=""!(IBDIV=0) S IBDIV="UNSPECIFIED"
     46 . S IBMSG=$S($P(IB,U,8):"PAYER",1:"NON-PAYER")
     47 . S IBUER=$S(IBUER:$P($G(^VA(200,IBUER,0)),U),1:"UNKNOWN")_"~"_IBUER
     48 . S IB364=$P(IB,U,11)
     49 . S IBOAM=$G(^DGCR(399,IBIFN,"U1"))
     50 . S IBOAM=$P(IBOAM,U,1)-$P(IBOAM,U,2)     ; current balance (total charges - offset)
     51 . ;
     52 . S IBSTSMSG=$$TXT(IBDA)       ; status message text
     53 . S IBERR=$E(IBSTSMSG,1,30)
     54 . I IBERR="" S IBERR="-"
     55 . ;
     56 . S IB=$$BN1^PRCAFN(IBIFN)     ; external bill#
     57 . S A=IBIFN_U_IBPAY_U_IBPAT_U_IBSSN_U_IBSER_U_IBOAM_U_IBLOC_U_IBDIV_U_IBUER_U_IBMSG_U_IBPEN_U_$S(IBREV:"*",1:"")_U_IB364_U_IB
     58 . ;
     59 . S SV1=$$SRTV($G(IBSORT1),IBDA)
     60 . S SV2=$$SRTV($G(IBSORT2),IBDA)
     61 . S SV3=$$SRTV($G(IBSORT3),IBDA)
     62 . S ^TMP("IBCECSB",$J,SV1,SV2,SV3,IBDA)=A
     63 . S ^TMP("IBCECSB",$J,SV1,SV2,SV3,IBDA,"MSG")=IBSTSMSG
     64 . Q
     65 ;
     66 I '$D(^TMP("IBCECSB",$J)) D NMAT Q
     67 D SCRN
     68 Q
     69 ;
     70NMAT ;No CSA list
     71 S VALMCNT=2,IBCNT=2
     72 S ^TMP("IBCECSA",$J,1,0)=" "
     73 S ^TMP("IBCECSA",$J,2,0)="No Messages Matching Selection Criteria Found"
     74 Q
     75 ;
     76SRTV(SORT,IBDA) ; sort value calculation given the sort code letter
     77 I SORT="" Q IBDA
     78 Q $$SV^IBCECSA(SORT)
     79 ;
     80SCRN ;
     81 NEW IBSRT1,IBSRT2,IBSRT3,IBX,IBCNT,IBIFN,IBDA,IB,INFX,DAT,X
     82 W !,"Building the CSA list display ... "
     83 S IBCNT=0,IBSRT1=""
     84 F  S IBSRT1=$O(^TMP("IBCECSB",$J,IBSRT1)) Q:IBSRT1=""  D
     85 . D SRTBRK(1,$G(IBSORT1),IBSRT1)
     86 . S IBSRT2=""
     87 . F  S IBSRT2=$O(^TMP("IBCECSB",$J,IBSRT1,IBSRT2)) Q:IBSRT2=""  D
     88 .. D SRTBRK(2,$G(IBSORT2),IBSRT2)
     89 .. S IBSRT3=""
     90 .. F  S IBSRT3=$O(^TMP("IBCECSB",$J,IBSRT1,IBSRT2,IBSRT3)) Q:IBSRT3=""  D
     91 ... D SRTBRK(3,$G(IBSORT3),IBSRT3)
     92 ... S IBDA=0
     93 ... F  S IBDA=$O(^TMP("IBCECSB",$J,IBSRT1,IBSRT2,IBSRT3,IBDA)) Q:'IBDA  D
     94 .... S IB=$G(^TMP("IBCECSB",$J,IBSRT1,IBSRT2,IBSRT3,IBDA))
     95 .... S IBSTSMSG=$G(^TMP("IBCECSB",$J,IBSRT1,IBSRT2,IBSRT3,IBDA,"MSG"))
     96 .... S IBIFN=+IB
     97 .... S IB364=$P(IB,U,13)
     98 .... S DAT=IBIFN_U_IBDA_U_IBSRT1_U_IBSRT2_U_IB364_U_IBSRT3
     99 .... ;
     100 .... S IBCNT=IBCNT+1
     101 .... S X=$$SETFLD^VALM1($J(IBCNT,3),"","NUMBER")
     102 .... D SETL1(IB,.X)
     103 .... D SET(X,IBCNT,DAT)
     104 .... ;
     105 .... S X=$$SETSTR^VALM1(IBSTSMSG,"",6,75)
     106 .... D SET(X,IBCNT,DAT)
     107 .... Q
     108 ... Q
     109 .. Q
     110 . Q
     111 Q
     112 ;
     113SRTBRK(LVL,SORT,IBSRT) ; sort break for display of certain sort data
     114 ; LVL   - sort level
     115 ; SORT  - sort letter code
     116 ; IBSRT - subscript data
     117 ;
     118 NEW IBS,DSPDATA
     119 I '$F(".A.D.N.","."_$G(SORT)_".") G SRTBRKX
     120 S IBS=$$SD^IBCECSA(SORT)
     121 S DSPDATA=IBSRT
     122 I SORT="A" S DSPDATA=$P(DSPDATA,"~",1)      ; biller name
     123 I SORT="N" S DSPDATA=-DSPDATA               ; number of days pending
     124 D SET($J("",LVL-1)_IBS_": "_DSPDATA,IBCNT,"")
     125SRTBRKX ;
     126 Q
     127 ;
     128SET(X,CNT,DAT) ;set up list manager screen array
     129 S VALMCNT=VALMCNT+1
     130 I 'CNT S CNT=1
     131 S ^TMP("IBCECSA",$J,VALMCNT,0)=X
     132 S ^TMP("IBCECSA",$J,"IDX",VALMCNT,CNT)=""
     133 I DAT'="" S ^TMP("IBCECSA",$J,CNT)=VALMCNT_U_DAT
     134 Q
     135 ;
     136SETL1(IB,X) ;
     137 S X=$$SETFLD^VALM1($P($G(^DGCR(399,+IB,0)),U,1)_$P(IB,U,12),X,"BILL")
     138 S X=$$SETFLD^VALM1($P(IB,U,2),X,"PNAME")
     139 S X=$$SETFLD^VALM1($P(IB,U,3),X,"PANAME")
     140 S X=$$SETFLD^VALM1($P(IB,U,4),X,"SSN")
     141 S X=$$SETFLD^VALM1($$FMTE^XLFDT($P(IB,U,5),"2Z"),X,"SERVICE")
     142 S X=$$SETFLD^VALM1($J("$"_$FN($P(IB,U,6),"",2),10),X,"CURBAL")
     143 Q
     144 ;
     145TXT(IBDA,LEN) ; Return a string of status message text
     146 ; IBDA - ien to file 361
     147 ;  LEN - desired maximum length of combined text string
     148 NEW MSG,LN,STOP,TX,HLN,REFN,DELIM
     149 S MSG="",LN=0,LEN=$G(LEN,75),STOP=0
     150 F  S LN=$O(^IBM(361,+$G(IBDA),1,LN)) Q:'LN  D  Q:STOP
     151 . S TX=$G(^IBM(361,IBDA,1,LN,0))
     152 . I $E(TX,1,5)="Error" S TX=$E(TX,6,999)
     153 . S TX=$$TRIM^XLFSTR(TX)
     154 . I $E(TX,1,8)="Patient:" S STOP=1 Q
     155 . I $E(TX,1,14)="Service Dates:" S STOP=1 Q
     156 . I $E(TX,1,11)="Payer Name:" S STOP=1 Q
     157 . I $E(TX,1,7)="Source:" S STOP=1 Q
     158 . I $E(TX,1,11)="Claim Line:" S STOP=1 Q
     159 . I $E(TX,1,13)="Service Type:" S STOP=1 Q
     160 . I TX["HL=" S HLN=+$P(TX,"HL=",2),DELIM="HL="_HLN,TX=$P(TX,DELIM,1)_"HL= "_$P(TX,DELIM,2,9)
     161 . I TX["ENVOY REF: " S REFN=$E($P(TX,"ENVOY REF: ",2),1,14),DELIM="ENVOY REF: "_REFN,TX=$P(TX,DELIM,1)_"ENVOY REF: "_$P(TX,DELIM,2,9)
     162 . I ($L(MSG)+$L(TX))>500 S STOP=1 Q
     163 . S MSG=MSG_$S(MSG="":"",1:" ")_TX
     164 . I $L(MSG)>LEN S STOP=1
     165 . Q
     166 Q $E(MSG,1,LEN)
     167 ;

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCECSA3.m

    r613 r623  
    1 IBCECSA3        ;ALB/CXW - CLAIMS STATUS AWAITING RESOLUTION REPORT ;23-JUL-99
    2         ;;2.0;INTEGRATED BILLING;**137,320,371,377**;21-MAR-94;Build 23
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         Q
    5 EN      ; Report of claims status awaiting resolution
    6         NEW %ZIS,ZTSAVE,ZTRTN,ZTDESC,DIR,X,Y,DIRUT,DTOUT,DUOUT,DIROUT,IBRVW
    7         ;
    8         D FULL^VALM1
    9         W !
    10         S DIR(0)="YO"           ; IB*2*377 new question
    11         S DIR("A")="Would you like to include Review Comments with this report"
    12         S DIR("B")="No"
    13         D ^DIR K DIR
    14         I $D(DIRUT) Q
    15         S IBRVW=Y
    16         ;
    17         W !!,"You will need a 132 column printer for this report!",!
    18         ;
    19         S %ZIS="QM" D ^%ZIS Q:POP
    20         I $D(IO("Q")) K IO("Q") D  Q
    21         . S ZTRTN="LIST^IBCECSA3"
    22         . S ZTSAVE("IBSORT1")=""
    23         . S ZTSAVE("IBSORT2")=""
    24         . S ZTSAVE("IBSORT3")=""
    25         . S ZTSAVE("IBSORTOR")=""
    26         . S ZTSAVE("^TMP(""IBCECSB"",$J,")=""
    27         . S ZTSAVE("IBRVW")=""
    28         . S ZTDESC="IB -Claims Status Awaiting Resolution Report" D ^%ZTLOAD K ZTSK D HOME^%ZIS
    29         U IO
    30 LIST    ; display
    31         N IBSTOP,X,IBPAGE,IBX,IBDIV,IBDA,IBPAY,IB,IBZ,IBZFT,IBFST,IBX2
    32         W:$E(IOST,1,2)["C-" @IOF ;Only initial form feed for print to screen
    33         S (IBSTOP,IBPAGE,IBFST,IBDIV)=0
    34         I IBSORT1="D" S IBDIV=1
    35         I '$D(^TMP("IBCECSB",$J)) D  G LISTQ
    36         . D HDR1 W !,"No entries found for this report"
    37         S IBX="" F  S IBX=$O(^TMP("IBCECSB",$J,IBX)) Q:IBX=""!IBSTOP  S IBX2="" F  S IBX2=$O(^TMP("IBCECSB",$J,IBX,IBX2)) Q:IBX2=""!IBSTOP  S IBX3="" F  S IBX3=$O(^TMP("IBCECSB",$J,IBX,IBX2,IBX3)) Q:IBX3=""!IBSTOP  D  Q:IBSTOP
    38         . I 'IBFST S IBPAY=$$IBPAY(IBX,IBX2,IBX3) D HDR1 S:'IBDIV IBFST=1 Q:IBSTOP
    39         . S IBDA=0 F  S IBDA=$O(^TMP("IBCECSB",$J,IBX,IBX2,IBX3,IBDA)) Q:'IBDA!IBSTOP  S IB=$G(^TMP("IBCECSB",$J,IBX,IBX2,IBX3,IBDA)) D  Q:IBSTOP
    40         .. I ($Y+3)>IOSL D HDR1 Q:IBSTOP
    41         .. W $$BN1^PRCAFN(+IB),$P(IB,U,12),?13,$E($P(IB,U,2),1,25),?40,$E($P(IB,U,3),1,30),?72,$P($P(IB,U,4),"~"),?78,$$DAT1^IBOUTL($P(IB,U,5)),?88,$E($P(IB,U,7),1,10),?100,"$"_$J($P(IB,U,6),0,2),?110,$P(IB,U,10),?122,$P(IB,U,11),!
    42         .. I $P(IB,U,12)="*" W " ***** CSA REVIEW IN PROCESS *****",!
    43         .. W " FORM TYPE: "_$P($G(^IBE(353,$P($G(^DGCR(399,+IB,0)),U,19),0)),U),!
    44         .. I 'IBDIV S X=" DIVISION: "_$P(IB,U,8) W X,$J(" ",40-$L(X))_"AUTHORIZING BILLER: "_$P($P(IB,U,9),"~",1),!
    45         .. W " MESSAGE TEXT: " S IBZFT=0
    46         .. S IBZ=0 F  S IBZ=$O(^IBM(361,IBDA,1,IBZ)) Q:'IBZ  D  Q:IBSTOP
    47         ... W:'IBZFT ?15 S X=$G(^IBM(361,IBDA,1,IBZ,0))
    48         ... F I=1:131:$L(X) W " "_$E(X,I,I+130),!
    49         ... S IBZFT=1
    50         ... I ($Y+3)>IOSL D HDR1 Q:IBSTOP
    51         ... Q
    52         .. Q:IBSTOP
    53         .. ;
    54         .. ; Display the Review Comments if they exist based on user choice (IB*377)
    55         .. I $G(IBRVW),+$O(^IBM(361,IBDA,2,0)) D  Q:IBSTOP
    56         ... N IBCM,IBT1,IBT0,IBD0,IBCL
    57         ... I ($Y+3)>IOSL D HDR1 Q:IBSTOP
    58         ... W ?3,"*** Review Comments for Claim "_$$BN1^PRCAFN(+IB)_" ***",!
    59         ... S IBCM=0 F IBT1=0:1 S IBCM=$O(^IBM(361,IBDA,2,IBCM)) Q:'IBCM     ; count up # of comments
    60         ... S IBT0=0
    61         ... S IBCM=0 F  S IBCM=$O(^IBM(361,IBDA,2,IBCM)) Q:'IBCM!IBSTOP  D  Q:IBSTOP
    62         .... S IBT0=IBT0+1
    63         .... S IBD0=$G(^IBM(361,IBDA,2,IBCM,0))
    64         .... I ($Y+3)>IOSL D HDR1 Q:IBSTOP
    65         .... W ?7,"Entered "_$$FMTE^XLFDT($P(IBD0,U,1),"5ZPM")
    66         .... I $P(IBD0,U,2) W " by "_$P($G(^VA(200,$P(IBD0,U,2),0)),U,1)
    67         .... W " ("_IBT0_" of "_IBT1_")",!
    68         .... S IBCL=0 F  S IBCL=$O(^IBM(361,IBDA,2,IBCM,1,IBCL)) Q:'IBCL!IBSTOP  D  Q:IBSTOP
    69         ..... I ($Y+3)>IOSL D HDR1 Q:IBSTOP
    70         ..... W ?10,$G(^IBM(361,IBDA,2,IBCM,1,IBCL,0)),!
    71         ..... Q
    72         .... Q
    73         ... Q
    74         .. ;
    75         .. ; Display a line break before the next claim in this report
    76         .. I ($Y+3)>IOSL D HDR1 Q:IBSTOP
    77         .. W !
    78         .. Q
    79         . Q
    80         ;
    81         G:IBSTOP LISTQ
    82         I $E(IOST,1,2)["C-" K DIR S DIR(0)="E" D ^DIR K DIR
    83 LISTQ   I $D(ZTQUEUED) S ZTREQ="@" Q
    84         W ! D ^%ZISC
    85         Q
    86 IBPAY(IBX,IBX2,IBX3)    ; return biller name
    87         N X
    88         S X=$O(^TMP("IBCECSB",$J,IBX,IBX2,IBX3,0))
    89         S X=$G(^TMP("IBCECSB",$J,IBX,IBX2,IBX3,X))
    90         Q $P($P(X,U,9),"~",1)
    91 HDR1    ;
    92         N DIR,Y
    93         I IBPAGE D  Q:IBSTOP
    94         . I $E(IOST,1,2)["C-" K DIR S DIR(0)="E" D ^DIR K DIR S IBSTOP=('Y) Q:IBSTOP
    95         . W @IOF
    96         S IBPAGE=IBPAGE+1
    97         W !,"Sort 1: ",$$SD^IBCECSA(IBSORT1)
    98         W ?46,"Claims Status Awaiting Resolution Report",?120,$J("Page: "_IBPAGE,11)
    99         W !,"Sort 2: ",$S($G(IBSORT2)'="":$$SD^IBCECSA(IBSORT2),1:"n/a")
    100         W ?104,$J("Run Date: "_$$HTE^XLFDT($H,"2Z"),27)
    101         W !,"Sort 3: ",$S($G(IBSORT3)'="":$$SD^IBCECSA(IBSORT3),1:"n/a")
    102         I IBDIV W !!,"Division: "_$S($G(IBX)=0:"",1:$G(IBX)),!,"Authorizing Biller: "_$G(IBPAY)
    103         W !,?72,"Last",?78,"Date of",?88,"Location",?100,"Current",?110,"Source of",?122,"Days Msg"
    104         W !,"Bill #",?13,"Payer Name",?40,"Patient Name",?72,"4 SSN",?78,"Service",?88,"of Service",?100,"Balance",?110,"Message",?122,"Pending"
    105         W !,$TR($J("",132)," ","-"),!
    106         Q
    107         ;
    108         ;
    109 RESORT  ; CSA screen re-sort action
    110         NEW DIR,X,Y,Z,IBSAVE,VALMQUIT,IBCURR
    111         D FULL^VALM1 S VALMBCK="R"
    112         W !!?2,"The CSA screen is currently sorted in the following manner:"
    113         W !!?9,"Primary Sort:  ",$S($G(IBSORT1)'="":$$SD^IBCECSA(IBSORT1),1:"n/a")
    114         W !?7,"Secondary Sort:  ",$S($G(IBSORT2)'="":$$SD^IBCECSA(IBSORT2),1:"n/a")
    115         W !?8,"Tertiary Sort:  ",$S($G(IBSORT3)'="":$$SD^IBCECSA(IBSORT3),1:"n/a")
    116         ;
    117         W !
    118         S DIR(0)="Y",DIR("A")="Would you like to change the sort criteria"
    119         S DIR("B")="Yes" D ^DIR K DIR
    120         I 'Y G RESORTX
    121         ;
    122         ; save the old sort criteria
    123         S IBSAVE=$G(IBSORT1)_U_$G(IBSORT2)_U_$G(IBSORT3)
    124         S Z="" F  S Z=$O(IBSORTOR(Z)) Q:Z=""  S IBSAVE=IBSAVE_U_Z_U_IBSORTOR(Z)
    125         ;
    126         W !
    127         K IBSORTOR
    128         D SORT^IBCECSA(1,$P(IBSAVE,U,1)) I $G(VALMQUIT) G RES1
    129         D SORT^IBCECSA(2) I $G(VALMQUIT) G RES1
    130         I $G(IBSORT2)'="" D SORT^IBCECSA(3) I $G(VALMQUIT) G RES1
    131 RES1    ;
    132         I $G(IBSORT1)="" S IBSORT1=$P(IBSAVE,U,1)   ; need at least one
    133         ;
    134         ; see if the sort criteria changed
    135         S IBCURR=$G(IBSORT1)_U_$G(IBSORT2)_U_$G(IBSORT3)
    136         S Z="" F  S Z=$O(IBSORTOR(Z)) Q:Z=""  S IBCURR=IBCURR_U_Z_U_IBSORTOR(Z)
    137         I IBSAVE=IBCURR G RESORTX    ; no sort changes made at all
    138         ;
    139         ; time to rebuild the list because sorts have changed
    140         I $G(IBDAYS)="" S IBDAYS=0
    141         I $G(IBSEV)="" S IBSEV="R"
    142         D BLD^IBCECSA1
    143         S VALMBCK="R",VALMBG=1
    144         ;
    145 RESORTX ;
    146         Q
    147         ;
    148 MCS     ; Link to the Multiple CSA Message Management option
    149         NEW IBCSAMCS S IBCSAMCS=1
    150         D FULL^VALM1 S VALMBCK="R"
    151         I '$$KCHK^XUSRB("IB MESSAGE MANAGEMENT") D  G MCSX
    152         . W !!?5,"You must hold the IB MESSAGE MANAGEMENT key to access this option."
    153         . D PAUSE^VALM1
    154         . Q
    155         ;
    156         D      ; call the MCS screen
    157         . NEW IBSORT1,IBSORT2,IBSORT3,IBDAYS,IBSEV     ; protect CSA vars
    158         . D EN^IBCEMCL
    159         . Q
    160         ;
    161         I $G(IBCSAMCS)=2 D BLD^IBCECSA1 S VALMBG=1     ; rebuild CSA
    162         S VALMBCK="R"
    163 MCSX    ;
    164         Q
    165         ;
     1IBCECSA3 ;ALB/CXW - CLAIMS STATUS AWAITING RESOLUTION REPORT ;23-JUL-99
     2 ;;2.0;INTEGRATED BILLING;**137,320**;21-MAR-94
     3 Q
     4EN ; Report of claims status awaiting resolution
     5 D FULL^VALM1
     6 W !!,"You will need a 132 column printer for this report!",!
     7 ;
     8 N %ZIS,ZTSAVE,ZTRTN,ZTDESC
     9 S %ZIS="QM" D ^%ZIS Q:POP
     10 I $D(IO("Q")) K IO("Q") D  Q
     11 . S ZTRTN="LIST^IBCECSA3"
     12 . S ZTSAVE("IBSORT1")=""
     13 . S ZTSAVE("IBSORT2")=""
     14 . S ZTSAVE("IBSORT3")=""
     15 . S ZTSAVE("IBSORTOR")=""
     16 . S ZTSAVE("^TMP(""IBCECSB"",$J,")=""
     17 . S ZTDESC="IB -Claims Status Awaiting Resolution Report" D ^%ZTLOAD K ZTSK D HOME^%ZIS
     18 U IO
     19LIST ; display
     20 N IBSTOP,X,IBPAGE,IBX,IBDIV,IBDA,IBPAY,IB,IBZ,IBZFT,IBFST,IBX2
     21 W:$E(IOST,1,2)["C-" @IOF ;Only initial form feed for print to screen
     22 S (IBSTOP,IBPAGE,IBFST,IBDIV)=0
     23 I IBSORT1="D" S IBDIV=1
     24 I '$D(^TMP("IBCECSB",$J)) D  G LISTQ
     25 . D HDR1 W !,"No entries found for this report"
     26 S IBX="" F  S IBX=$O(^TMP("IBCECSB",$J,IBX)) Q:IBX=""!IBSTOP  S IBX2="" F  S IBX2=$O(^TMP("IBCECSB",$J,IBX,IBX2)) Q:IBX2=""!IBSTOP  S IBX3="" F  S IBX3=$O(^TMP("IBCECSB",$J,IBX,IBX2,IBX3)) Q:IBX3=""!IBSTOP  D
     27 . I 'IBFST S IBPAY=$$IBPAY(IBX,IBX2,IBX3) D HDR1 S:'IBDIV IBFST=1 Q:IBSTOP
     28 . S IBDA=0 F  S IBDA=$O(^TMP("IBCECSB",$J,IBX,IBX2,IBX3,IBDA)) Q:'IBDA!IBSTOP  S IB=$G(^TMP("IBCECSB",$J,IBX,IBX2,IBX3,IBDA)) D
     29 .. I ($Y+5)>IOSL D HDR1 Q:IBSTOP
     30 .. W $$BN1^PRCAFN(+IB),?13,$E($P(IB,U,2),1,25),?40,$E($P(IB,U,3),1,30),?72,$P($P(IB,U,4),"~"),?78,$$DAT1^IBOUTL($P(IB,U,5)),?88,$E($P(IB,U,7),1,10),?100,"$"_$J($P(IB,U,6),0,2),?110,$P(IB,U,10),?122,$P(IB,U,11),!
     31 .. W " FORM TYPE: "_$P($G(^IBE(353,$P($G(^DGCR(399,+IB,0)),U,19),0)),U),!
     32 .. I 'IBDIV S X=" DIVISION: "_$P(IB,U,8) W X,$J(" ",40-$L(X))_"AUTHORIZING BILLER: "_$P($P(IB,U,9),"~",1),!
     33 .. W " MESSAGE TEXT: " S IBZFT=0
     34 .. S IBZ=0 F  S IBZ=$O(^IBM(361,IBDA,1,IBZ)) Q:'IBZ  D  Q:IBSTOP
     35 ... W:'IBZFT ?15 S X=$G(^IBM(361,IBDA,1,IBZ,0))
     36 ... F I=1:131:$L(X) W " "_$E(X,I,I+130),!
     37 ... S IBZFT=1
     38 ... I ($Y+5)>IOSL D HDR1 Q:IBSTOP
     39 .. W !
     40 G:IBSTOP LISTQ
     41 I $E(IOST,1,2)["C-" K DIR S DIR(0)="E" D ^DIR K DIR
     42LISTQ I $D(ZTQUEUED) S ZTREQ="@" Q
     43 W ! D ^%ZISC
     44 Q
     45IBPAY(IBX,IBX2,IBX3) ; return biller name
     46 N X
     47 S X=$O(^TMP("IBCECSB",$J,IBX,IBX2,IBX3,0))
     48 S X=$G(^TMP("IBCECSB",$J,IBX,IBX2,IBX3,X))
     49 Q $P($P(X,U,9),"~",1)
     50HDR1 ;
     51 N DIR,Y
     52 I IBPAGE D  Q:IBSTOP
     53 . I $E(IOST,1,2)["C-" K DIR S DIR(0)="E" D ^DIR K DIR S IBSTOP=('Y) Q:IBSTOP
     54 . W @IOF
     55 S IBPAGE=IBPAGE+1
     56 W !,"Sort 1: ",$$SD^IBCECSA(IBSORT1)
     57 W ?46,"Claims Status Awaiting Resolution Report",?120,$J("Page: "_IBPAGE,11)
     58 W !,"Sort 2: ",$S($G(IBSORT2)'="":$$SD^IBCECSA(IBSORT2),1:"n/a")
     59 W ?104,$J("Run Date: "_$$HTE^XLFDT($H,"2Z"),27)
     60 W !,"Sort 3: ",$S($G(IBSORT3)'="":$$SD^IBCECSA(IBSORT3),1:"n/a")
     61 I IBDIV W !!,"Division: "_$S($G(IBX)=0:"",1:$G(IBX)),!,"Authorizing Biller: "_$G(IBPAY)
     62 W !,?72,"Last",?78,"Date of",?88,"Location",?100,"Current",?110,"Source of",?122,"Days Msg"
     63 W !,"Bill #",?13,"Payer Name",?40,"Patient Name",?72,"4 SSN",?78,"Service",?88,"of Service",?100,"Balance",?110,"Message",?122,"Pending"
     64 W !,$TR($J("",132)," ","-"),!
     65 Q
     66 ;
     67 ;
     68RESORT ; CSA screen re-sort action
     69 NEW DIR,X,Y,Z,IBSAVE,VALMQUIT,IBCURR
     70 D FULL^VALM1 S VALMBCK="R"
     71 W !!?2,"The CSA screen is currently sorted in the following manner:"
     72 W !!?9,"Primary Sort:  ",$S($G(IBSORT1)'="":$$SD^IBCECSA(IBSORT1),1:"n/a")
     73 W !?7,"Secondary Sort:  ",$S($G(IBSORT2)'="":$$SD^IBCECSA(IBSORT2),1:"n/a")
     74 W !?8,"Tertiary Sort:  ",$S($G(IBSORT3)'="":$$SD^IBCECSA(IBSORT3),1:"n/a")
     75 ;
     76 W !
     77 S DIR(0)="Y",DIR("A")="Would you like to change the sort criteria"
     78 S DIR("B")="Yes" D ^DIR K DIR
     79 I 'Y G RESORTX
     80 ;
     81 ; save the old sort criteria
     82 S IBSAVE=$G(IBSORT1)_U_$G(IBSORT2)_U_$G(IBSORT3)
     83 S Z="" F  S Z=$O(IBSORTOR(Z)) Q:Z=""  S IBSAVE=IBSAVE_U_Z_U_IBSORTOR(Z)
     84 ;
     85 W !
     86 K IBSORTOR
     87 D SORT^IBCECSA(1,$P(IBSAVE,U,1)) I $G(VALMQUIT) G RES1
     88 D SORT^IBCECSA(2) I $G(VALMQUIT) G RES1
     89 I $G(IBSORT2)'="" D SORT^IBCECSA(3) I $G(VALMQUIT) G RES1
     90RES1 ;
     91 I $G(IBSORT1)="" S IBSORT1=$P(IBSAVE,U,1)   ; need at least one
     92 ;
     93 ; see if the sort criteria changed
     94 S IBCURR=$G(IBSORT1)_U_$G(IBSORT2)_U_$G(IBSORT3)
     95 S Z="" F  S Z=$O(IBSORTOR(Z)) Q:Z=""  S IBCURR=IBCURR_U_Z_U_IBSORTOR(Z)
     96 I IBSAVE=IBCURR G RESORTX    ; no sort changes made at all
     97 ;
     98 ; time to rebuild the list because sorts have changed
     99 I $G(IBDAYS)="" S IBDAYS=0
     100 I $G(IBSEV)="" S IBSEV="R"
     101 D BLD^IBCECSA1
     102 S VALMBCK="R",VALMBG=1
     103 ;
     104RESORTX ;
     105 Q
     106 ;
     107MCS ; Link to the Multiple CSA Message Management option
     108 NEW IBCSAMCS S IBCSAMCS=1
     109 D FULL^VALM1 S VALMBCK="R"
     110 I '$$KCHK^XUSRB("IB MESSAGE MANAGEMENT") D  G MCSX
     111 . W !!?5,"You must hold the IB MESSAGE MANAGEMENT key to access this option."
     112 . D PAUSE^VALM1
     113 . Q
     114 ;
     115 D      ; call the MCS screen
     116 . NEW IBSORT1,IBSORT2,IBSORT3,IBDAYS,IBSEV     ; protect CSA vars
     117 . D EN^IBCEMCL
     118 . Q
     119 ;
     120 I $G(IBCSAMCS)=2 D BLD^IBCECSA1 S VALMBG=1     ; rebuild CSA
     121 S VALMBCK="R"
     122MCSX ;
     123 Q
     124 ;

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCECSA4.m

    r613 r623  
    1 IBCECSA4        ;ALB/CXW - IB CLAIMS STATUS AWAITING RESOLUTION SCREEN ;5-AUG-1999
    2         ;;2.0;INTEGRATED BILLING;**137,155,320,371**;21-MAR-1994;Build 57
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5 SMSG    ;select message
    6         N IBCOM,IBX,IBDAX,IBA
    7         D SEL(.IBDAX,1)
    8         I $O(IBDAX(""))="" G SMSGQ
    9         S IBDAX=+$O(IBDAX(0)),IBA=$G(IBDAX(IBDAX))
    10         S IBX=$G(^TMP("IBCECSB",$J,$P(IBA,U,3),$P(IBA,U,4),$P(IBA,U,6),$P(IBA,U,2)))
    11         I IBX'="" D
    12         . Q:'$$LOCK^IBCEU0(361,$P(IBA,U,2))
    13         . D EN^VALM("IBCEM CSA MSG")
    14         . D UNLOCK^IBCEU0(361,$P(IBA,U,2))
    15 SMSGQ   S VALMBCK="R"
    16         I $G(IBFASTXT) S VALMBCK="Q" K IBDAX
    17         D:$O(IBDAX(0)) BLD^IBCECSA1
    18         Q
    19         ;
    20 COB     ; COB management link from CSA
    21         N IBA,IBX
    22         ;IBX,IBA are killed during cancel execution
    23         D FULL^VALM1
    24         D EN^IBCECOB
    25         I $D(IBFASTXT) K IBFASTXT
    26         S VALMBCK="R"
    27         Q
    28         ;
    29 EDI     ;History detail display
    30         N IBIFN,IBX,IBA
    31         D FULL^VALM1
    32         S IBDAX=$O(IBDAX(0)),IBIFN=+$G(IBDAX(IBDAX))
    33         D EDI2^IBCECOB2(IBIFN)
    34         S VALMBCK="R"
    35         Q
    36 EOB     ;View an EOB
    37         N IBIFN,IBA,IBX
    38         D FULL^VALM1
    39         S IBDAX=$O(IBDAX(0)),IBIFN=+$G(IBDAX(IBDAX))
    40         D EN^VALM("IBCEM VIEW EOB")
    41         Q
    42         ;
    43 TPJI    ;Third Party joint Inquiry
    44         N IBIFN,IBX,IBA
    45         D FULL^VALM1
    46         S IBDAX=$O(IBDAX(0)),IBIFN=+$G(IBDAX(IBDAX))
    47         D TPJI1^IBCECOB2(IBIFN)
    48         S VALMBCK="R"
    49         Q
    50         ;
    51 PBILL   ;Print bill - not for resubmit
    52         ; IB*320 - allow action for MRA request claims
    53         N IBIFN,IBX,IBA,IBRESUB
    54         D FULL^VALM1
    55         S IBDAX=$O(IBDAX(0)),IBIFN=+$G(IBDAX(+IBDAX))
    56         I "234"'[$P($G(^DGCR(399,IBIFN,0)),U,13) W !!,"Bill status must be REQUEST MRA, AUTHORIZED or PRNT/TX to print the bill." D PAUSE^VALM1 G PB1
    57         ;
    58         ; don't update review status for MRA's
    59         I $P($G(^DGCR(399,IBIFN,0)),U,13)=2 S IBRESUB=1
    60         E  S IBRESUB=$$RESUB(IBIFN,1,"PX")
    61         I IBRESUB'>0 W !,*7,"This is not a transmittable bill or review not needed" D PAUSE^VALM1 G PB1
    62         I IBRESUB=2 D  G PB1
    63         . N IB364
    64         . S IB364=+$P($G(IBDAX(IBDAX)),U,5)
    65         . D PRINT1^IBCEM03(IBIFN,.IBDAX,IB364)
    66         D PBILL1^IBCECOB2(IBIFN)
    67 PB1     ;
    68         S VALMBCK="R"
    69         Q
    70         ;
    71 CANCEL  ;Cancel bill
    72         N IBIFN,IB364,IBX,IBA,MRACHK
    73         ; IBX,IBA will be killed during execution - need to protect them
    74         D FULL^VALM1
    75         S IBDAX=$O(IBDAX(0)),IBIFN=+$G(IBDAX(+IBDAX))
    76         ; Check for security key
    77         I '$$KCHK^XUSRB("IB AUTHORIZE") D  G CANCELQ
    78         . W !!?5,"You don't hold the proper security key to access this function."
    79         . W !?5,"The necessary key is IB AUTHORIZE.  Please see your manager."
    80         . D PAUSE^VALM1
    81         . Q
    82         D MRACHK I MRACHK G CANCELQ
    83         S IB364=+$P($G(IBDAX(IBDAX)),U,5)
    84         D CANCEL^IBCEM3(.IBDAX,IBIFN,IB364)
    85 CANCELQ S VALMBCK="R"
    86         Q
    87         ;
    88 CLONE   ;'Copy/cancel bill' protocol action
    89         N IBX,IBA,IB364,MRACHK,IBIFN
    90         ; IBX,IBA will be killed during execution - need to protect them
    91         D FULL^VALM1
    92         S IBDAX=$O(IBDAX("")),IBIFN=+$P($G(IBDAX(IBDAX)),U)
    93         I IBDAX="" G CLONEQ
    94         ; Check for security key
    95         I '$$KCHK^XUSRB("IB AUTHORIZE") D  G CLONEQ
    96         . W !!?5,"You don't hold the proper security key to access this function."
    97         . W !?5,"The necessary key is IB AUTHORIZE.  Please see your manager."
    98         . D PAUSE^VALM1
    99         . Q
    100         D MRACHK I MRACHK G CLONEQ
    101         S IB364=+$P($G(IBDAX(IBDAX)),U,5)
    102         D COPYCLON^IBCECOB2(+$G(IBDAX(IBDAX)),IB364,.IBDAX)
    103 CLONEQ  S VALMBCK="R"
    104         Q
    105         ;
    106 PRO     ; Copy for secondary/tertiary bill
    107         N IBIFNH,IBIFN,IB364,IBX,IBA,Z,IBCBASK,IBCBCOPY,IBCAN
    108         D FULL^VALM1
    109         ;IBDAX - array from selection of message
    110         S IBA=$G(IBDAX(+$G(IBDAX)))
    111         G:'IBA PROQ
    112         S IBX=$G(^TMP("IBCECSB",$J,$P(IBA,U,3),$P(IBA,U,4),$P(IBA,U,6),$P(IBA,U,2))),IBIFN=$P(IBA,U)
    113         S IB364=+$P(IBA,U,5)
    114         G:'IBIFN PROQ
    115         ;
    116         I $P($G(^DGCR(399,IBIFN,0)),U,13)=2 D  G PROQ
    117         . W !!?4,"This bill is in a status of REQUEST MRA."
    118         . I $$CHK^IBCEMU1(IBIFN) W !?4,"MRA EOBs must be processed from the MRA management worklist."
    119         . E  W !?4,"There are no MRA EOBs on file."
    120         . D PAUSE^VALM1
    121         . Q
    122         ;
    123         D COBCOPY^IBCECOB2(IBIFN,IB364,1,$P(IBA,U,2),"INIT^IBCECSA2")
    124 PROQ    S VALMBCK="R"
    125         Q
    126         ;
    127 RES     ;Resubmit bill by print
    128         N IBTMP,IB364,IBIFN,IBX,IBA
    129         D FULL^VALM1
    130         S (IBTMP,IBDAX)=$O(IBDAX(0)),IBTMP(IBTMP)=IBDAX(IBDAX)
    131         S IBIFN=$P($G(IBDAX(+IBDAX)),U)
    132         S IB364=+$P($G(IBDAX(IBDAX)),U,5)
    133         I IBIFN D PRINT1^IBCEM03(IBIFN,.IBDAX,IB364),PAUSE^VALM1,INIT^IBCECSA2
    134         S IBDAX(IBTMP)=IBTMP(IBTMP)
    135         S VALMBCK="R"
    136         Q
    137         ;
    138 EBI     ;Edit bill
    139         N IBFLG,IBIFN,IB364,IBX,IBA
    140         K ^TMP($J,"IBBILL")
    141         D FULL^VALM1
    142         S IBDAX=$O(IBDAX(""))
    143         I IBDAX="" G EDITQ
    144         S IBIFN=$P(IBDAX(IBDAX),U)
    145         S IBFLG=1 D  I IBFLG S IBDAX="" D PAUSE^VALM1 G EDITQ
    146         . I $P($G(^DGCR(399,IBIFN,0)),U,13)>2 W !,*7,"An authorized bill can not be edited." Q
    147         . I '$D(^XUSEC("IB EDIT",DUZ)) W !,*7,"You are not authorized to edit a bill" Q
    148         . S IBFLG=0
    149         S IBIFN=+$G(IBDAX(IBDAX))
    150         S IB364=+$P($G(IBDAX(IBDAX)),U,5)
    151         D EBILL^IBCEM3(.IBDAX,IBIFN,IB364)
    152 EDITQ   S VALMBCK="R"
    153         Q
    154         ;
    155 SEL(IBDA,ONE)   ; Select entry(s) from list
    156         ; IBDA = array returned if selections made
    157         ;    IBDAX(n)=ien of bill selected (file 399)
    158         ; ONE = if set to 1, only one selection can be made at a time
    159         N IB
    160         K IBDA
    161         D EN^VALM2($G(XQORNOD(0)),$S('$G(ONE):"",1:"S"))
    162         S IBDA=0 F  S IBDA=$O(VALMY(IBDA)) Q:'IBDA  D
    163         . S IBDA(IBDA)=$P($G(^TMP("IBCECSA",$J,IBDA)),U,2,7)
    164         Q
    165         ;
    166 RESUB(IBIFN,TXMT,IBFUNC,IBTBA)  ; Function asks if resubmit as resolution to a
    167         ;   message is the intention
    168         ; IBIFN = ien of bill in file 399
    169         ; TXMT = flag if = 1, assume it's transmittable, don't have to check
    170         ; IBFUNC = code to say where the code is called from
    171         ;  'E'=edit/authorize  'P'=print 'PX'= print/not to resubmit  'C'=cancel
    172         ; IBTBA = transmit bill array returned to calling routine.  Optional
    173         ;    parameter to be passed by reference.
    174         ;    IBTBA(364ptr)=""
    175         ;
    176         ; Returns:
    177         ; -1 = ^ or timeout at prompt
    178         ;  0 = not a transmittable bill or review not needed
    179         ;  1 = don't update the review status (user choice)
    180         ;  2 = Yes, update the review status (user choice), or resubmit by print
    181         ;
    182         NEW DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT,STAT
    183         KILL IBTBA
    184         I '$G(TXMT),'$$TXMT^IBCEF4(IBIFN) S Y=0 G RESUB1   ; not transmittable
    185         ;
    186         ; Check for any messages or EOB's needing review
    187         S STAT=$$STATUS^IBCEF4(IBIFN)
    188         I '$TR(STAT,U) S Y=0 G RESUB1                ; no unreviewed items
    189         I $P(STAT,U,1) S IBTBA($P(STAT,U,1))=""      ; 364 ien for 361 data
    190         I $P(STAT,U,2) S IBTBA($P(STAT,U,2))=""      ; 364 ien for 361.1 data
    191         ;
    192         I IBFUNC'="P" D
    193         . S DIR(0)="YA",DIR("A",1)="",DIR("A",2)="This bill is in need of review due to receipt of a status msg or EOB",DIR("A")="OK to update the review status to 'REVIEW COMPLETE' based on this action?: ",DIR("B")="NO"
    194         . S DIR("?",1)="You have just "_$S(IBFUNC="E":"requested re-transmission of",IBFUNC="C":"cancelled",1:"")_" the bill"
    195         . S DIR("?",2)="You can update the review status of the unreviewed message to ",DIR("?",3)=" 'REVIEW COMPLETE' if you say YES here"
    196         . S DIR("?")="Press ENTER to continue "
    197         . D ^DIR K DIR
    198         . I $D(DTOUT)!$D(DUOUT) S Y=-1 Q
    199         . S Y=Y+1
    200         E  D
    201         . W !,"The review status of this message will be updated to 'REVIEW COMPLETE'",!,"  based on this action"
    202         . S Y=2
    203         ;
    204 RESUB1  Q +Y
    205         ;
    206 RETXMT  ;
    207         N IB364,IBIFN
    208         D FULL^VALM1
    209         S IBDAX=$O(IBDAX(0)),IB364=+$P($G(IBDAX(IBDAX)),U,5),IBIFN=+$P($G(IBDAX(IBDAX)),U)
    210         I 'IB364!('IBIFN) G RETXMTQ
    211         D MRACHK I MRACHK G RETXMTQ
    212         D RESUB^IBCE(IB364)
    213 RETXMTQ S VALMBCK="R"
    214         Q
    215         ;
    216 MRACHK  ; Restrict access to process REQUEST MRA claims
    217         S MRACHK=0
    218         ; At least one MRA EOB appears on the MRA management worklist
    219         I $P($G(^DGCR(399,IBIFN,0)),U,13)=2,$$MRAWL^IBCEMU2(IBIFN) S MRACHK=1 D  D PAUSE^VALM1
    220         . W !,?4,"This bill is in a status of REQUEST MRA and it does appear on"
    221         . W !,?4,"the MRA Management Worklist.  Please use the MRA Management Menu"
    222         . W !,?4,"options for all processing related to this bill."
    223         Q
     1IBCECSA4 ;ALB/CXW - IB CLAIMS STATUS AWAITING RESOLUTION SCREEN ;5-AUG-1999
     2 ;;2.0;INTEGRATED BILLING;**137,155,320**;21-MAR-1994
     3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
     4 ;
     5SMSG ;select message
     6 N IBCOM,IBX,IBDAX,IBA
     7 D SEL(.IBDAX,1)
     8 I $O(IBDAX(""))="" G SMSGQ
     9 S IBDAX=+$O(IBDAX(0)),IBA=$G(IBDAX(IBDAX))
     10 S IBX=$G(^TMP("IBCECSB",$J,$P(IBA,U,3),$P(IBA,U,4),$P(IBA,U,6),$P(IBA,U,2)))
     11 I IBX'="" D
     12 . Q:'$$LOCK^IBCEU0(361,$P(IBA,U,2))
     13 . D EN^VALM("IBCEM CSA MSG")
     14 . D UNLOCK^IBCEU0(361,$P(IBA,U,2))
     15SMSGQ S VALMBCK="R"
     16 D:$O(IBDAX(0)) BLD^IBCECSA1
     17 Q
     18 ;
     19COB ; COB management link from CSA
     20 N IBA,IBX
     21 ;IBX,IBA are killed during cancel execution
     22 D FULL^VALM1
     23 D EN^IBCECOB
     24 I $D(IBFASTXT) K IBFASTXT
     25 S VALMBCK="R"
     26 Q
     27 ;
     28EDI ;History detail display
     29 N IBIFN,IBX,IBA
     30 D FULL^VALM1
     31 S IBDAX=$O(IBDAX(0)),IBIFN=+$G(IBDAX(IBDAX))
     32 D EDI2^IBCECOB2(IBIFN)
     33 S VALMBCK="R"
     34 Q
     35EOB ;View an EOB
     36 N IBIFN,IBA,IBX
     37 D FULL^VALM1
     38 S IBDAX=$O(IBDAX(0)),IBIFN=+$G(IBDAX(IBDAX))
     39 D EN^VALM("IBCEM VIEW EOB")
     40 Q
     41 ;
     42TPJI ;Third Party joint Inquiry
     43 N IBIFN,IBX,IBA
     44 D FULL^VALM1
     45 S IBDAX=$O(IBDAX(0)),IBIFN=+$G(IBDAX(IBDAX))
     46 D TPJI1^IBCECOB2(IBIFN)
     47 S VALMBCK="R"
     48 Q
     49 ;
     50PBILL ;Print bill - not for resubmit
     51 ; IB*320 - allow action for MRA request claims
     52 N IBIFN,IBX,IBA,IBRESUB
     53 D FULL^VALM1
     54 S IBDAX=$O(IBDAX(0)),IBIFN=+$G(IBDAX(+IBDAX))
     55 I "234"'[$P($G(^DGCR(399,IBIFN,0)),U,13) W !!,"Bill status must be REQUEST MRA, AUTHORIZED or PRNT/TX to print the bill." D PAUSE^VALM1 G PB1
     56 ;
     57 ; don't update review status for MRA's
     58 I $P($G(^DGCR(399,IBIFN,0)),U,13)=2 S IBRESUB=1
     59 E  S IBRESUB=$$RESUB(IBIFN,1,"PX")
     60 I IBRESUB'>0 W !,*7,"This is not a transmittable bill or review not needed" D PAUSE^VALM1 G PB1
     61 I IBRESUB=2 D  G PB1
     62 . N IB364
     63 . S IB364=+$P($G(IBDAX(IBDAX)),U,5)
     64 . D PRINT1^IBCEM03(IBIFN,.IBDAX,IB364)
     65 D PBILL1^IBCECOB2(IBIFN)
     66PB1 ;
     67 S VALMBCK="R"
     68 Q
     69 ;
     70CANCEL ;Cancel bill
     71 N IBIFN,IB364,IBX,IBA,MRACHK
     72 ; IBX,IBA will be killed during execution - need to protect them
     73 D FULL^VALM1
     74 S IBDAX=$O(IBDAX(0)),IBIFN=+$G(IBDAX(+IBDAX))
     75 ; Check for security key
     76 I '$$KCHK^XUSRB("IB AUTHORIZE") D  G CANCELQ
     77 . W !!?5,"You don't hold the proper security key to access this function."
     78 . W !?5,"The necessary key is IB AUTHORIZE.  Please see your manager."
     79 . D PAUSE^VALM1
     80 . Q
     81 D MRACHK I MRACHK G CANCELQ
     82 S IB364=+$P($G(IBDAX(IBDAX)),U,5)
     83 D CANCEL^IBCEM3(.IBDAX,IBIFN,IB364)
     84CANCELQ S VALMBCK="R"
     85 Q
     86 ;
     87CLONE ;'Copy/cancel bill' protocol action
     88 N IBX,IBA,IB364,MRACHK,IBIFN
     89 ; IBX,IBA will be killed during execution - need to protect them
     90 D FULL^VALM1
     91 S IBDAX=$O(IBDAX("")),IBIFN=+$P($G(IBDAX(IBDAX)),U)
     92 I IBDAX="" G CLONEQ
     93 ; Check for security key
     94 I '$$KCHK^XUSRB("IB AUTHORIZE") D  G CLONEQ
     95 . W !!?5,"You don't hold the proper security key to access this function."
     96 . W !?5,"The necessary key is IB AUTHORIZE.  Please see your manager."
     97 . D PAUSE^VALM1
     98 . Q
     99 D MRACHK I MRACHK G CLONEQ
     100 S IB364=+$P($G(IBDAX(IBDAX)),U,5)
     101 D COPYCLON^IBCECOB2(+$G(IBDAX(IBDAX)),IB364,.IBDAX)
     102CLONEQ S VALMBCK="R"
     103 Q
     104 ;
     105PRO ; Copy for secondary/tertiary bill
     106 N IBIFNH,IBIFN,IB364,IBX,IBA,Z,IBCBASK,IBCBCOPY,IBCAN
     107 D FULL^VALM1
     108 ;IBDAX - array from selection of message
     109 S IBA=$G(IBDAX(+$G(IBDAX)))
     110 G:'IBA PROQ
     111 S IBX=$G(^TMP("IBCECSB",$J,$P(IBA,U,3),$P(IBA,U,4),$P(IBA,U,6),$P(IBA,U,2))),IBIFN=$P(IBA,U)
     112 S IB364=+$P(IBA,U,5)
     113 G:'IBIFN PROQ
     114 ;
     115 I $P($G(^DGCR(399,IBIFN,0)),U,13)=2 D  G PROQ
     116 . W !!?4,"This bill is in a status of REQUEST MRA."
     117 . I $$CHK^IBCEMU1(IBIFN) W !?4,"MRA EOBs must be processed from the MRA management worklist."
     118 . E  W !?4,"There are no MRA EOBs on file."
     119 . D PAUSE^VALM1
     120 . Q
     121 ;
     122 D COBCOPY^IBCECOB2(IBIFN,IB364,1,$P(IBA,U,2),"INIT^IBCECSA2")
     123PROQ S VALMBCK="R"
     124 Q
     125 ;
     126RES ;Resubmit bill by print
     127 N IBTMP,IB364,IBIFN,IBX,IBA
     128 D FULL^VALM1
     129 S (IBTMP,IBDAX)=$O(IBDAX(0)),IBTMP(IBTMP)=IBDAX(IBDAX)
     130 S IBIFN=$P($G(IBDAX(+IBDAX)),U)
     131 S IB364=+$P($G(IBDAX(IBDAX)),U,5)
     132 I IBIFN D PRINT1^IBCEM03(IBIFN,.IBDAX,IB364),PAUSE^VALM1,INIT^IBCECSA2
     133 S IBDAX(IBTMP)=IBTMP(IBTMP)
     134 S VALMBCK="R"
     135 Q
     136 ;
     137EBI ;Edit bill
     138 N IBFLG,IBIFN,IB364,IBX,IBA
     139 K ^TMP($J,"IBBILL")
     140 D FULL^VALM1
     141 S IBDAX=$O(IBDAX(""))
     142 I IBDAX="" G EDITQ
     143 S IBIFN=$P(IBDAX(IBDAX),U)
     144 S IBFLG=1 D  I IBFLG S IBDAX="" D PAUSE^VALM1 G EDITQ
     145 . I $P($G(^DGCR(399,IBIFN,0)),U,13)>2 W !,*7,"An authorized bill can not be edited." Q
     146 . I '$D(^XUSEC("IB EDIT",DUZ)) W !,*7,"You are not authorized to edit a bill" Q
     147 . S IBFLG=0
     148 S IBIFN=+$G(IBDAX(IBDAX))
     149 S IB364=+$P($G(IBDAX(IBDAX)),U,5)
     150 D EBILL^IBCEM3(.IBDAX,IBIFN,IB364)
     151EDITQ S VALMBCK="R"
     152 Q
     153 ;
     154SEL(IBDA,ONE) ; Select entry(s) from list
     155 ; IBDA = array returned if selections made
     156 ;    IBDAX(n)=ien of bill selected (file 399)
     157 ; ONE = if set to 1, only one selection can be made at a time
     158 N IB
     159 K IBDA
     160 D EN^VALM2($G(XQORNOD(0)),$S('$G(ONE):"",1:"S"))
     161 S IBDA=0 F  S IBDA=$O(VALMY(IBDA)) Q:'IBDA  D
     162 . S IBDA(IBDA)=$P($G(^TMP("IBCECSA",$J,IBDA)),U,2,7)
     163 Q
     164 ;
     165RESUB(IBIFN,TXMT,IBFUNC,IBTBA) ; Function asks if resubmit as resolution to a
     166 ;   message is the intention
     167 ; IBIFN = ien of bill in file 399
     168 ; TXMT = flag if = 1, assume it's transmittable, don't have to check
     169 ; IBFUNC = code to say where the code is called from
     170 ;  'E'=edit/authorize  'P'=print 'PX'= print/not to resubmit  'C'=cancel
     171 ; IBTBA = transmit bill array returned to calling routine.  Optional
     172 ;    parameter to be passed by reference.
     173 ;    IBTBA(364ptr)=""
     174 ;
     175 ; Returns:
     176 ; -1 = ^ or timeout at prompt
     177 ;  0 = not a transmittable bill or review not needed
     178 ;  1 = don't update the review status (user choice)
     179 ;  2 = Yes, update the review status (user choice), or resubmit by print
     180 ;
     181 NEW DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT,STAT
     182 KILL IBTBA
     183 I '$G(TXMT),'$$TXMT^IBCEF4(IBIFN) S Y=0 G RESUB1   ; not transmittable
     184 ;
     185 ; Check for any messages or EOB's needing review
     186 S STAT=$$STATUS^IBCEF4(IBIFN)
     187 I '$TR(STAT,U) S Y=0 G RESUB1                ; no unreviewed items
     188 I $P(STAT,U,1) S IBTBA($P(STAT,U,1))=""      ; 364 ien for 361 data
     189 I $P(STAT,U,2) S IBTBA($P(STAT,U,2))=""      ; 364 ien for 361.1 data
     190 ;
     191 I IBFUNC'="P" D
     192 . S DIR(0)="YA",DIR("A",1)="",DIR("A",2)="This bill is in need of review due to receipt of a status msg or EOB",DIR("A")="OK to update the review status to 'REVIEW COMPLETE' based on this action?: ",DIR("B")="NO"
     193 . S DIR("?",1)="You have just "_$S(IBFUNC="E":"requested re-transmission of",IBFUNC="C":"cancelled",1:"")_" the bill"
     194 . S DIR("?",2)="You can update the review status of the unreviewed message to ",DIR("?",3)=" 'REVIEW COMPLETE' if you say YES here"
     195 . S DIR("?")="Press ENTER to continue "
     196 . D ^DIR K DIR
     197 . I $D(DTOUT)!$D(DUOUT) S Y=-1 Q
     198 . S Y=Y+1
     199 E  D
     200 . W !,"The review status of this message will be updated to 'REVIEW COMPLETE'",!,"  based on this action"
     201 . S Y=2
     202 ;
     203RESUB1 Q +Y
     204 ;
     205RETXMT ;
     206 N IB364,IBIFN
     207 D FULL^VALM1
     208 S IBDAX=$O(IBDAX(0)),IB364=+$P($G(IBDAX(IBDAX)),U,5),IBIFN=+$P($G(IBDAX(IBDAX)),U)
     209 I 'IB364!('IBIFN) G RETXMTQ
     210 D MRACHK I MRACHK G RETXMTQ
     211 D RESUB^IBCE(IB364)
     212RETXMTQ S VALMBCK="R"
     213 Q
     214 ;
     215MRACHK ; Restrict access to process REQUEST MRA claims
     216 S MRACHK=0
     217 ; At least one MRA EOB appears on the MRA management worklist
     218 I $P($G(^DGCR(399,IBIFN,0)),U,13)=2,$$MRAWL^IBCEMU2(IBIFN) S MRACHK=1 D  D PAUSE^VALM1
     219 . W !,?4,"This bill is in a status of REQUEST MRA and it does appear on"
     220 . W !,?4,"the MRA Management Worklist.  Please use the MRA Management Menu"
     221 . W !,?4,"options for all processing related to this bill."
     222 Q

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF.m

    r613 r623  
    1 IBCEF   ;ALB/TMP - FORMATTER SPECIFIC BILL FUNCTIONS ;22-JAN-96
    2         ;;2.0;INTEGRATED BILLING;**52,80,51,137,288,296,361,371**;21-MAR-94;Build 57
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5         ;IBIFN = bill ien throughout this routine
    6 COB(IBIFN)      ; Bill seq
    7         N A
    8         S A=$P($G(^DGCR(399,IBIFN,0)),U,21) S:A="" A="P"
    9         Q A
    10         ;
    11 COBN(IBIFN,A)   ; Return seq # of selected payer
    12         ; A = 'PST' or null to get current bill payer seq #
    13         I $G(A)="" S A=$$COB(IBIFN) S:"PST"'[A A="P"
    14         I 'A S A=$F("PST",A)-1 S:A<1 A=1
    15         Q A
    16         ;
    17 POLICY(IBIFN,IBPC,IBCOBN)       ; Return raw data from policy info on bill
    18         ; IBPC  = pc # of data element in policy (optional)
    19         ;          if null, 0-node is returned
    20         ; IBCOBN = bill designation 1-3 or 'PST' (optional)
    21         ;          if null, default to current
    22         N IBI
    23         I "PST"[$G(IBCOBN) S IBCOBN=$$COBN(IBIFN,$G(IBCOBN))
    24         S IBI=$G(^DGCR(399,IBIFN,"I"_IBCOBN))
    25         I $G(IBPC) S IBI=$P(IBI,U,IBPC)
    26 POLICYQ Q IBI
    27         ;
    28 INSADDR(IBIFN,IBCOB)    ; Return insured's address in 7 pieces:
    29         ; ALL STREET ADDRESSES^CITY^STATE ABBREVIATION^ZIP^STREET ADDRESS 1^
    30         ;  STREET ADDRESS 2^STREET ADDRESS 3
    31         ; IBIFN = bill ien
    32         ; IBCOB = bill designation (P)rimary, (S)econdary, (T)ertiary
    33         ;          or 1-2-3. If not defined or null, return current
    34         ; If insured is patient or spouse, take from patient file top level
    35         ;   fields, then if top-level street addresses are blank and policy
    36         ;   level fields are not, use policy level
    37         ; If insured is other than patient/spouse, use policy level fields only
    38         N A,B,IBADDR,IBI,DFN,VAPA,VATEST
    39         S:$G(IBCOB)="" IBCOB=""
    40         I 'IBCOB S IBCOB=$$COBN(IBIFN,$G(IBCOB))
    41         S IBI=+$$POLICY(IBIFN,16,IBCOB)     ; pt relationship to insured
    42         S DFN=+$P($G(^DGCR(399,IBIFN,0)),U,2)
    43         I $S('IBI:1,1:"12"'[IBI) S IBADDR="" G INSADDQ
    44         ; insured's address (patient/spouse) same as patient's
    45         S VATEST("ADD",9)=+$G(^DGCR(399,IBIFN,"U")),VATEST("ADD",10)=+$P($G(^("U")),U,2)
    46         D ADD^VADPT
    47         S IBADDR=VAPA(1)_" "_VAPA(2)_" "_VAPA(3)_U_VAPA(4)_U_$P($G(^DIC(5,+VAPA(5),0)),U,2)_U_VAPA(6)_U_VAPA(1)_U_VAPA(2)_U_VAPA(3)
    48 INSADDQ S A=$P($G(^DGCR(399,IBIFN,"M")),U,(11+IBCOB))
    49         S A=$G(^DPT(DFN,.312,+A,3))
    50         I $TR($P(IBADDR,U)," ")="" D PI3
    51         I IBI=2,$$NOPUNCT($P(A,U,6,10),1)'="" D PI3
    52         Q IBADDR
    53         ;
    54 PI3     ; build IBADDR string from patient insurance 3 node data
    55         S $P(IBADDR,U,1)=$P(A,U,6)_" "_$P(A,U,7)
    56         S $P(IBADDR,U,5,6)=$P(A,U,6,7)
    57         F B=2,4 S $P(IBADDR,U,B)=$P(A,U,B+6)
    58         S $P(IBADDR,U,3)=$P($G(^DIC(5,+$P(A,U,9),0)),U,2)
    59         S $P(IBADDR,U,7)=""   ; no street address 3 in file 2.312
    60         Q
    61         ;
    62 PTADDR(IBIFN,ELE)       ;Return part of patient's permanent address
    63         ;IBIFN = bill ien
    64         ;ELE = subscript in ^UTILITY("VAPA", array for element needed
    65         ;
    66         I '$D(^UTILITY("VAPA",$J)) D  ; once per pt
    67         .N VAHOW,DFN,VAPA
    68         .S VAHOW=2,DFN=+$P($G(^DGCR(399,IBIFN,0)),U,2),VAPA("P")=""
    69         .D ADD^VADPT
    70         Q $P($G(^UTILITY("VAPA",$J,ELE)),U)
    71         ;
    72 PTDEM(IBIFN,ELE,PC)     ;Return part of patient's demographics
    73         ;IBIFN = bill ien
    74         ;ELE = subscript in ^UTILITY("VADM" array for demographic element needed
    75         ;PC = pc of string at subscript ELE to be returned
    76         ;
    77         I '$G(PC) S PC=1
    78         I '$D(^UTILITY("VADM",$J)) D  ; once per pt
    79         .N VAHOW,DFN,VADM
    80         .S VAHOW=2,DFN=+$P($G(^DGCR(399,IBIFN,0)),U,2)
    81         .D DEM^VADPT
    82         Q $P($G(^UTILITY("VADM",$J,ELE)),U,PC)
    83         ;
    84 PTEMPL(IBIFN,ELE,WHOSE,VAOA)    ;Return part of pt's or spouse's employer info
    85         ;ELE = subscript in VAOA array for employer element needed
    86         ;WHOSE = 6 if spouse's info needed  5 if pt info needed (DEFAULT)
    87         ;
    88         N DFN
    89         S DFN=+$P($G(^DGCR(399,IBIFN,0)),U,2),VAOA("A")=$S($G(WHOSE):WHOSE,1:5)
    90         D OAD^VADPT
    91         Q $P($G(VAOA(ELE)),U)
    92         ;
    93 INSDEM(IBIFN,IBCOB)     ; Return insured's demographics in 6 pieces:
    94         ; DATE OF BIRTH^SEX^PHONE^BRANCH pointer^RANK^SSN(no dashes)
    95         ; IBIFN = bill ien
    96         ; IBCOB = bill designation (P)rimary (default), (S)econdary, (T)ertiary
    97         ;          or 1,2,3 ... if not defined or null, return current
    98         ; If insured is patient/spouse, take from patient file top level
    99         ;   fields, then if top-level are blank and policy level aren't,
    100         ;   use policy level
    101         ; If insured other than patient/spouse, use policy level fields only
    102         N A,B,IBDEM,IBI,DFN,VADM
    103         S:$G(IBCOB)="" IBCOB=""
    104         S:'IBCOB IBCOB=$$COBN(IBIFN,IBCOB)
    105         S IBI=$$WHOSINS(IBIFN,IBCOB)
    106         S DFN=+$P($G(^DGCR(399,IBIFN,0)),U,2)
    107         I $S('IBI:1,1:"12"'[IBI) S IBDEM="" G INSDEM1
    108         ; If it gets here, assume insured is patient/spouse
    109         S A=$$PTDEM(IBIFN,0),A=$$PTADDR(IBIFN,0)
    110         F A=2,3,5 S VADM(A)=$P($G(^UTILITY("VADM",$J,A)),U)
    111         S VAPA(8)=$P($G(^UTILITY("VAPA",$J,8)),U)
    112         I VADM(5)="",'VADM(3),VAPA(8)="" S IBDEM="" G INSDEM1
    113         S $P(IBDEM,U,3)=VAPA(8),$P(IBDEM,U,6)=VADM(2)
    114         I IBI=1,VADM(3) S $P(IBDEM,U)=VADM(3) ;Patient's own policy only
    115 INSDEM1 S A=$P($G(^DGCR(399,IBIFN,"M")),U,(11+IBCOB))
    116         S A=$G(^DPT(DFN,.312,+A,3))
    117         S:"MF"'[$G(VADM(5)) VADM(5)=""
    118         S $P(IBDEM,U,2)=$S(IBI=1:VADM(5),1:$P(A,U,12))
    119         S $P(IBDEM,U,4,5)=$P(A,U,2)_U_$P(A,U,3)
    120         S:'$P(IBDEM,U) $P(IBDEM,U)=$P(A,U)
    121         S:$P(IBDEM,U,3)="" $P(IBDEM,U,3)=$P(A,U,11)
    122         S:$P(IBDEM,U,6)="" $P(IBDEM,U,6)=$P(A,U,5)
    123         Q IBDEM
    124         ;
    125 INSEMPL(IBIFN,IBCOB)    ; Return insured's employer data in 5 pieces:
    126         ; EMPLOYER NAME^EMPLOYER CITY^EMPLOYER STATE ABBREVIATION^STATE IEN^STREET 1
    127         ; IBCOB = bill designation (P)rimary-default, (S)econdary, (T)ertiary
    128         ;            or 123 - if not defined or null, return current
    129         N A,IBEMPL,IBI,DFN,VAOA
    130         S IBI=$$WHOSINS(IBIFN,$G(IBCOB))
    131         I $S('IBI:1,1:"12"'[IBI) S IBEMPL="^^" G INSEMPQ
    132         ; insured = pt/spouse
    133         S DFN=+$P($G(^DGCR(399,IBIFN,0)),U,2)
    134         S A=$$PTEMPL(IBIFN,0,IBI+4,.VAOA)
    135         S IBEMPL=VAOA(9)_U_VAOA(4)_U_$P($G(^DIC(5,+VAOA(5),0)),U,2)_U_+VAOA(5)_U_VAOA(1)
    136 INSEMPQ Q IBEMPL
    137         ;
    138 WHOSINS(IBIFN,IBCOB)    ; Determine who is insured for bill IBIFN and
    139         ; seq of coverage COB (123 or PST) or if not defined or null, current
    140         N Z,Z0,VAEL,DFN
    141         S Z=+$$POLICY(IBIFN,16,$G(IBCOB))
    142         I 'Z D
    143         .S Z0=$$POLICY(IBIFN,6,$G(IBCOB)),DFN=$P($G(^DGCR(399,IBIFN,0)),U,2)
    144         .I Z0="v" D ELIG^VADPT I VAEL(4) S Z=1 Q  ;vet is pt
    145         .I Z0="s" D ELIG^VADPT I VAEL(4) S Z=2 Q  ;vet is pt, so vets spouse is pt's spouse
    146         .S Z=9 ; relationship of insured to pt unknown
    147         Q Z
    148         ;
    149 EMPSTAT(IBIFN,WHOSE)    ;Return employment status
    150         ; IBIFN = bill ien
    151         ; WHOSE = v for vet, s for spouse status
    152         N STAT,DFN,VAPD
    153         S STAT="",DFN=+$P($G(^DGCR(399,IBIFN,0)),U,2)
    154         I WHOSE="v" D OPD^VADPT S STAT=$P(VAPD(7),U)
    155         I WHOSE="s" S STAT=$P($G(^DPT(DFN,.25)),U,15)
    156         I STAT="" S STAT=9
    157         Q STAT
    158         ;
    159 INPAT(IBIFN,OUT)        ; Determine if bill is inpatient
    160         ; OUT = optional - if 1, return output value based on
    161         ;  inpatient/outpatient from UB-04 type of bill field
    162         ; Return 1 if inpatient, 0 if not inpatient or can't be determined
    163         N INPT,CODE,CODE0,IB0
    164         S IB0=$G(^DGCR(399,IBIFN,0))
    165         S OUT=+$G(OUT),CODE=+$P(IB0,U,5)
    166         I 'OUT S INPT=CODE
    167         I OUT D
    168         . S CODE0=$P($G(^DGCR(399.1,+$P(IB0,U,25),0)),U,2)
    169         . I CODE0=8,$P(IB0,U,24)=1 S INPT=$P(IB0,U,5) Q  ; 18X
    170         . I CODE0=9,$P(IB0,U,24)=8 S INPT=$P(IB0,U,5) Q  ; 89X
    171         . I CODE0=1,$P(IB0,U,24)=8 S INPT=0 Q  ; 81X
    172         . I CODE0=1,$P(IB0,U,24)=7 S INPT=0 Q  ; 71X
    173         . I CODE0=2,$P(IB0,U,24)=7 S INPT=0 Q  ; 72X
    174         . S INPT=CODE0
    175         Q $S(INPT:INPT'>2,1:0)
    176         ;
    177 INSPRF(IBIFN)   ; Function to determine if bill is prof or inst
    178         ; Return 1 if institutional (UB-04) claim, 0 if professional (CMS-1500) claim
    179         N A
    180         S A=$G(^DGCR(399,IBIFN,0))
    181         I $P(A,U,27)="" S $P(A,U,27)=$S($P(A,U,19)=3:1,1:0)
    182         Q $S($P(A,U,27)=1:1,1:0)
    183         ;
    184 F(FLD,IBXRET,IBXERR1,IBIEN)     ;Execute extract for data element FLD and bill IBIEN
    185         ; If IBXDATA array to be returned as data value(s) of fld
    186         ;   D F^IBCEF("FLD NAME","IBXDATA","IBXERR") or D F^IBCEF("FLD NAME")
    187         ; Variable ref-ed by IBXERR1 will contain error message if an error
    188         ; @IBXRET always defined on return.  It will be null if error
    189         I $G(IBIEN) N IBXIEN S IBXIEN=IBIEN
    190         I $G(IBXERR1)="" S IBXERR1="IBXERR"
    191         N IBXHOLD
    192         S IBXHOLD=""
    193         I $G(IBXRET)=""!($G(IBXRET)="IBXDATA") S IBXHOLD="IBXDATA",IBXRET="IBXRET"
    194         S @IBXERR1=""
    195         ;
    196         N FLDN,OFLD,STOP,Z,IBXERR2,IBXRETX
    197         ;
    198         I '$G(IBXIEN) S @IBXERR1="Invalid entry #" G FQ
    199         I '$D(^IBA(364.5,"B",FLD)) S OFLD=FLD,STOP=0 D  I FLD="" S @IBXERR1=OFLD_" Field not found!!" G FQ
    200         .F  S FLD=$O(^IBA(364.5,"B",FLD))  D  Q:STOP
    201         ..I $E(FLD,1,$L(OFLD))'=OFLD S FLD=""
    202         ..S STOP=1
    203         ;
    204         S Z=0
    205         F  S Z=$O(^IBA(364.5,"B",FLD,Z)) Q:'Z  I $P($G(^IBA(364.5,Z,0)),U,5)=399 Q
    206         I 'Z S @IBXERR1=FLD_" Field not found!!" G FQ
    207         ;
    208         S FLDN(1)=Z D EXTONE^IBCEFG0(IBXIEN,.FLDN,""_IBXRET_"",.IBXERR2)
    209         ;
    210         I $G(IBXERR2)'="" S @IBXERR1=IBXERR2
    211 FQ      S IBXARRY=$S(IBXHOLD="IBXDATA":"IBXDATA",1:""_IBXRET_"")
    212         I @IBXERR1'="" K @IBXARRY S @IBXARRY="" Q
    213         ;
    214         I IBXHOLD="IBXDATA" S IBXRET="IBXRET"
    215         M IBXRETX=@IBXRET K @IBXARRY M @IBXARRY=IBXRETX(1)
    216         S:'($D(@IBXARRY)#2) @IBXARRY=""
    217         Q
    218         ;
    219 SERVDT(IBIFN,LENGTH,FORMAT)     ; Return default service date for
    220         ; outpatient/UB-04 lines or X12-837 institutional lines
    221         ; LENGTH = null/8 for 8 digit date, 6 for 6 digit date
    222         ; FORMAT = 1 = X12 format (YYYYMMDD), 2 = FM internal (NNNNNNN),
    223         ;          0 = external (MMDDYY or MMDDYYYY)
    224         N IBZ
    225         G:$$INPAT^IBCEF(IBIFN,1)!($$FT^IBCEF(IBIFN)'=3) SERVDTQ ;Inpatient claim or billed on a CMS-1500
    226         S LENGTH=$G(LENGTH),FORMAT=$G(FORMAT)
    227         D F("N-STATEMENT COVERS FROM DATE","IBZ",,IBIFN)
    228         I '$G(IBZ)!(FORMAT=2) G SERVDTQ
    229         ;
    230         I FORMAT=1 S IBZ=$$DT^IBCEFG1(IBZ,"",$S(LENGTH'=6:"D8",1:"D6")) G SERVDTQ
    231         S IBZ=$$DATE^IBCF2(IBZ,$S(LENGTH=6:0,1:1),1)
    232         ;
    233 SERVDTQ Q $G(IBZ)
    234         ;
    235 NOPUNCT(X,SPACE,EXC)    ; Strip punctuation from data in X
    236         ; SPACE = flag if 1 strip SPACES
    237         ; EXC = list of punctuation not to strip
    238         ;
    239         N PUNCT,Z
    240         S PUNCT=".,-+(){}[]\/><:;?|=_*&%$#@!~`^'"""
    241         I $G(SPACE) S PUNCT=PUNCT_" "
    242         I $G(EXC)'="" F Z=1:1:$L(EXC) S PUNCT=$TR(PUNCT,$E(EXC,Z))
    243         S X=$TR(X,PUNCT)
    244         Q X
    245         ;
    246 FT(IBIFN)       ; Internal code for bill form type
    247         Q +$P($G(^DGCR(399,IBIFN,0)),U,19)
    248         ;
    249 COBCT(IBIFN)    ; # of payers on claim
    250         N CT,Z
    251         S CT=0 F Z="I1","I2","I3" Q:'$D(^DGCR(399,IBIFN,Z))  S CT=CT+1
    252         Q CT
    253         ;
     1IBCEF ;ALB/TMP - FORMATTER SPECIFIC BILL FUNCTIONS ;22-JAN-96
     2 ;;2.0;INTEGRATED BILLING;**52,80,51,137,288,296,361**;21-MAR-94;Build 9
     3 ;;Per VHA Directive 2004-038, this routine should not be modified.
     4 ;
     5 ;IBIFN = bill ien throughout this routine
     6COB(IBIFN) ; Bill seq
     7 N A
     8 S A=$P($G(^DGCR(399,IBIFN,0)),U,21) S:A="" A="P"
     9 Q A
     10 ;
     11COBN(IBIFN,A) ; Return seq # of selected payer
     12 ; A = 'PST' or null to get current bill payer seq #
     13 I $G(A)="" S A=$$COB(IBIFN) S:"PST"'[A A="P"
     14 I 'A S A=$F("PST",A)-1 S:A<1 A=1
     15 Q A
     16 ;
     17POLICY(IBIFN,IBPC,IBCOBN) ; Return raw data from policy info on bill
     18 ; IBPC  = pc # of data element in policy (optional)
     19 ;          if null, 0-node is returned
     20 ; IBCOBN = bill designation 1-3 or 'PST' (optional)
     21 ;          if null, default to current
     22 N IBI
     23 I "PST"[$G(IBCOBN) S IBCOBN=$$COBN(IBIFN,$G(IBCOBN))
     24 S IBI=$G(^DGCR(399,IBIFN,"I"_IBCOBN))
     25 I $G(IBPC) S IBI=$P(IBI,U,IBPC)
     26POLICYQ Q IBI
     27 ;
     28INSADDR(IBIFN,IBCOB) ; Return insured's address in 7 pieces:
     29 ; ALL STREET ADDRESSES^CITY^STATE ABBREVIATION^ZIP^STREET ADDRESS 1^
     30 ;  STREET ADDRESS 2^STREET ADDRESS 3
     31 ; IBIFN = bill ien
     32 ; IBCOB = bill designation (P)rimary, (S)econdary, (T)ertiary
     33 ;          or 1-2-3. If not defined or null, return current
     34 ; If insured is patient or spouse, take from patient file top level
     35 ;   fields, then if top-level street addresses are blank and policy
     36 ;   level fields are not, use policy level
     37 ; If insured is other than patient/spouse, use policy level fields only
     38 N A,B,IBADDR,IBI,DFN,VAPA,VATEST
     39 S:$G(IBCOB)="" IBCOB=""
     40 I 'IBCOB S IBCOB=$$COBN(IBIFN,$G(IBCOB))
     41 S IBI=+$$POLICY(IBIFN,16,IBCOB)
     42 S DFN=+$P($G(^DGCR(399,IBIFN,0)),U,2)
     43 I $S('IBI:1,1:"12"'[IBI) S IBADDR="" G INSADDQ
     44 ; insured's address (patient/spouse) same as patient's
     45 S VATEST("ADD",9)=+$G(^DGCR(399,IBIFN,"U")),VATEST("ADD",10)=+$P($G(^("U")),U,2)
     46 D ADD^VADPT
     47 S IBADDR=VAPA(1)_" "_VAPA(2)_" "_VAPA(3)_U_VAPA(4)_U_$P($G(^DIC(5,+VAPA(5),0)),U,2)_U_VAPA(6)_U_VAPA(1)_U_VAPA(2)_U_VAPA(3)
     48INSADDQ S A=$P($G(^DGCR(399,IBIFN,"M")),U,(11+IBCOB))
     49 S A=$G(^DPT(DFN,.312,+A,3))
     50 I $TR($P(IBADDR,U)," ")="" D
     51 .S $P(IBADDR,U)=$P(A,U,6)_" "_$P(A,U,7),$P(IBADDR,U,5,6)=$P(A,U,6,7)
     52 .F B=2,4 S $P(IBADDR,U,B)=$P(A,U,B+6)
     53 .S $P(IBADDR,U,3)=$P($G(^DIC(5,+$P(A,U,9),0)),U,2)
     54 Q IBADDR
     55 ;
     56PTADDR(IBIFN,ELE) ;Return part of patient's permanent address
     57 ;IBIFN = bill ien
     58 ;ELE = subscript in ^UTILITY("VAPA", array for element needed
     59 ;
     60 I '$D(^UTILITY("VAPA",$J)) D  ; once per pt
     61 .N VAHOW,DFN,VAPA
     62 .S VAHOW=2,DFN=+$P($G(^DGCR(399,IBIFN,0)),U,2),VAPA("P")=""
     63 .D ADD^VADPT
     64 Q $P($G(^UTILITY("VAPA",$J,ELE)),U)
     65 ;
     66PTDEM(IBIFN,ELE,PC) ;Return part of patient's demographics
     67 ;IBIFN = bill ien
     68 ;ELE = subscript in ^UTILITY("VADM" array for demographic element needed
     69 ;PC = pc of string at subscript ELE to be returned
     70 ;
     71 I '$G(PC) S PC=1
     72 I '$D(^UTILITY("VADM",$J)) D  ; once per pt
     73 .N VAHOW,DFN,VADM
     74 .S VAHOW=2,DFN=+$P($G(^DGCR(399,IBIFN,0)),U,2)
     75 .D DEM^VADPT
     76 Q $P($G(^UTILITY("VADM",$J,ELE)),U,PC)
     77 ;
     78PTEMPL(IBIFN,ELE,WHOSE,VAOA) ;Return part of pt's or spouse's employer info
     79 ;ELE = subscript in VAOA array for employer element needed
     80 ;WHOSE = 6 if spouse's info needed  5 if pt info needed (DEFAULT)
     81 ;
     82 N DFN
     83 S DFN=+$P($G(^DGCR(399,IBIFN,0)),U,2),VAOA("A")=$S($G(WHOSE):WHOSE,1:5)
     84 D OAD^VADPT
     85 Q $P($G(VAOA(ELE)),U)
     86 ;
     87INSDEM(IBIFN,IBCOB) ; Return insured's demographics in 6 pieces:
     88 ; DATE OF BIRTH^SEX^PHONE^BRANCH pointer^RANK^SSN(no dashes)
     89 ; IBIFN = bill ien
     90 ; IBCOB = bill designation (P)rimary (default), (S)econdary, (T)ertiary
     91 ;          or 1,2,3 ... if not defined or null, return current
     92 ; If insured is patient/spouse, take from patient file top level
     93 ;   fields, then if top-level are blank and policy level aren't,
     94 ;   use policy level
     95 ; If insured other than patient/spouse, use policy level fields only
     96 N A,B,IBDEM,IBI,DFN,VADM
     97 S:$G(IBCOB)="" IBCOB=""
     98 S:'IBCOB IBCOB=$$COBN(IBIFN,IBCOB)
     99 S IBI=$$WHOSINS(IBIFN,IBCOB)
     100 S DFN=+$P($G(^DGCR(399,IBIFN,0)),U,2)
     101 I $S('IBI:1,1:"12"'[IBI) S IBDEM="" G INSDEM1
     102 ; If it gets here, assume insured is patient/spouse
     103 S A=$$PTDEM(IBIFN,0),A=$$PTADDR(IBIFN,0)
     104 F A=2,3,5 S VADM(A)=$P($G(^UTILITY("VADM",$J,A)),U)
     105 S VAPA(8)=$P($G(^UTILITY("VAPA",$J,8)),U)
     106 I VADM(5)="",'VADM(3),VAPA(8)="" S IBDEM="" G INSDEM1
     107 S $P(IBDEM,U,3)=VAPA(8),$P(IBDEM,U,6)=VADM(2)
     108 I IBI=1,VADM(3) S $P(IBDEM,U)=VADM(3) ;Patient's own policy only
     109INSDEM1 S A=$P($G(^DGCR(399,IBIFN,"M")),U,(11+IBCOB))
     110 S A=$G(^DPT(DFN,.312,+A,3))
     111 S:"MF"'[$G(VADM(5)) VADM(5)=""
     112 S $P(IBDEM,U,2)=$S(IBI=1:VADM(5),1:$P(A,U,12))
     113 S $P(IBDEM,U,4,5)=$P(A,U,2)_U_$P(A,U,3)
     114 S:'$P(IBDEM,U) $P(IBDEM,U)=$P(A,U)
     115 S:$P(IBDEM,U,3)="" $P(IBDEM,U,3)=$P(A,U,11)
     116 S:$P(IBDEM,U,6)="" $P(IBDEM,U,6)=$P(A,U,5)
     117 Q IBDEM
     118 ;
     119INSEMPL(IBIFN,IBCOB) ; Return insured's employer data in 5 pieces:
     120 ; EMPLOYER NAME^EMPLOYER CITY^EMPLOYER STATE ABBREVIATION^STATE IEN^STREET 1
     121 ; IBCOB = bill designation (P)rimary-default, (S)econdary, (T)ertiary
     122 ;            or 123 - if not defined or null, return current
     123 N A,IBEMPL,IBI,DFN,VAOA
     124 S IBI=$$WHOSINS(IBIFN,$G(IBCOB))
     125 I $S('IBI:1,1:"12"'[IBI) S IBEMPL="^^" G INSEMPQ
     126 ; insured = pt/spouse
     127 S DFN=+$P($G(^DGCR(399,IBIFN,0)),U,2)
     128 S A=$$PTEMPL(IBIFN,0,IBI+4,.VAOA)
     129 S IBEMPL=VAOA(9)_U_VAOA(4)_U_$P($G(^DIC(5,+VAOA(5),0)),U,2)_U_+VAOA(5)_U_VAOA(1)
     130INSEMPQ Q IBEMPL
     131 ;
     132WHOSINS(IBIFN,IBCOB) ; Determine who is insured for bill IBIFN and
     133 ; seq of coverage COB (123 or PST) or if not defined or null, current
     134 N Z,Z0,VAEL,DFN
     135 S Z=+$$POLICY(IBIFN,16,$G(IBCOB))
     136 I 'Z D
     137 .S Z0=$$POLICY(IBIFN,6,$G(IBCOB)),DFN=$P($G(^DGCR(399,IBIFN,0)),U,2)
     138 .I Z0="v" D ELIG^VADPT I VAEL(4) S Z=1 Q  ;vet is pt
     139 .I Z0="s" D ELIG^VADPT I VAEL(4) S Z=2 Q  ;vet is pt, so vets spouse is pt's spouse
     140 .S Z=9 ; relationship of insured to pt unknown
     141 Q Z
     142 ;
     143EMPSTAT(IBIFN,WHOSE) ;Return employment status
     144 ; IBIFN = bill ien
     145 ; WHOSE = v for vet, s for spouse status
     146 N STAT,DFN,VAPD
     147 S STAT="",DFN=+$P($G(^DGCR(399,IBIFN,0)),U,2)
     148 I WHOSE="v" D OPD^VADPT S STAT=$P(VAPD(7),U)
     149 I WHOSE="s" S STAT=$P($G(^DPT(DFN,.25)),U,15)
     150 I STAT="" S STAT=9
     151 Q STAT
     152 ;
     153INPAT(IBIFN,OUT) ; Determine if bill is inpatient
     154 ; OUT = optional - if 1, return output value based on
     155 ;  inpatient/outpatient from UB-04 type of bill field
     156 ; Return 1 if inpatient, 0 if not inpatient or can't be determined
     157 N INPT,CODE,CODE0,IB0
     158 S IB0=$G(^DGCR(399,IBIFN,0))
     159 S OUT=+$G(OUT),CODE=+$P(IB0,U,5)
     160 I 'OUT S INPT=CODE
     161 I OUT D
     162 . S CODE0=$P($G(^DGCR(399.1,+$P(IB0,U,25),0)),U,2)
     163 . I CODE0=8,$P(IB0,U,24)=1 S INPT=$P(IB0,U,5) Q  ; 18X
     164 . I CODE0=9,$P(IB0,U,24)=8 S INPT=$P(IB0,U,5) Q  ; 89X
     165 . I CODE0=1,$P(IB0,U,24)=8 S INPT=0 Q  ; 81X
     166 . I CODE0=1,$P(IB0,U,24)=7 S INPT=0 Q  ; 71X
     167 . I CODE0=2,$P(IB0,U,24)=7 S INPT=0 Q  ; 72X
     168 . S INPT=CODE0
     169 Q $S(INPT:INPT'>2,1:0)
     170 ;
     171INSPRF(IBIFN) ; Function to determine if bill is prof or inst
     172 ; Return 1 if institutional (UB-04) claim, 0 if professional (CMS-1500) claim
     173 N A
     174 S A=$G(^DGCR(399,IBIFN,0))
     175 I $P(A,U,27)="" S $P(A,U,27)=$S($P(A,U,19)=3:1,1:0)
     176 Q $S($P(A,U,27)=1:1,1:0)
     177 ;
     178F(FLD,IBXRET,IBXERR1,IBIEN) ;Execute extract for data element FLD and bill IBIEN
     179 ; If IBXDATA array to be returned as data value(s) of fld
     180 ;   D F^IBCEF("FLD NAME","IBXDATA","IBXERR") or D F^IBCEF("FLD NAME")
     181 ; Variable ref-ed by IBXERR1 will contain error message if an error
     182 ; @IBXRET always defined on return.  It will be null if error
     183 I $G(IBIEN) N IBXIEN S IBXIEN=IBIEN
     184 I $G(IBXERR1)="" S IBXERR1="IBXERR"
     185 N IBXHOLD
     186 S IBXHOLD=""
     187 I $G(IBXRET)=""!($G(IBXRET)="IBXDATA") S IBXHOLD="IBXDATA",IBXRET="IBXRET"
     188 S @IBXERR1=""
     189 ;
     190 N FLDN,OFLD,STOP,Z,IBXERR2,IBXRETX
     191 ;
     192 I '$G(IBXIEN) S @IBXERR1="Invalid entry #" G FQ
     193 I '$D(^IBA(364.5,"B",FLD)) S OFLD=FLD,STOP=0 D  I FLD="" S @IBXERR1=OFLD_" Field not found!!" G FQ
     194 .F  S FLD=$O(^IBA(364.5,"B",FLD))  D  Q:STOP
     195 ..I $E(FLD,1,$L(OFLD))'=OFLD S FLD=""
     196 ..S STOP=1
     197 ;
     198 S Z=0
     199 F  S Z=$O(^IBA(364.5,"B",FLD,Z)) Q:'Z  I $P($G(^IBA(364.5,Z,0)),U,5)=399 Q
     200 I 'Z S @IBXERR1=FLD_" Field not found!!" G FQ
     201 ;
     202 S FLDN(1)=Z D EXTONE^IBCEFG0(IBXIEN,.FLDN,""_IBXRET_"",.IBXERR2)
     203 ;
     204 I $G(IBXERR2)'="" S @IBXERR1=IBXERR2
     205FQ S IBXARRY=$S(IBXHOLD="IBXDATA":"IBXDATA",1:""_IBXRET_"")
     206 I @IBXERR1'="" K @IBXARRY S @IBXARRY="" Q
     207 ;
     208 I IBXHOLD="IBXDATA" S IBXRET="IBXRET"
     209 M IBXRETX=@IBXRET K @IBXARRY M @IBXARRY=IBXRETX(1)
     210 S:'($D(@IBXARRY)#2) @IBXARRY=""
     211 Q
     212 ;
     213SERVDT(IBIFN,LENGTH,FORMAT) ; Return default service date for
     214 ; outpatient/UB-04 lines or X12-837 institutional lines
     215 ; LENGTH = null/8 for 8 digit date, 6 for 6 digit date
     216 ; FORMAT = 1 = X12 format (YYYYMMDD), 2 = FM internal (NNNNNNN),
     217 ;          0 = external (MMDDYY or MMDDYYYY)
     218 N IBZ
     219 G:$$INPAT^IBCEF(IBIFN,1)!($$FT^IBCEF(IBIFN)'=3) SERVDTQ ;Inpatient claim or billed on a CMS-1500
     220 S LENGTH=$G(LENGTH),FORMAT=$G(FORMAT)
     221 D F("N-STATEMENT COVERS FROM DATE","IBZ",,IBIFN)
     222 I '$G(IBZ)!(FORMAT=2) G SERVDTQ
     223 ;
     224 I FORMAT=1 S IBZ=$$DT^IBCEFG1(IBZ,"",$S(LENGTH'=6:"D8",1:"D6")) G SERVDTQ
     225 S IBZ=$$DATE^IBCF2(IBZ,$S(LENGTH=6:0,1:1),1)
     226 ;
     227SERVDTQ Q $G(IBZ)
     228 ;
     229NOPUNCT(X,SPACE,EXC) ; Strip punctuation from data in X
     230 ; SPACE = flag if 1 strip SPACES
     231 ; EXC = list of punctuation not to strip
     232 ;
     233 N PUNCT,Z
     234 S PUNCT=".,-+(){}[]\/><:;?|=_*&%$#@!~`^'"""
     235 I $G(SPACE) S PUNCT=PUNCT_" "
     236 I $G(EXC)'="" F Z=1:1:$L(EXC) S PUNCT=$TR(PUNCT,$E(EXC,Z))
     237 S X=$TR(X,PUNCT)
     238 Q X
     239 ;
     240FT(IBIFN) ; Internal code for bill form type
     241 Q +$P($G(^DGCR(399,IBIFN,0)),U,19)
     242 ;
     243COBCT(IBIFN) ; # of payers on claim
     244 N CT,Z
     245 S CT=0 F Z="I1","I2","I3" Q:'$D(^DGCR(399,IBIFN,Z))  S CT=CT+1
     246 Q CT
     247 ;

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF1.m

    r613 r623  
    1 IBCEF1  ;ALB/TMP - FORMATTER SPECIFIC BILL FUNCTIONS - CONT ;30-JAN-96
    2         ;;2.0;INTEGRATED BILLING;**52,124,51,137,210,155,349,371**;21-MAR-94;Build 57
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5 OCC(IBIFN,REL,TEXT)     ;Sets up an arrays of occurrence codes for various cks
    6         ;RETURNS 1^additional data for entry IBXSAVE("OCC",n) if REL or TEXT
    7         ;   parameters have been met or null if conditions not met
    8         ;If no REL or TEXT parameters sent, just extract codes array
    9         ; IBIFN = bill ien
    10         ; REL = 'OCC RELATED TO' value to check for
    11         ; TEXT = text to check for the .01 field of 399.1 entry pointed to
    12         ;         by the occurrence code
    13         N OCC,SORT,ARR,N,DATA,CODE,CT
    14         I '$D(IBXSAVE("OCC")),'$D(IBXSAVE("OCCS")) D
    15         .N IBI,Z,CT1,CT2,Z0 S (IBI,CT1,CT2)=0
    16         .F  S IBI=$O(^DGCR(399,IBIFN,"OC",IBI)) Q:'IBI  S Z=$G(^(IBI,0)) D
    17         ..S Z0=$G(^DGCR(399.1,+Z,0))
    18         ..Q:'$P(Z0,U,10)&'$P(Z0,U,4)  ;Not an occurrence code
    19         ..I $P(Z0,U,10) S CT2=CT2+1,IBXSAVE("OCCS",CT2)=$S($P(Z0,U,4):$P(Z0,U,2)_U_$P(Z,U,2),1:U)_U_$P(Z,U,4)_U_$P(Z0,U)_U_$P(Z0,U,9)_U_$P(Z,U,3)_U_$P(Z,U,2)
    20         ..I '$P(Z0,U,10) S CT1=CT1+1,IBXSAVE("OCC",CT1)=$S($P(Z0,U,4):$P(Z0,U,2)_U_$P(Z,U,2),1:U)_U_U_$P(Z0,U)_U_$P(Z0,U,9)_U_$P(Z,U,3)_U_$P(Z,U,2)
    21         I '$D(IBXSAVE("OCC"))&'$D(IBXSAVE("OCCS")) S IBXSAVE("OCC")="" G OCCQ
    22         ;
    23         ; esg - IB*2*349 - order the occurrence codes
    24         ;       Build the SORT array sorted by the occ code
    25         F ARR="OCC","OCCS" S N=0 F  S N=$O(IBXSAVE(ARR,N)) Q:'N  S DATA=$G(IBXSAVE(ARR,N)) I $P(DATA,U,1)'="" S CODE=" "_$P(DATA,U,1),SORT(ARR,CODE,N)=DATA
    26         ;       Loop thru the SORT array and re-build the IBXSAVE array
    27         F ARR="OCC","OCCS" K IBXSAVE(ARR) S CODE="",CT=0 F  S CODE=$O(SORT(ARR,CODE)) Q:CODE=""  S N=0 F  S N=$O(SORT(ARR,CODE,N)) Q:'N  S CT=CT+1,IBXSAVE(ARR,CT)=SORT(ARR,CODE,N)
    28         ;
    29         I $G(REL)'=""!($G(TEXT)'="") D OCC1("",.OCC,$G(REL),$G(TEXT)) D:'$D(OCC) OCC1("S",.OCC,$G(REL),$G(TEXT))
    30 OCCQ    Q $G(OCC)
    31         ;
    32 OCC1(ARR,OCC,REL,TEXT)  ; Search thru local array for parameters met
    33         ; ARR = null to search OCC subscript, "S" to search OCCS subscript
    34         N Z
    35         S ARR="OCC"_ARR,Z=0
    36         F  S Z=$O(IBXSAVE(ARR,Z)) Q:'Z  D
    37         .I $G(REL)'="",$P(IBXSAVE(ARR,Z),U,5)=REL S OCC="1"_$S(REL=2:U_$P(IBXSAVE(ARR,Z),U,6),1:"") Q
    38         .I $G(TEXT)'="",$P(IBXSAVE(ARR,Z),U,4)=TEXT S OCC="1^"_$P(IBXSAVE(ARR,Z),U,7)
    39         Q
    40         ;
    41 RX(IBIFN)       ; Format billable prescription data for refills for 837
    42         N Z,IBXDATA,CT
    43         I '$D(IBXSAVE("BOX24")) D B24^IBCEF3(.IBXSAVE,IBIFN,1)
    44         S Z="",CT=0
    45         F  S Z=$O(IBXSAVE("BOX24",Z)) Q:Z=""  I $D(IBXSAVE("BOX24",Z,"RX")) S CT=CT+1,IBXDATA(Z)=IBXSAVE("BOX24",Z,"RX")
    46 RXQ     Q CT
    47         ;
    48 OTHPAY(IBIFN,SEQ)       ; Return the other insurance payment amount for bill
    49         ;  IBIFN and payer sequence SEQ (1-3)
    50         N AMT,IBIFN1
    51         S IBIFN1=$P($G(^DGCR(399,IBIFN,"M1")),U,SEQ+4)
    52         I IBIFN1 D
    53         . I $$MCRWNR^IBEFUNC(+$G(^DGCR(399,IBIFN,"I"_SEQ))) S AMT=$$MCRPAY^IBCEU0(IBIFN) Q
    54         . S AMT=+$$TPR^PRCAFN(IBIFN1) Q:AMT  ; A/R amount
    55         . S AMT=+$P($G(^DGCR(399,IBIFN,"U2")),U,SEQ+3) ; amount on bill
    56         Q $G(AMT)
    57         ;
    58 OUTPT(IBIFN,IBPRINT)    ; Moved for space
    59         D OUTPT^IBCEF11(IBIFN,$G(IBPRINT))
    60         Q
    61         ;
    62 OCC92   ;Reformats IBXSAVE("OCC") and IBXSAVE("OCCS") to fit blocks on UB-04
    63         ; Set up IBXSAVE(32-36) arrays
    64         N IBPG,IB32,IB33,IB34,IB35,IB36,IBFL,Z,Z0,PG
    65         S IBPG=0
    66         F Z=32:1:36 K IBFL(Z) S IBFL(Z)=0
    67         M IB32=IBXSAVE("OCC"),IB36=IBXSAVE("OCCS")
    68         S IB32=$O(IB32(""),-1),IB36=$O(IB36(""),-1),PG=1
    69         D OCC^IBCF32
    70         F Z=32:1:36 S Z0="" F  S Z0=$O(IBFL(Z,Z0)) Q:'Z0  S IBXSAVE("OC92",Z,Z0)=$P(IBFL(Z,Z0),U,1,3)
    71         Q
    72         ;
    73 BATCH() ; Moved for space IB*2*349
    74         Q $$BATCH^IBCEF11()
    75         ;
    76 PROC(T,TYPE)    ; Find procedure code, strip '.' Function returns result
    77         ; T = Procedure internal entry #;file reference
    78         ; TYPE = "CPT" for only CPT/HCPCS valid
    79         ;        "ICD" for only ICD9 valid or null for either
    80         N Q,S
    81         S Q="",S="^"_$P($P(T,";",2),"(")
    82         I $G(TYPE)="" D
    83         . I $E(S,2,3)="IC" S Q=$P($$PRCD(T),U) Q
    84         . I T["DIC(81.3" S Q=$$MOD^ICPTMOD(+T,"I") S Q=$S(Q>0:$P(Q,U,4),1:"")
    85         I $G(TYPE)="CPT",$E(S,2,3)="IC" S Q=$$PRCD(T) Q
    86         I $G(TYPE)="ICD",T["ICD0" S Q=$P($$ICD0^IBACSV(+T),U)
    87         Q $TR(Q,".")
    88         ;
    89 FACILITY(IBIFN) ;return the Facility (Institution pointer-#4) for a bill
    90         ; the institution of the Bill Division (399,.22) if defined, otherwise the Facility Name (350.9,.02)
    91         ;
    92         N IB0,IBIN S IBIN=0
    93         S IB0=$G(^DGCR(399,+$G(IBIFN),0)) I +$P(IB0,U,22) S IBIN=$$SITE^VASITE(+$P(IB0,U,3),+$P(IB0,U,22))
    94         I IBIN'>0 S IBIN=+$P($G(^IBE(350.9,1,0)),U,2)
    95         Q +IBIN
    96         ;
    97 ISRX(IBIFN)     ; Function to determine if bill is a prescription refill bill
    98         ; Returns 0 if no Rx on bill or 1 if there is.
    99         ;
    100         N IBRX
    101         I $D(^IBA(362.4,"AIFN"_IBIFN)) S IBRX=1
    102         Q +$G(IBRX)
    103         ;
    104 ISPROS(IBIFN)   ; Function to determine if bill is a prosthetics bill
    105         ; Returns 0 if no Prosthetics on bill or 1 if there is.
    106         ;
    107         N IBPROS
    108         I $D(^IBA(362.5,"AIFN"_IBIFN)) S IBPROS=1
    109         Q +$G(IBPROS)
    110         ;
    111 FINDINS(IBIFN,IBSEQ)    ; Returns the internal entry number of the insurance
    112         ;  company for bill ien IBIFN for payer sequence IBSEQ (or current if
    113         ;  IBSEQ is null)
    114         Q $P($G(^DGCR(399,IBIFN,"I"_$$COBN^IBCEF(IBIFN,$G(IBSEQ)))),U)
    115         ;
    116 TOB(IBIFN)      ; Returns UB-04 type of bill from data in the output formatter
    117         N IBTOB,IBZ1,IBZ2,IBZ3
    118         D F^IBCEF("N-UB-04 LOCATION OF CARE","IBZ1",,IBIFN)
    119         D F^IBCEF("N-UB-04 BILL CLASSIFICATION","IBZ2",,IBIFN)
    120         D F^IBCEF("N-UB-04 TIMEFRAME OF BILL","IBZ3",,IBIFN)
    121         S IBTOB=IBZ1_IBZ2_IBZ3
    122         Q IBTOB
    123         ;
    124 PRCD(PRIEN,ALL,EDT)     ; Function returns the code that corresponds to the variable
    125         ; pointer data in PRIEN (ien;file)
    126         ; ALL = if ALL=1, returns the entire $$CPT^ICPTCOD for CPT or
    127         ;       ^code^name format for ICD result
    128         ;       or null if lookup fails
    129         ; EDT = Effective date to check (not used if +$G(ALL)=0)
    130         N CODE,IBX
    131         S CODE=""
    132         ;Modified for Code Set Versioning
    133         I PRIEN["ICPT" S IBX=$$CPT^ICPTCOD(+PRIEN,$G(EDT)) G:IBX'>0 PRCDQ S CODE=$S($G(ALL):IBX,1:$P(IBX,U,2))
    134         I PRIEN["ICD0" S IBX=$$ICD0^IBACSV(+PRIEN,$G(EDT)) G:IBX="" PRCDQ S CODE=$S($G(ALL):U_$P(IBX,U)_U_$P(IBX,U,4),1:$P(IBX,U))
    135 PRCDQ   Q CODE
    136         ;
    137 NFT(FT,IBIFN)   ; Returns 1 if bill IBIFN is not of form type FT (internal)
    138         ; so the data element should not be required
    139         S FT=$S($$FT^IBCEF(IBIFN)=FT:0,1:1)
    140         Q FT
    141         ;
    142 REQ(FT,INP,IBIFN)       ; Determine if bill IBIFN is of form type FT and
    143         ; Inpatient (I) or Outpatient (O) status INP [or either if (null)]
    144         ;
    145         ;Returns 1 if both conditions FT and INP match for the bill
    146         ; or 0 if either of these conditions are not true
    147         ; I $$REQ^IBCEF1(2,"I",1) would mean if bill entry #1 is
    148         ;                         CMS-1500/inpatient the data would be required
    149         ; I '$$REQ^IBCEF1(2,"I",1) would mean if bill entry #1 is anything but
    150         ;                          CMS-1500/inpatient, the data would not be
    151         ;                          required
    152         N Z
    153         S Z=1
    154         S:$$NFT(FT,IBIFN) Z=0 ; Not the form type for requirement
    155         I Z,$G(INP)'="" D
    156         . S Z0=$$INPAT^IBCEF(IBIFN,1),INP=$G(INP)
    157         . S Z=$S(Z0:INP="I",1:INP="O") ;Check if I/O matches required state
    158         Q Z
    159         ;
    160 SET1(IBIFN,A,IBZ,IBXDATA,IBXNOREQ)      ; Utility to set variables for output
    161         ; formatter for professional EDI
    162         ; Returns values of A, IBXDATA, IBZ, IBXNOREQ
    163         N Z,CT
    164         S A="^TMP($J,""IBLCT"")"
    165         S (Z,CT)=0
    166         F  S Z=$O(IBXDATA(Z)) Q:'Z  D  ; Don't transmit 0-charges
    167         . I $P(IBXDATA(Z),U,9),$P(IBXDATA(Z),U,8) S CT=CT+1 M IBZ(CT)=IBXDATA(Z)
    168         K IBXDATA
    169         S IBXNOREQ='$$REQ(2,"O",IBIFN)
    170         Q
    171         ;
    172 CIADDR(IBXDATA,IBXSAVE,LINE,FORM)       ; Format current ins co address line LINE for FORM
    173         ; FORM = 1 for CMS-1500, 2 for UB-04
    174         ; Called from output formatter - both IBXDATA, IBXSAVE parameters are
    175         ;  passed by reference
    176         ;
    177         K IBXDATA
    178         I $G(FORM)'=1 D
    179         . ;
    180         . ; esg - 11/17/06 - IB*2*349 - UB-04 FL-38 contains the payer name
    181         . ;       and address on 4 lines within this 5 line box.  All 5 lines
    182         . ;       are formatted here into the IBXDATA array.  This is the
    183         . ;       address that shows through the envelope window.
    184         . ;
    185         . ; esg - 9/13/07 - IB*2*371 - Line 1 of this box contains the print
    186         . ;       status (i.e. copy, 2nd notice, 3rd notice, MRA needed).
    187         . ;
    188         . N Z,Z1,LM,Q,ADDR,X,IBPSTAT
    189         . S LM=$P($G(^IBE(350.9,1,1)),U,31)   ; UB address column parameter
    190         . S Z=""
    191         . I LM S $P(Z," ",LM)=""              ; beginning spaces indent
    192         . S ADDR=$G(IBXSAVE("CADR"))          ; address data string
    193         . ;
    194         . D F^IBCEF("N-PRINT BILL SUBMIT STATUS","IBPSTAT",,+$G(IBXIEN))
    195         . S Z1=Z I Z1="" S Z1=" "     ; line 1 can't start in column 1
    196         . S IBXDATA(1)=Z1_$G(IBPSTAT),Q=1             ; line 1 print status
    197         . S Q=Q+1
    198         . S IBXDATA(Q)=Z_$G(IBXSAVE("CADR_NAME"))     ; line 2 payer name
    199         . S X=$P(ADDR,U,1)
    200         . I X'="" S Q=Q+1,IBXDATA(Q)=Z_X              ; address line 1
    201         . S X=$P(ADDR,U,2)
    202         . I X'="" S Q=Q+1,IBXDATA(Q)=Z_X D            ; address line 2
    203         .. S X=$P(ADDR,U,3)
    204         .. I X'="" S IBXDATA(Q)=IBXDATA(Q)_" "_X      ; address line 3
    205         .. Q
    206         . S Q=Q+1                                     ; city,st,zip on last line
    207         . S IBXDATA(Q)=Z_$P(ADDR,U,4)_", "_$$STATE^IBCEFG1($P(ADDR,U,5))_" "_$P(ADDR,U,6)
    208         . KILL IBXSAVE("CADR_NAME"),IBXSAVE("CADR")   ; cleanup
    209         . Q
    210         ;
    211         I $G(FORM)=1 D           ; CMS-1500
    212         . N CT,X,Z
    213         . S:'$D(IBXSAVE("INDENT")) Z="",$P(Z," ",+$P($G(^IBE(350.9,1,1)),U,27)+1)="",IBXSAVE("INDENT")=Z
    214         . S CT=0
    215         . S X=$P(IBXSAVE("CADR"),U) S:X'="" CT=CT+1,IBXDATA(CT)=IBXSAVE("INDENT")_X
    216         . S X=$S($P(IBXSAVE("CADR"),U,2)'="":$P(IBXSAVE("CADR"),U,2),1:"")_$S($P(IBXSAVE("CADR"),U,2)'="":" ",1:"")_$P(IBXSAVE("CADR"),U,3) S:X'="" CT=CT+1,IBXDATA(CT)=IBXSAVE("INDENT")_X
    217         . S CT=CT+1,IBXDATA(CT)=IBXSAVE("INDENT")_$P(IBXSAVE("CADR"),U,4)_", "_$$STATE^IBCEFG1($P(IBXSAVE("CADR"),U,5))_" "_$P(IBXSAVE("CADR"),U,6)
    218         . Q
    219         ;
    220         Q
    221         ;
     1IBCEF1 ;ALB/TMP - FORMATTER SPECIFIC BILL FUNCTIONS - CONT ;30-JAN-96
     2 ;;2.0;INTEGRATED BILLING;**52,124,51,137,210,155,349**;21-MAR-94;Build 46
     3 ;;Per VHA Directive 2004-038, this routine should not be modified.
     4 ;
     5OCC(IBIFN,REL,TEXT) ;Sets up an arrays of occurrence codes for various cks
     6 ;RETURNS 1^additional data for entry IBXSAVE("OCC",n) if REL or TEXT
     7 ;   parameters have been met or null if conditions not met
     8 ;If no REL or TEXT parameters sent, just extract codes array
     9 ; IBIFN = bill ien
     10 ; REL = 'OCC RELATED TO' value to check for
     11 ; TEXT = text to check for the .01 field of 399.1 entry pointed to
     12 ;         by the occurrence code
     13 N OCC,SORT,ARR,N,DATA,CODE,CT
     14 I '$D(IBXSAVE("OCC")),'$D(IBXSAVE("OCCS")) D
     15 .N IBI,Z,CT1,CT2,Z0 S (IBI,CT1,CT2)=0
     16 .F  S IBI=$O(^DGCR(399,IBIFN,"OC",IBI)) Q:'IBI  S Z=$G(^(IBI,0)) D
     17 ..S Z0=$G(^DGCR(399.1,+Z,0))
     18 ..Q:'$P(Z0,U,10)&'$P(Z0,U,4)  ;Not an occurrence code
     19 ..I $P(Z0,U,10) S CT2=CT2+1,IBXSAVE("OCCS",CT2)=$S($P(Z0,U,4):$P(Z0,U,2)_U_$P(Z,U,2),1:U)_U_$P(Z,U,4)_U_$P(Z0,U)_U_$P(Z0,U,9)_U_$P(Z,U,3)_U_$P(Z,U,2)
     20 ..I '$P(Z0,U,10) S CT1=CT1+1,IBXSAVE("OCC",CT1)=$S($P(Z0,U,4):$P(Z0,U,2)_U_$P(Z,U,2),1:U)_U_U_$P(Z0,U)_U_$P(Z0,U,9)_U_$P(Z,U,3)_U_$P(Z,U,2)
     21 I '$D(IBXSAVE("OCC"))&'$D(IBXSAVE("OCCS")) S IBXSAVE("OCC")="" G OCCQ
     22 ;
     23 ; esg - IB*2*349 - order the occurrence codes
     24 ;       Build the SORT array sorted by the occ code
     25 F ARR="OCC","OCCS" S N=0 F  S N=$O(IBXSAVE(ARR,N)) Q:'N  S DATA=$G(IBXSAVE(ARR,N)) I $P(DATA,U,1)'="" S CODE=" "_$P(DATA,U,1),SORT(ARR,CODE,N)=DATA
     26 ;       Loop thru the SORT array and re-build the IBXSAVE array
     27 F ARR="OCC","OCCS" K IBXSAVE(ARR) S CODE="",CT=0 F  S CODE=$O(SORT(ARR,CODE)) Q:CODE=""  S N=0 F  S N=$O(SORT(ARR,CODE,N)) Q:'N  S CT=CT+1,IBXSAVE(ARR,CT)=SORT(ARR,CODE,N)
     28 ;
     29 I $G(REL)'=""!($G(TEXT)'="") D OCC1("",.OCC,$G(REL),$G(TEXT)) D:'$D(OCC) OCC1("S",.OCC,$G(REL),$G(TEXT))
     30OCCQ Q $G(OCC)
     31 ;
     32OCC1(ARR,OCC,REL,TEXT) ; Search thru local array for parameters met
     33 ; ARR = null to search OCC subscript, "S" to search OCCS subscript
     34 N Z
     35 S ARR="OCC"_ARR,Z=0
     36 F  S Z=$O(IBXSAVE(ARR,Z)) Q:'Z  D
     37 .I $G(REL)'="",$P(IBXSAVE(ARR,Z),U,5)=REL S OCC="1"_$S(REL=2:U_$P(IBXSAVE(ARR,Z),U,6),1:"") Q
     38 .I $G(TEXT)'="",$P(IBXSAVE(ARR,Z),U,4)=TEXT S OCC="1^"_$P(IBXSAVE(ARR,Z),U,7)
     39 Q
     40 ;
     41RX(IBIFN) ; Format billable prescription data for refills for 837
     42 N Z,IBXDATA,CT
     43 I '$D(IBXSAVE("BOX24")) D B24^IBCEF3(.IBXSAVE,IBIFN,1)
     44 S Z="",CT=0
     45 F  S Z=$O(IBXSAVE("BOX24",Z)) Q:Z=""  I $D(IBXSAVE("BOX24",Z,"RX")) S CT=CT+1,IBXDATA(Z)=IBXSAVE("BOX24",Z,"RX")
     46RXQ Q CT
     47 ;
     48OTHPAY(IBIFN,SEQ) ; Return the other insurance payment amount for bill
     49 ;  IBIFN and payer sequence SEQ (1-3)
     50 N AMT,IBIFN1
     51 S IBIFN1=$P($G(^DGCR(399,IBIFN,"M1")),U,SEQ+4)
     52 I IBIFN1 D
     53 . I $$MCRWNR^IBEFUNC(+$G(^DGCR(399,IBIFN,"I"_SEQ))) S AMT=$$MCRPAY^IBCEU0(IBIFN) Q
     54 . S AMT=+$$TPR^PRCAFN(IBIFN1) Q:AMT  ; A/R amount
     55 . S AMT=+$P($G(^DGCR(399,IBIFN,"U2")),U,SEQ+3) ; amount on bill
     56 Q $G(AMT)
     57 ;
     58OUTPT(IBIFN,IBPRINT) ; Moved for space
     59 D OUTPT^IBCEF11(IBIFN,$G(IBPRINT))
     60 Q
     61 ;
     62OCC92 ;Reformats IBXSAVE("OCC") and IBXSAVE("OCCS") to fit blocks on UB-04
     63 ; Set up IBXSAVE(32-36) arrays
     64 N IBPG,IB32,IB33,IB34,IB35,IB36,IBFL,Z,Z0,PG
     65 S IBPG=0
     66 F Z=32:1:36 K IBFL(Z) S IBFL(Z)=0
     67 M IB32=IBXSAVE("OCC"),IB36=IBXSAVE("OCCS")
     68 S IB32=$O(IB32(""),-1),IB36=$O(IB36(""),-1),PG=1
     69 D OCC^IBCF32
     70 F Z=32:1:36 S Z0="" F  S Z0=$O(IBFL(Z,Z0)) Q:'Z0  S IBXSAVE("OC92",Z,Z0)=$P(IBFL(Z,Z0),U,1,3)
     71 Q
     72 ;
     73BATCH() ; Moved for space IB*2*349
     74 Q $$BATCH^IBCEF11()
     75 ;
     76PROC(T,TYPE) ; Find procedure code, strip '.' Function returns result
     77 ; T = Procedure internal entry #;file reference
     78 ; TYPE = "CPT" for only CPT/HCPCS valid
     79 ;        "ICD" for only ICD9 valid or null for either
     80 N Q,S
     81 S Q="",S="^"_$P($P(T,";",2),"(")
     82 I $G(TYPE)="" D
     83 . I $E(S,2,3)="IC" S Q=$P($$PRCD(T),U) Q
     84 . I T["DIC(81.3" S Q=$$MOD^ICPTMOD(+T,"I") S Q=$S(Q>0:$P(Q,U,4),1:"")
     85 I $G(TYPE)="CPT",$E(S,2,3)="IC" S Q=$$PRCD(T) Q
     86 I $G(TYPE)="ICD",T["ICD0" S Q=$P($$ICD0^IBACSV(+T),U)
     87 Q $TR(Q,".")
     88 ;
     89FACILITY(IBIFN) ;return the Facility (Institution pointer-#4) for a bill
     90 ; the institution of the Bill Division (399,.22) if defined, otherwise the Facility Name (350.9,.02)
     91 ;
     92 N IB0,IBIN S IBIN=0
     93 S IB0=$G(^DGCR(399,+$G(IBIFN),0)) I +$P(IB0,U,22) S IBIN=$$SITE^VASITE(+$P(IB0,U,3),+$P(IB0,U,22))
     94 I IBIN'>0 S IBIN=+$P($G(^IBE(350.9,1,0)),U,2)
     95 Q +IBIN
     96 ;
     97ISRX(IBIFN) ; Function to determine if bill is a prescription refill bill
     98 ; Returns 0 if no Rx on bill or 1 if there is.
     99 ;
     100 N IBRX
     101 I $D(^IBA(362.4,"AIFN"_IBIFN)) S IBRX=1
     102 Q +$G(IBRX)
     103 ;
     104ISPROS(IBIFN) ; Function to determine if bill is a prosthetics bill
     105 ; Returns 0 if no Prosthetics on bill or 1 if there is.
     106 ;
     107 N IBPROS
     108 I $D(^IBA(362.5,"AIFN"_IBIFN)) S IBPROS=1
     109 Q +$G(IBPROS)
     110 ;
     111FINDINS(IBIFN,IBSEQ) ; Returns the internal entry number of the insurance
     112 ;  company for bill ien IBIFN for payer sequence IBSEQ (or current if
     113 ;  IBSEQ is null)
     114 Q $P($G(^DGCR(399,IBIFN,"I"_$$COBN^IBCEF(IBIFN,$G(IBSEQ)))),U)
     115 ;
     116TOB(IBIFN) ; Returns UB-04 type of bill from data in the output formatter
     117 N IBTOB,IBZ1,IBZ2,IBZ3
     118 D F^IBCEF("N-UB-04 LOCATION OF CARE","IBZ1",,IBIFN)
     119 D F^IBCEF("N-UB-04 BILL CLASSIFICATION","IBZ2",,IBIFN)
     120 D F^IBCEF("N-UB-04 TIMEFRAME OF BILL","IBZ3",,IBIFN)
     121 S IBTOB=IBZ1_IBZ2_IBZ3
     122 Q IBTOB
     123 ;
     124PRCD(PRIEN,ALL,EDT) ; Function returns the code that corresponds to the variable
     125 ; pointer data in PRIEN (ien;file)
     126 ; ALL = if ALL=1, returns the entire $$CPT^ICPTCOD for CPT or
     127 ;       ^code^name format for ICD result
     128 ;       or null if lookup fails
     129 ; EDT = Effective date to check (not used if +$G(ALL)=0)
     130 N CODE,IBX
     131 S CODE=""
     132 ;Modified for Code Set Versioning
     133 I PRIEN["ICPT" S IBX=$$CPT^ICPTCOD(+PRIEN,$G(EDT)) G:IBX'>0 PRCDQ S CODE=$S($G(ALL):IBX,1:$P(IBX,U,2))
     134 I PRIEN["ICD0" S IBX=$$ICD0^IBACSV(+PRIEN,$G(EDT)) G:IBX="" PRCDQ S CODE=$S($G(ALL):U_$P(IBX,U)_U_$P(IBX,U,4),1:$P(IBX,U))
     135PRCDQ Q CODE
     136 ;
     137NFT(FT,IBIFN) ; Returns 1 if bill IBIFN is not of form type FT (internal)
     138 ; so the data element should not be required
     139 S FT=$S($$FT^IBCEF(IBIFN)=FT:0,1:1)
     140 Q FT
     141 ;
     142REQ(FT,INP,IBIFN) ; Determine if bill IBIFN is of form type FT and
     143 ; Inpatient (I) or Outpatient (O) status INP [or either if (null)]
     144 ;
     145 ;Returns 1 if both conditions FT and INP match for the bill
     146 ; or 0 if either of these conditions are not true
     147 ; I $$REQ^IBCEF1(2,"I",1) would mean if bill entry #1 is
     148 ;                         CMS-1500/inpatient the data would be required
     149 ; I '$$REQ^IBCEF1(2,"I",1) would mean if bill entry #1 is anything but
     150 ;                          CMS-1500/inpatient, the data would not be
     151 ;                          required
     152 N Z
     153 S Z=1
     154 S:$$NFT(FT,IBIFN) Z=0 ; Not the form type for requirement
     155 I Z,$G(INP)'="" D
     156 . S Z0=$$INPAT^IBCEF(IBIFN,1),INP=$G(INP)
     157 . S Z=$S(Z0:INP="I",1:INP="O") ;Check if I/O matches required state
     158 Q Z
     159 ;
     160SET1(IBIFN,A,IBZ,IBXDATA,IBXNOREQ) ; Utility to set variables for output
     161 ; formatter for professional EDI
     162 ; Returns values of A, IBXDATA, IBZ, IBXNOREQ
     163 N Z,CT
     164 S A="^TMP($J,""IBLCT"")"
     165 S (Z,CT)=0
     166 F  S Z=$O(IBXDATA(Z)) Q:'Z  D  ; Don't transmit 0-charges
     167 . I $P(IBXDATA(Z),U,9),$P(IBXDATA(Z),U,8) S CT=CT+1 M IBZ(CT)=IBXDATA(Z)
     168 K IBXDATA
     169 S IBXNOREQ='$$REQ(2,"O",IBIFN)
     170 Q
     171 ;
     172CIADDR(IBXDATA,IBXSAVE,LINE,FORM) ; Format current ins co address line LINE for FORM
     173 ; FORM = 1 for CMS-1500, 2 for UB-04
     174 ; Called from output formatter - both IBXDATA, IBXSAVE parameters are
     175 ;  passed by reference
     176 ;
     177 K IBXDATA
     178 I $G(FORM)'=1 D
     179 . ;
     180 . ; esg - 11/17/06 - IB*2*349 - UB-04 FL-38 contains the payer name
     181 . ;       and address on 4 lines within this 5 line box.  All 5 lines
     182 . ;       are formatted here into the IBXDATA array.  This is the
     183 . ;       address that shows through the envelope window.
     184 . ;
     185 . N Z,LM,Q,ADDR,X
     186 . S LM=$P($G(^IBE(350.9,1,1)),U,31)   ; UB address column parameter
     187 . S Z=""
     188 . I LM S $P(Z," ",LM)=""              ; beginning spaces indent
     189 . S ADDR=$G(IBXSAVE("CADR"))          ; address data string
     190 . S IBXDATA(1)="",Q=1                 ; line 1 is blank
     191 . S Q=Q+1
     192 . S IBXDATA(Q)=Z_$G(IBXSAVE("CADR_NAME"))     ; line 2 payer name
     193 . S X=$P(ADDR,U,1)
     194 . I X'="" S Q=Q+1,IBXDATA(Q)=Z_X              ; address line 1
     195 . S X=$P(ADDR,U,2)
     196 . I X'="" S Q=Q+1,IBXDATA(Q)=Z_X D            ; address line 2
     197 .. S X=$P(ADDR,U,3)
     198 .. I X'="" S IBXDATA(Q)=IBXDATA(Q)_" "_X      ; address line 3
     199 .. Q
     200 . S Q=Q+1                                     ; city,st,zip on last line
     201 . S IBXDATA(Q)=Z_$P(ADDR,U,4)_", "_$$STATE^IBCEFG1($P(ADDR,U,5))_" "_$P(ADDR,U,6)
     202 . KILL IBXSAVE("CADR_NAME"),IBXSAVE("CADR")   ; cleanup
     203 . Q
     204 ;
     205 I $G(FORM)=1 D           ; CMS-1500
     206 . N CT,X,Z
     207 . S:'$D(IBXSAVE("INDENT")) Z="",$P(Z," ",+$P($G(^IBE(350.9,1,1)),U,27)+1)="",IBXSAVE("INDENT")=Z
     208 . S CT=0
     209 . S X=$P(IBXSAVE("CADR"),U) S:X'="" CT=CT+1,IBXDATA(CT)=IBXSAVE("INDENT")_X
     210 . S X=$S($P(IBXSAVE("CADR"),U,2)'="":$P(IBXSAVE("CADR"),U,2),1:"")_$S($P(IBXSAVE("CADR"),U,2)'="":" ",1:"")_$P(IBXSAVE("CADR"),U,3) S:X'="" CT=CT+1,IBXDATA(CT)=IBXSAVE("INDENT")_X
     211 . S CT=CT+1,IBXDATA(CT)=IBXSAVE("INDENT")_$P(IBXSAVE("CADR"),U,4)_", "_$$STATE^IBCEFG1($P(IBXSAVE("CADR"),U,5))_" "_$P(IBXSAVE("CADR"),U,6)
     212 . Q
     213 ;
     214 Q
     215 ;

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF11.m

    r613 r623  
    1 IBCEF11 ;ALB/TMP - FORMATTER SPECIFIC BILL FUNCTIONS - CONT ;30-JAN-96
    2         ;;2.0;INTEGRATED BILLING;**51,137,155,309,335,348,349,371**;21-MAR-94;Build 57
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5 BOX24D(A,IB)    ; Returns the lines for boxes 19-24 of the CMS-1500 display
    6         ; IB = flag is 1 if only box 24 is needed
    7         Q $S('$G(IB):"36",1:"44")_"^55"
    8         ;
    9 RCBOX() ; Returns the lines for revenue code boxes of the UB-04 display
    10         Q "19^41"
    11         ;
    12 OUTPT(IBIFN,IBPRINT)    ; Returns an array of service line data from
    13         ;                 CMS-1500 box 24.  Output is in IBXDATA(n)
    14         ; IBPRINT = print flag  1: return print fields
    15         ;                       0: return EDI fields
    16         ; Uses diagnosis array ^TMP("IBXSAVE",$J,"DX",IBIFN,DIAG CODE)=SEQ #
    17         ;   if it already exists. If not, it builds it from N-DIAGNOSES element
    18         ;
    19         ; For EDI call: Returns IBXDATA(n)=
    20         ;   begin date(YYYYMMDD)^end date(YYYYMMDD)^pos^tos^
    21         ;   proc code/revenue code - if no procedure (not the pointers)^
    22         ;   type of code^dx pointer(s)^unit charge^units^modifiers separated by;
    23         ;   ^purchased charge amount ^anesthesia minutes^emergency indicator^
    24         ;   lab-type service flag.
    25         ;
    26         ;   Also Returns IBXDATA(IBI,"COB",COB,m) with COB data for each line
    27         ;      item found in an accepted EOB for the bill and = the reference
    28         ;      line in the first '^' piece followed by the '0' node data of file
    29         ;      361.115 (LINE LEVEL ADJUSTMENTS)
    30         ;       COB = COB sequence # of adjustment's ins co, m = seq #
    31         ;         -- AND --
    32         ;    IBXDATA(IBI,"COB",COB,m,z,p)=
    33         ;           the data on the '0' node for each subordinate entry of file
    34         ;           361.11511 (REASONS) (Only first 3 pieces for 837 output)
    35         ;       z = group code, sometimes preceeded by a space   p = seq #
    36         ;
    37         ; For Print call: Returns begin date(DDMMYYYY)^end date(DDMMYYYY) or
    38         ;   null if equal to begin date^pos^tos^bedsection name(if no procedure)
    39         ;   or procedure code(not the pointer)^ ... refer to EDI call results
    40         ;   Also, IBXDATA(n,"TEXT")=the text to print on first line of box 24,
    41         ;   If no procedure code, returns IBXDATA(n,"A")=rev code abbrev
    42         ;
    43         ;  For both calls, returns IBXDATA(n,item type,item ptr)=""
    44         ;      -- AND --
    45         ;   IBXDATA(n,"RX")=RX#^drug name^NDC^refill #^(re)fill date^qty^days
    46         ;                   ^chrge^ien of file 362.4^NDC format
    47         ;           If line references a prescription
    48         ;      -- AND --
    49         ;   If no revenue code for a prescription, returns IBXDATA(n,"ARX")=""
    50         ;      -- AND --
    51         ;   IBXDATA(n,"AUX")='AUX' node of the procedure entry
    52         ;
    53         N IB,IBI,IBJ,IBFLD,IBDXI,IBXIEN,Z,IBXTRA,IBRX,IBRX0,IBRX1,Z0,Z1
    54         ;
    55         K ^TMP($J,"IBITEM")
    56         S ^TMP($J,"IBITEM")=""
    57         ; Build diagnosis array if not already built
    58         I $O(^TMP("IBXSAVE",$J,"DX",IBIFN,""))="",$O(^IBA(362.3,"AIFN"_IBIFN,"")) D
    59         .N Z,IBXDATA D F^IBCEF("N-DIAGNOSES",,,IBIFN)
    60         .S Z="" F  S Z=$O(IBXDATA(Z)) K:$O(IBXDATA(0))=""&(Z="") IBXDATA Q:Z=""  S:$P(IBXDATA(Z),U,2) ^TMP("IBXSAVE",$J,"DX",IBIFN,$P(IBXDATA(Z),U,2))=Z
    61         ;
    62         S IB(0)=$G(^DGCR(399,IBIFN,0)),IB("U")=$G(^("U")),IB("U1")=$G(^("U1"))
    63         S IBI="" F  S IBI=$O(^TMP("IBXSAVE",$J,"DX",IBIFN,IBI)) Q:IBI=""  S IBDXI(IBI)=^(IBI)
    64         I '$G(IBPRINT) D RVCE^IBCF23(IBIFN,IBIFN)
    65         I $G(IBPRINT) D RVCE^IBCF23(,IBIFN)
    66         ; Returns IBFLD(24) = begin date^end date^pos^tos^
    67         ;     proc/bedsection/revenue code^dx pointer^unit charge^
    68         ;     units^modifiers^ purchased charge amount ^anesthesia minutes^
    69         ;     emergency indicator ^ AND
    70         ;         IBFLD(24,n,type,item)=""
    71         ;         IBFLD(24,n_"A") = revenue code abbreviation if no procedure
    72         ;         IBFLD(24,n,"AUX") = 'AUX' node of line item
    73         ;         IBFLD(24,n,"RX") = soft pointer to file 362.4 from 'item' fld
    74         ;                            (can be null)
    75         ;
    76         D SET^IBCSC5A(IBIFN,.IBRX) ;prescriptions
    77         ; IBRX1(ien 362.4)=RX#^drug ien^NDC^refil #^(re)fil date^qty^days^chrge
    78         I IBRX S IBRX="" F  S IBRX=$O(IBRX(IBRX)) Q:IBRX=""  S IBRX0=0 F  S IBRX0=$O(IBRX(IBRX,IBRX0)) Q:'IBRX0  D
    79         . N IBRXH
    80         . S IBRXH=IBRX(IBRX,IBRX0)
    81         . S IBRX1(+IBRXH)=IBRX_U_$P(IBRXH,U,2)_U_$P(IBRXH,U,5)_U_$P(IBRXH,U,7)_U_IBRX0_U_$P(IBRXH,U,4)_U_$P(IBRXH,U,3)_U_$P(IBRXH,U,6)_U_+IBRXH_U_$P(IBRXH,U,8)
    82         K IBRX
    83         ;
    84         ; for EDI, remove any $0 line items from the IBFLD array before
    85         ; dropping down into the next loop (IB*2*371)
    86         I '$G(IBPRINT) D
    87         . NEW IBZ,IBI,Z
    88         . M IBZ=IBFLD K IBFLD
    89         . S (IBI,Z)=0
    90         . F  S IBI=$O(IBZ(24,IBI)) Q:IBI'=+IBI  D
    91         .. I $P(IBZ(24,IBI),U,7)*$P(IBZ(24,IBI),U,8)'>0 Q
    92         .. S Z=Z+1
    93         .. M IBFLD(24,Z)=IBZ(24,IBI)
    94         .. S IBFLD(24)=Z
    95         .. Q
    96         . Q
    97         ;
    98         S IBI=0
    99         F  S IBI=$O(IBFLD(24,IBI)) Q:IBI'=+IBI  D
    100         . S IBRX1=0
    101         . S IBXDATA(IBI)=$P(IBFLD(24,IBI),U)_U_$P(IBFLD(24,IBI),U,$S($P(IBFLD(24,IBI),U,2)=""&'$G(IBPRINT):1,1:2))
    102         . S $P(IBXDATA(IBI),U,3,5)=$P(IBFLD(24,IBI),U,3,5)
    103         . S $P(IBXDATA(IBI),U,6)=$S($D(IBFLD(24,IBI_"X")):"CJ",1:"HC")
    104         . S $P(IBXDATA(IBI),U,7,13)=$P(IBFLD(24,IBI),U,6,12)
    105         . S $P(IBXDATA(IBI),U,14)=+$$ISLAB(IBXDATA(IBI))
    106         . ;
    107         . I $D(IBFLD(24,IBI,"RX")) D  ;Rx
    108         .. S IBRX1=1
    109         .. I $P($G(IBFLD(24,IBI,"AUX")),U,8)'="" S $P(IBFLD(24,IBI,"AUX"),U,8)="",$P(IBFLD(24,IBI,"AUX"),U,9)=""  ;No free text allowed for rx's
    110         .. I $D(IBRX1(+IBFLD(24,IBI,"RX"))) D  Q  ;Soft link exists
    111         ...D ZERO^IBRXUTL(+$P(IBRX1(+IBFLD(24,IBI,"RX")),U,2))
    112         ... S IBXDATA(IBI,"RX")=IBRX1(+IBFLD(24,IBI,"RX")),$P(IBXDATA(IBI,"RX"),U,2)=$E($G(^TMP($J,"IBDRUG",+$P(IBRX1(+IBFLD(24,IBI,"RX")),U,2),.01)),1,30)
    113         ... K IBRX1(+IBFLD(24,IBI,"RX"))
    114         ... ; No soft link - must find the first Rx with the same charge
    115         .. S IBRX="" F  S IBRX=$O(IBRX1(IBRX)) Q:'IBRX  I +$P(IBRX1(IBRX),U,8)=+$P(IBXDATA(IBI),U,8) D  Q
    116         ... D ZERO^IBRXUTL(+$P(IBRX1(IBRX),U,2))
    117         ... S IBXDATA(IBI,"RX")=IBRX1(IBRX),$P(IBXDATA(IBI,"RX"),U,2)=$E($G(^TMP($J,"IBDRUG",+$P(IBRX1(IBRX),U,2),.01)),1,30) K IBRX1(IBRX) Q
    118         ... Q
    119         .. Q
    120         . ;
    121         . I $G(IBFLD(24,IBI,"AUX"))'="" D
    122         .. I $G(IBPRINT),$P(IBFLD(24,IBI,"AUX"),U,8)'="" S IBXDATA(IBI,"TEXT")=$P(IBFLD(24,IBI,"AUX"),U,8),$P(IBFLD(24,IBI,"AUX"),U,8)=""
    123         .. S IBXDATA(IBI,"AUX")=IBFLD(24,IBI,"AUX")
    124         .. Q
    125         . ;
    126         . I $G(IBPRINT) D
    127         .. I '$P(IBXDATA(IBI),U,8),'$G(IBXDATA(IBI,"RX")) D  Q
    128         ... I $G(IBNOSHOW) Q    ; don't show errors/warnings
    129         ... S IBXDATA(IBI,"TEXT")="Warning:** REV CODE UNITS < #PROCEDURES, THEY MUST BE ="
    130         ... I $D(IBXDATA(IBI,"AUX")) S $P(IBXDATA(IBI,"AUX"),U,9)=""
    131         ... Q
    132         .. ;
    133         .. I $G(IBFLD(24,IBI_"A"))'="" D  Q
    134         ... S IBXDATA(IBI,"A")=IBFLD(24,IBI_"A")
    135         ... I $G(IBNOSHOW) Q    ; don't show errors/warnings
    136         ... S IBXDATA(IBI,"TEXT")="Warning:** REV CODE UNITS > #PROCEDURES, THEY MUST BE=: "_IBFLD(24,IBI_"A")
    137         ... I $D(IBXDATA(IBI,"AUX")) S $P(IBXDATA(IBI,"AUX"),U,9)=""
    138         ... Q
    139         .. ;
    140         .. S IBRX=$G(IBXDATA(IBI,"RX"))
    141         .. I IBRX'="" D  ;Format Rx detail
    142         ... N Z
    143         ... S Z=$P(IBRX,U)
    144         ... S Z=$S(Z'="":"Rx#"_Z_" ",1:"RX: ")
    145         ... S IBXDATA(IBI,"TEXT")=Z_$S($P(IBRX,U,3)'="":"NDC: "_$P(IBRX,U,3),1:"NOC: "_$P(IBRX,U,2))_" Qty: "_$P(IBRX,U,6)_" Days: "_$P(IBRX,U,7)
    146         ... S $P(IBXDATA(IBI,"AUX"),U,9)="N4"   ; service line comment qualifier for RX's
    147         ... Q
    148         .. Q
    149         . ;
    150         . I '$G(IBPRINT) D COBLINE^IBCEU6(IBIFN,IBI,.IBXDATA,,.IBXTRA)
    151         . Q
    152         ;
    153         I $G(IBPRINT) D
    154         . S IBRX=0 F  S IBRX=$O(IBRX1(IBRX)) Q:'IBRX  D
    155         .. S IBI=+$O(IBXDATA(""),-1)+1
    156         .. S IBXDATA(IBI)=$$DATE($P(IBRX1(IBRX),U,5))
    157         .. S IBXDATA(IBI,"TEXT")="**** ERROR - NO PROC LINK TO REV CODE FOR DRUG: RX#: "_$P(IBRX1(IBRX),U)_"  NDC #: "_$P(IBRX1(IBRX),U,3)
    158         .. I $D(IBXDATA(IBI,"AUX")) S $P(IBXDATA(IBI,"AUX"),U,9)=""
    159         .. S IBXDATA(IBI,"ARX")=""
    160         .. D ZERO^IBRXUTL(+$P(IBRX1(IBRX),U,2))
    161         .. S IBXDATA(IBI,"RX")=IBRX1(IBRX),$P(IBXDATA(IBI,"RX"),U,2)=$E($G(^TMP($J,"IBDRUG",+$P(IBRX1(IBRX),U,2),.01)),1,30) K IBRX1(IBRX)
    162         .. Q
    163         . Q
    164         ;
    165         I '$G(IBPRINT),$D(IBXTRA) D COMBO^IBCEU2(.IBXDATA,.IBXTRA,0) ;Handle bundled/unbundled lines
    166         K ^TMP($J,"IBDRUG")
    167         Q
    168         ;
    169 ISLAB(LDATA)    ; Returns 0/1 if line item data indicates the item is a lab (1)
    170         ; 'LAB' is defined here as type of service = 5
    171         Q $E($P(LDATA,U,4))="5"
    172         ;
    173 FMT(DATA,DLEN,FLEN)     ; Returns a string in DATA with a max length of DLEN
    174         ;  and a field length of FLEN
    175         Q $E($E(DATA,1,DLEN)_$J("",FLEN),1,FLEN)
    176         ;
    177 DATE(X,DEL)     ;  Returns FM date in X as MMxDDxYYYY  where x=DEL
    178         S DEL=$G(DEL)
    179         S X=$$DATE^IBCF2(X,1,1)
    180         I X'="" S X=$E(X,1,2)_DEL_$E(X,3,4)_DEL_$E(X,5,8)
    181         Q X
    182         ;
    183 BATCH() ; Sets up record for and stores/returns the next batch number
    184         N NUM,FAC,DO,DD,DLAYGO,DIC,X,Y
    185         ;Keep latest batch number for view/print edi bill extract data option
    186         I $D(IBVNUM) S NUM=IBVNUM G BATCHQ
    187         ;Check for batch resubmit - if yes, use same number as original batch
    188         I $P($G(^TMP("IBRESUBMIT",$J)),U,3)=1 S NUM=$P(^($J),U) G BATCHQ
    189         L +^IBA(364.1,0):5 I '$T Q 0
    190         S FAC=+$P($$SITE^VASITE(),U,3),NUM=$O(^IBA(364.1,"B",""),-1)
    191         I $D(^IBA(364.1,+NUM,0)),$P(^(0),U,2)="" F  D  Q:'NUM!($P($G(^IBA(364.1,+NUM,0)),U,2)'="")
    192         . I $D(^IBA(364.1,NUM,0)) S DA=NUM,DIK="^IBA(364.1," D ^DIK
    193         . S NUM=$O(^IBA(364.1,"B",""),-1)
    194         F  S NUM=$S($P(NUM,FAC,2)'="":NUM+1,1:FAC_"0000001") Q:'$D(^IBA(364.1,"B",NUM))
    195         K DO,DD S DIC="^IBA(364.1,",DLAYGO=364.1,DIC(0)="L",X=NUM D FILE^DICN K DD,DO I Y'>0 S NUM=0
    196         L -^IBA(364.1,0)
    197 BATCHQ  Q NUM
    198         ;
     1IBCEF11 ;ALB/TMP - FORMATTER SPECIFIC BILL FUNCTIONS - CONT ;30-JAN-96
     2 ;;2.0;INTEGRATED BILLING;**51,137,155,309,335,348,349**;21-MAR-94;Build 46
     3 ;;Per VHA Directive 2004-038, this routine should not be modified.
     4 ;
     5BOX24D(A,IB) ; Returns the lines for boxes 19-24 of the CMS-1500 display
     6 ; IB = flag is 1 if only box 24 is needed
     7 Q $S('$G(IB):"36",1:"44")_"^55"
     8 ;
     9RCBOX() ; Returns the lines for revenue code boxes of the UB-04 display
     10 Q "19^41"
     11 ;
     12OUTPT(IBIFN,IBPRINT) ; Returns an array of service line data from
     13 ;                 CMS-1500 box 24.  Output is in IBXDATA(n)
     14 ; IBPRINT = print flag  1: return print fields
     15 ;                       0: return EDI fields
     16 ; Uses diagnosis array ^TMP("IBXSAVE",$J,"DX",IBIFN,DIAG CODE)=SEQ #
     17 ;   if it already exists. If not, it builds it from N-DIAGNOSES element
     18 ;
     19 ; For EDI call: Returns IBXDATA(n)=
     20 ;   begin date(YYYYMMDD)^end date(YYYYMMDD)^pos^tos^
     21 ;   proc code/revenue code - if no procedure (not the pointers)^
     22 ;   type of code^dx pointer(s)^unit charge^units^modifiers separated by;
     23 ;   ^purchased charge amount ^anesthesia minutes^emergency indicator^
     24 ;   lab-type service flag.
     25 ;
     26 ;   Also Returns IBXDATA(IBI,"COB",COB,m) with COB data for each line
     27 ;      item found in an accepted EOB for the bill and = the reference
     28 ;      line in the first '^' piece followed by the '0' node data of file
     29 ;      361.115 (LINE LEVEL ADJUSTMENTS)
     30 ;       COB = COB sequence # of adjustment's ins co, m = seq #
     31 ;         -- AND --
     32 ;    IBXDATA(IBI,"COB",COB,m,z,p)=
     33 ;           the data on the '0' node for each subordinate entry of file
     34 ;           361.11511 (REASONS) (Only first 3 pieces for 837 output)
     35 ;       z = group code, sometimes preceeded by a space   p = seq #
     36 ;
     37 ; For Print call: Returns begin date(DDMMYYYY)^end date(DDMMYYYY) or
     38 ;   null if equal to begin date^pos^tos^bedsection name(if no procedure)
     39 ;   or procedure code(not the pointer)^ ... refer to EDI call results
     40 ;   Also, IBXDATA(n,"TEXT")=the text to print on first line of box 24,
     41 ;   If no procedure code, returns IBXDATA(n,"A")=rev code abbrev
     42 ;
     43 ;  For both calls, returns IBXDATA(n,item type,item ptr)=""
     44 ;      -- AND --
     45 ;   IBXDATA(n,"RX")=RX#^drug name^NDC^refill #^(re)fill date^qty^days
     46 ;                   ^chrge^ien of file 362.4^NDC format
     47 ;           If line references a prescription
     48 ;      -- AND --
     49 ;   If no revenue code for a prescription, returns IBXDATA(n,"ARX")=""
     50 ;      -- AND --
     51 ;   IBXDATA(n,"AUX")='AUX' node of the procedure entry
     52 ;
     53 N IB,IBI,IBJ,IBFLD,IBDXI,IBXIEN,Z,IBXTRA,IBRX,IBRX0,IBRX1,Z0,Z1
     54 ;
     55 K ^TMP($J,"IBITEM")
     56 S ^TMP($J,"IBITEM")=""
     57 ; Build diagnosis array if not already built
     58 I $O(^TMP("IBXSAVE",$J,"DX",IBIFN,""))="",$O(^IBA(362.3,"AIFN"_IBIFN,"")) D
     59 .N Z,IBXDATA D F^IBCEF("N-DIAGNOSES",,,IBIFN)
     60 .S Z="" F  S Z=$O(IBXDATA(Z)) K:$O(IBXDATA(0))=""&(Z="") IBXDATA Q:Z=""  S:$P(IBXDATA(Z),U,2) ^TMP("IBXSAVE",$J,"DX",IBIFN,$P(IBXDATA(Z),U,2))=Z
     61 ;
     62 S IB(0)=$G(^DGCR(399,IBIFN,0)),IB("U")=$G(^("U")),IB("U1")=$G(^("U1"))
     63 S IBI="" F  S IBI=$O(^TMP("IBXSAVE",$J,"DX",IBIFN,IBI)) Q:IBI=""  S IBDXI(IBI)=^(IBI)
     64 I '$G(IBPRINT) D RVCE^IBCF23(IBIFN,IBIFN)
     65 I $G(IBPRINT) D RVCE^IBCF23(,IBIFN)
     66 ; Returns IBFLD(24) = begin date^end date^pos^tos^
     67 ;     proc/bedsection/revenue code^dx pointer^unit charge^
     68 ;     units^modifiers^ purchased charge amount ^anesthesia minutes^
     69 ;     emergency indicator ^ AND
     70 ;         IBFLD(24,n,type,item)=""
     71 ;         IBFLD(24,n_"A") = revenue code abbreviation if no procedure
     72 ;         IBFLD(24,n,"AUX") = 'AUX' node of line item
     73 ;         IBFLD(24,n,"RX") = soft pointer to file 362.4 from 'item' fld
     74 ;                            (can be null)
     75 ;
     76 D SET^IBCSC5A(IBIFN,.IBRX) ;prescriptions
     77 ; IBRX1(ien 362.4)=RX#^drug ien^NDC^refil #^(re)fil date^qty^days^chrge
     78 I IBRX S IBRX="" F  S IBRX=$O(IBRX(IBRX)) Q:IBRX=""  S IBRX0=0 F  S IBRX0=$O(IBRX(IBRX,IBRX0)) Q:'IBRX0  D
     79 . N IBRXH
     80 . S IBRXH=IBRX(IBRX,IBRX0)
     81 . S IBRX1(+IBRXH)=IBRX_U_$P(IBRXH,U,2)_U_$P(IBRXH,U,5)_U_$P(IBRXH,U,7)_U_IBRX0_U_$P(IBRXH,U,4)_U_$P(IBRXH,U,3)_U_$P(IBRXH,U,6)_U_+IBRXH_U_$P(IBRXH,U,8)
     82 K IBRX
     83 ;
     84 S IBI=0
     85 F  S IBI=$O(IBFLD(24,IBI)) Q:IBI'=+IBI  D
     86 . S IBRX1=0
     87 . I '$G(IBPRINT) Q:$P(IBFLD(24,IBI),U,7)*$P(IBFLD(24,IBI),U,8)'>0  ; For EDI, ignore 0-charge line items
     88 . S IBXDATA(IBI)=$P(IBFLD(24,IBI),U)_U_$P(IBFLD(24,IBI),U,$S($P(IBFLD(24,IBI),U,2)=""&'$G(IBPRINT):1,1:2))
     89 . S $P(IBXDATA(IBI),U,3,5)=$P(IBFLD(24,IBI),U,3,5)
     90 . S $P(IBXDATA(IBI),U,6)=$S($D(IBFLD(24,IBI_"X")):"CJ",1:"HC")
     91 . S $P(IBXDATA(IBI),U,7,13)=$P(IBFLD(24,IBI),U,6,12)
     92 . S $P(IBXDATA(IBI),U,14)=+$$ISLAB(IBXDATA(IBI))
     93 . ;
     94 . I $D(IBFLD(24,IBI,"RX")) D  ;Rx
     95 .. S IBRX1=1
     96 .. I $P($G(IBFLD(24,IBI,"AUX")),U,8)'="" S $P(IBFLD(24,IBI,"AUX"),U,8)="",$P(IBFLD(24,IBI,"AUX"),U,9)=""  ;No free text allowed for rx's
     97 .. I $D(IBRX1(+IBFLD(24,IBI,"RX"))) D  Q  ;Soft link exists
     98 ...D ZERO^IBRXUTL(+$P(IBRX1(+IBFLD(24,IBI,"RX")),U,2))
     99 ... S IBXDATA(IBI,"RX")=IBRX1(+IBFLD(24,IBI,"RX")),$P(IBXDATA(IBI,"RX"),U,2)=$E($G(^TMP($J,"IBDRUG",+$P(IBRX1(+IBFLD(24,IBI,"RX")),U,2),.01)),1,30)
     100 ... K IBRX1(+IBFLD(24,IBI,"RX"))
     101 ... ; No soft link - must find the first Rx with the same charge
     102 .. S IBRX="" F  S IBRX=$O(IBRX1(IBRX)) Q:'IBRX  I +$P(IBRX1(IBRX),U,8)=+$P(IBXDATA(IBI),U,8) D  Q
     103 ... D ZERO^IBRXUTL(+$P(IBRX1(IBRX),U,2))
     104 ... S IBXDATA(IBI,"RX")=IBRX1(IBRX),$P(IBXDATA(IBI,"RX"),U,2)=$E($G(^TMP($J,"IBDRUG",+$P(IBRX1(IBRX),U,2),.01)),1,30) K IBRX1(IBRX) Q
     105 ... Q
     106 .. Q
     107 . ;
     108 . I $G(IBFLD(24,IBI,"AUX"))'="" D
     109 .. I $G(IBPRINT),$P(IBFLD(24,IBI,"AUX"),U,8)'="" S IBXDATA(IBI,"TEXT")=$P(IBFLD(24,IBI,"AUX"),U,8),$P(IBFLD(24,IBI,"AUX"),U,8)=""
     110 .. S IBXDATA(IBI,"AUX")=IBFLD(24,IBI,"AUX")
     111 .. Q
     112 . ;
     113 . I $G(IBPRINT) D
     114 .. I '$P(IBXDATA(IBI),U,8),'$G(IBXDATA(IBI,"RX")) D  Q
     115 ... I $G(IBNOSHOW) Q    ; don't show errors/warnings
     116 ... S IBXDATA(IBI,"TEXT")="Warning:** REV CODE UNITS < #PROCEDURES, THEY MUST BE ="
     117 ... I $D(IBXDATA(IBI,"AUX")) S $P(IBXDATA(IBI,"AUX"),U,9)=""
     118 ... Q
     119 .. ;
     120 .. I $G(IBFLD(24,IBI_"A"))'="" D  Q
     121 ... S IBXDATA(IBI,"A")=IBFLD(24,IBI_"A")
     122 ... I $G(IBNOSHOW) Q    ; don't show errors/warnings
     123 ... S IBXDATA(IBI,"TEXT")="Warning:** REV CODE UNITS > #PROCEDURES, THEY MUST BE=: "_IBFLD(24,IBI_"A")
     124 ... I $D(IBXDATA(IBI,"AUX")) S $P(IBXDATA(IBI,"AUX"),U,9)=""
     125 ... Q
     126 .. ;
     127 .. S IBRX=$G(IBXDATA(IBI,"RX"))
     128 .. I IBRX'="" D  ;Format Rx detail
     129 ... N Z
     130 ... S Z=$P(IBRX,U)
     131 ... S Z=$S(Z'="":"Rx#"_Z_" ",1:"RX: ")
     132 ... S IBXDATA(IBI,"TEXT")=Z_$S($P(IBRX,U,3)'="":"NDC: "_$P(IBRX,U,3),1:"NOC: "_$P(IBRX,U,2))_" Qty: "_$P(IBRX,U,6)_" Days: "_$P(IBRX,U,7)
     133 ... S $P(IBXDATA(IBI,"AUX"),U,9)="N4"   ; service line comment qualifier for RX's
     134 ... Q
     135 .. Q
     136 . ;
     137 . I '$G(IBPRINT) D COBLINE^IBCEU6(IBIFN,IBI,.IBXDATA,,.IBXTRA)
     138 . Q
     139 ;
     140 I $G(IBPRINT) D
     141 . S IBRX=0 F  S IBRX=$O(IBRX1(IBRX)) Q:'IBRX  D
     142 .. S IBI=+$O(IBXDATA(""),-1)+1
     143 .. S IBXDATA(IBI)=$$DATE($P(IBRX1(IBRX),U,5))
     144 .. S IBXDATA(IBI,"TEXT")="**** ERROR - NO PROC LINK TO REV CODE FOR DRUG: RX#: "_$P(IBRX1(IBRX),U)_"  NDC #: "_$P(IBRX1(IBRX),U,3)
     145 .. I $D(IBXDATA(IBI,"AUX")) S $P(IBXDATA(IBI,"AUX"),U,9)=""
     146 .. S IBXDATA(IBI,"ARX")=""
     147 .. D ZERO^IBRXUTL(+$P(IBRX1(IBRX),U,2))
     148 .. S IBXDATA(IBI,"RX")=IBRX1(IBRX),$P(IBXDATA(IBI,"RX"),U,2)=$E($G(^TMP($J,"IBDRUG",+$P(IBRX1(IBRX),U,2),.01)),1,30) K IBRX1(IBRX)
     149 .. Q
     150 . Q
     151 ;
     152 I '$G(IBPRINT),$D(IBXTRA) D COMBO^IBCEU2(.IBXDATA,.IBXTRA,0) ;Handle bundled/unbundled lines
     153 K ^TMP($J,"IBDRUG")
     154 Q
     155 ;
     156ISLAB(LDATA) ; Returns 0/1 if line item data indicates the item is a lab (1)
     157 ; 'LAB' is defined here as type of service = 5
     158 Q $E($P(LDATA,U,4))="5"
     159 ;
     160FMT(DATA,DLEN,FLEN) ; Returns a string in DATA with a max length of DLEN
     161 ;  and a field length of FLEN
     162 Q $E($E(DATA,1,DLEN)_$J("",FLEN),1,FLEN)
     163 ;
     164DATE(X,DEL) ;  Returns FM date in X as MMxDDxYYYY  where x=DEL
     165 S DEL=$G(DEL)
     166 S X=$$DATE^IBCF2(X,1,1)
     167 I X'="" S X=$E(X,1,2)_DEL_$E(X,3,4)_DEL_$E(X,5,8)
     168 Q X
     169 ;
     170BATCH() ; Sets up record for and stores/returns the next batch number
     171 N NUM,FAC,DO,DD,DLAYGO,DIC,X,Y
     172 ;Keep latest batch number for view/print edi bill extract data option
     173 I $D(IBVNUM) S NUM=IBVNUM G BATCHQ
     174 ;Check for batch resubmit - if yes, use same number as original batch
     175 I $P($G(^TMP("IBRESUBMIT",$J)),U,3)=1 S NUM=$P(^($J),U) G BATCHQ
     176 L +^IBA(364.1,0):5 I '$T Q 0
     177 S FAC=+$P($$SITE^VASITE(),U,3),NUM=$O(^IBA(364.1,"B",""),-1)
     178 I $D(^IBA(364.1,+NUM,0)),$P(^(0),U,2)="" F  D  Q:'NUM!($P($G(^IBA(364.1,+NUM,0)),U,2)'="")
     179 . I $D(^IBA(364.1,NUM,0)) S DA=NUM,DIK="^IBA(364.1," D ^DIK
     180 . S NUM=$O(^IBA(364.1,"B",""),-1)
     181 F  S NUM=$S($P(NUM,FAC,2)'="":NUM+1,1:FAC_"0000001") Q:'$D(^IBA(364.1,"B",NUM))
     182 K DO,DD S DIC="^IBA(364.1,",DLAYGO=364.1,DIC(0)="L",X=NUM D FILE^DICN K DD,DO I Y'>0 S NUM=0
     183 L -^IBA(364.1,0)
     184BATCHQ Q NUM
     185 ;

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF21.m

    r613 r623  
    1 IBCEF21 ;ALB/TMP - FORMATTER SPECIFIC BILL FUNCTIONS CONTINUED ;06-FEB-96
    2         ;;2.0;INTEGRATED BILLING;**51,296,371,389**;21-MAR-94;Build 6
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5 COID(IBIFN)     ; Claim office ID
    6         N IBCOID,IBCOID1,IBIN
    7         S IBIN=$$CURR^IBCEF2(IBIFN),IBCOID1="",IBCOID=$P($$ADDRESS^IBCNSC0(IBIN,.11,5),U,11)
    8         ;
    9         I IBIN D
    10         . I $D(^IBA(364.2,"C",IBIFN)) S IBCOID1=$P($$ADDRESS^IBCNSC0(IBIN,.18,5),U,11) Q  ;Rx
    11         . I $P($G(^DGCR(399,IBIFN,0)),U,5)<3 S IBCOID1=$P($$ADDRESS^IBCNSC0(IBIN,.12,5),U,11) Q  ;Inpt
    12         . I $P($G(^DGCR(399,IBIFN,0)),U,5)'<3 S IBCOID1=$P($$ADDRESS^IBCNSC0(IBIN,.16,5),U,11) Q  ;Outpt
    13         ;
    14         Q $S(IBCOID1'="":IBCOID1,1:IBCOID)
    15         ;
    16 ESGHPST(IBIFN,COB)      ; return insureds employment status if the bill policy defined by COB is an Employer Sponsored Group Health Plan
    17         ; ESGHP FLAG (2.312,2.1) ^ the employment status (2.312,2.11)
    18         ;
    19         N PPOL,DFN,X,Y S Y=""
    20         S PPOL=$$PPOL^IBCEF2($G(IBIFN),$G(COB)),DFN=$P($G(^DGCR(399,+$G(IBIFN),0)),U,2)
    21         I +PPOL,+DFN S X=$G(^DPT(DFN,.312,+PPOL,2)) S Y=+$P(X,U,10)_U_$P(X,U,11)
    22         Q Y
    23         ;
    24 ESGHPNL(IBIFN,COB)      ; return employer name and location if the bill policy defined by COB is an Employer Sponsored Group Health Plan
    25         ; ESGHP FLAG (2.312,2.1) ^ employer name (2.312,2.015) ^ employer city (2.312,2.05)
    26         ;                        ^ employer state abbr (2.312,2.06) ^ employer state ifn  (2.312,2.06)
    27         ;
    28         N PPOL,DFN,X,Y S Y=""
    29         S PPOL=$$PPOL^IBCEF2($G(IBIFN),$G(COB)),DFN=$P($G(^DGCR(399,+$G(IBIFN),0)),U,2)
    30         I +PPOL,+DFN S X=$G(^DPT(DFN,.312,+PPOL,2)) S Y=+$P(X,U,10)_U_$P(X,U,9)_U_$P(X,U,5)_U_$P($G(^DIC(5,+$P(X,U,6),0)),U,2)_U_$P(X,U,6)
    31         Q Y
    32         ;
    33 REMARKS(IBIFN)  ; Compile array of bill remarks
    34         ;IBIFN = bill ien
    35         N Z,Z0,Z1,IBARRAY,IBSM
    36         S Z=0
    37         ;S:$P($G(^DGCR(399,IBIFN,"U1")),U,2) Z=Z+1,Z0=$P(^("U1"),U,2),IBXDATA(Z)="OFFSET AMOUNT: "_"$"_+$P(Z0,".")_"."_$E($P(Z0,".",2)_"00",1,2)
    38         S:$P($G(^DGCR(399,IBIFN,"U1")),U,8)'="" Z=Z+1,IBXDATA(Z)=$P(^("U1"),U,8) ;Bill comment on bill
    39         S Z0=$G(^DGCR(399,IBIFN,0)),Z1=$G(^DGCR(399.3,+$P(Z0,U,7),0))
    40         D SET^IBCSC5B(IBIFN,.IBARRAY)
    41         I $P($G(IBARRAY),U,2) D  ;Prosthetics
    42         . S Z0=0 F  S Z0=$O(IBARRAY(Z0)) Q:Z0=""  S Z1=0 F  S Z1=$O(IBARRAY(Z0,Z1)) Q:'Z1  S Z=Z+1,IBXDATA(Z)="Prosthetic: "_$E($$PINB^IBCSC5B(+IBARRAY(Z0,Z1)),1,39)_" "_$E(Z0,4,5)_"/"_$E(Z0,6,7)_"/"_$E(Z0,1,2)
    43         Q
    44         ;
    45 CREM(IBIFN)     ; Compile array of bill remarks common to every bill
    46         ;IBIFN = bill ien
    47         N Z
    48         S Z=0
    49         S:$P($G(^IBE(350.9,1,1)),U,4)'="" Z=Z+1,IBXDATA(Z)=$P(^(1),U,4) ;Site specific 'every bill' comment
    50         Q
    51         ;
    52 ADMDT(IBIFN,NOOUTCK)    ; Calculate admission/start of care date/time
    53         ; IBIFN = bill ien
    54         ; NOOUTCK = flag that will:
    55         ;          (1) no check for inpt episode overlap for outpt
    56         ;          (0 or null) performs check for inpt episode overlap for outpt
    57         ;                                     
    58         ; Returns IBXDATA = fileman date format
    59         N Z,Z0,Z1
    60         S Z=$G(^DGCR(399,IBIFN,0)),Z1=$P($G(^("U")),U,20),Z0=$$INPAT^IBCEF(IBIFN,1)
    61         S IBXDATA=$S(Z0&$P(Z,U,8):$P($G(^DGPT(+$P(Z,U,8),0)),U,2),1:"")
    62         S:'IBXDATA IBXDATA=$P(Z,U,3)_$S(Z0&(Z1<25):"."_$E("0",$L(Z1))_Z1,1:"")
    63         ; Check to see if outpt episode (date in event date) overlaps inpt
    64         ;  episode - use admit date if it does
    65         I 'Z0,IBXDATA,'$G(NOOUTCK) D
    66         . N VAINDT,VAIN,DFN
    67         . S VAINDT=IBXDATA,DFN=$P($G(^DGCR(399,IBIFN,0)),U)
    68         . D INP^VADPT S IBXDATA=+VAIN(7) S:'IBXDATA IBXDATA=""
    69         I 'IBXDATA,'Z0 S IBXDATA=$$SERVDT^IBCEF(IBIFN,,2)
    70         Q
    71         ;
    72 DISDT(IBIFN)    ; Calculate discharge date
    73         ; IBIFN = bill ien
    74         N Z,Z0
    75         S Z=$$INPAT^IBCEF(IBIFN,1),Z0=$G(^DGCR(399,IBIFN,0))
    76         I Z S IBXDATA=+$G(^DGPT(+$P(Z0,U,8),70)) S:'IBXDATA IBXDATA=$P(Z0,U,16)
    77         I 'Z N VAINDT,VAIN,DFN S DFN=$P($G(^DGCR(399,IBIFN,0)),U,2) D INP^VADPT I VAIN(1) S IBXDATA=+$G(^DGPM(+$P($G(^DGPM(+VAIN(1),0)),U,17),0))
    78         Q
    79         ;
    80 INSSECID(IBIFN,TYPE,SEQ)        ; Extract subscriber and patient prim/sec ID's
    81         ; IBIFN required
    82         ; TYPE is either "PAT" or "SUB" to indicate we need to extract either
    83         ;          patient or subscriber ID information.  Default="SUB".
    84         ; SEQ is the insurance sequence# (1,2,3).  Default is current ins seq#.
    85         ;
    86         ; Output:
    87         ; Function returns an 8-piece string as follows.
    88         ;   [1] primary qualifier
    89         ;   [2] primary ID
    90         ;   [3] secondary qual(1)
    91         ;   [4] secondary ID(1)
    92         ;   [5] secondary qual(2)
    93         ;   [6] secondary ID(2)
    94         ;   [7] secondary qual(3)
    95         ;   [8] secondary ID(3)
    96         ;
    97         NEW DATA,DFN,POL,IB0,IB5,REL
    98         S DATA=""
    99         S IBIFN=+$G(IBIFN) I 'IBIFN G INSSX
    100         I $G(TYPE)="" S TYPE="SUB"               ; default type of ID's to get
    101         I '$F(".PAT.SUB.","."_TYPE_".") G INSSX
    102         I '$G(SEQ) S SEQ=$$COBN^IBCEF(IBIFN)     ; default current ins seq#
    103         I '$F(".1.2.3.","."_SEQ_".") G INSSX
    104         S DFN=+$P($G(^DGCR(399,IBIFN,0)),U,2) I 'DFN G INSSX
    105         S POL=+$P($G(^DGCR(399,IBIFN,"M")),U,SEQ+11) I 'POL G INSSX
    106         S IB0=$G(^DPT(DFN,.312,POL,0)) I IB0="" G INSSX
    107         S IB5=$G(^DPT(DFN,.312,POL,5))
    108         S REL=+$P(IB0,U,16)                      ; pat rel to insured
    109         S $P(DATA,U,1)="MI"
    110         S $P(DATA,U,2)=$P(IB0,U,2)               ; subscriber primary ID
    111         S $P(DATA,U,3,8)=$P(IB5,U,2,7)           ; subscriber secondary data
    112         I TYPE="PAT",REL'=1 D
    113         . S $P(DATA,U,2)=$P(IB5,U,1)             ; patient primary ID
    114         . S $P(DATA,U,3,8)=$P(IB5,U,8,13)        ; patient secondary data
    115         . Q
    116         ;
    117         S DATA=$$SCRUB(DATA)     ; scrub the data
    118 INSSX   ;
    119         Q DATA
    120         ;
    121 SCRUB(DATA)     ; Scrub the 8-piece string gathered above
    122         NEW PCE
    123         ;
    124         ; make sure you can't have an ID without a qualifier or a qualifier
    125         ; without an ID.  Check all 4 pairs.
    126         F PCE=1,3,5,7 D
    127         . I $P(DATA,U,PCE)'="",$P(DATA,U,PCE+1)'="" Q
    128         . S ($P(DATA,U,PCE),$P(DATA,U,PCE+1))=""
    129         . Q
    130         ;
    131         ; fill in secondary gaps.  If Set1 and Set2 are blank, but Set3 exists
    132         ; then move Set3 to Set1 and delete Set3.
    133         I $P(DATA,U,3)="",$P(DATA,U,5)="",$P(DATA,U,7)'="" D
    134         . S $P(DATA,U,3)=$P(DATA,U,7),$P(DATA,U,4)=$P(DATA,U,8)
    135         . S ($P(DATA,U,7),$P(DATA,U,8))=""
    136         . Q
    137         ;
    138         ; fill in secondary gaps more generically.
    139         ; If Set(n) is blank, but Set(n+1) exists, then move it up.
    140         F PCE=3,5 D
    141         . I $P(DATA,U,PCE)="",$P(DATA,U,PCE+2)'="" D
    142         .. S $P(DATA,U,PCE)=$P(DATA,U,PCE+2)
    143         .. S $P(DATA,U,PCE+1)=$P(DATA,U,PCE+3)
    144         .. S ($P(DATA,U,PCE+2),$P(DATA,U,PCE+3))=""
    145         .. Q
    146         . Q
    147         ;
    148         Q DATA
    149         ;
     1IBCEF21 ;ALB/TMP - FORMATTER SPECIFIC BILL FUNCTIONS CONTINUED ;06-FEB-96
     2 ;;2.0;INTEGRATED BILLING;**51,296**;21-MAR-94
     3 ;
     4COID(IBIFN) ; Claim office ID
     5 N IBCOID,IBCOID1,IBIN
     6 S IBIN=$$CURR^IBCEF2(IBIFN),IBCOID1="",IBCOID=$P($$ADDRESS^IBCNSC0(IBIN,.11,5),U,11)
     7 ;
     8 I IBIN D
     9 . I $D(^IBA(364.2,"C",IBIFN)) S IBCOID1=$P($$ADDRESS^IBCNSC0(IBIN,.18,5),U,11) Q  ;Rx
     10 . I $P($G(^DGCR(399,IBIFN,0)),U,5)<3 S IBCOID1=$P($$ADDRESS^IBCNSC0(IBIN,.12,5),U,11) Q  ;Inpt
     11 . I $P($G(^DGCR(399,IBIFN,0)),U,5)'<3 S IBCOID1=$P($$ADDRESS^IBCNSC0(IBIN,.16,5),U,11) Q  ;Outpt
     12 ;
     13 Q $S(IBCOID1'="":IBCOID1,1:IBCOID)
     14 ;
     15ESGHPST(IBIFN,COB) ; return insureds employment status if the bill policy defined by COB is an Employer Sponsored Group Health Plan
     16 ; ESGHP FLAG (2.312,2.1) ^ the employment status (2.312,2.11)
     17 ;
     18 N PPOL,DFN,X,Y S Y=""
     19 S PPOL=$$PPOL^IBCEF2($G(IBIFN),$G(COB)),DFN=$P($G(^DGCR(399,+$G(IBIFN),0)),U,2)
     20 I +PPOL,+DFN S X=$G(^DPT(DFN,.312,+PPOL,2)) S Y=+$P(X,U,10)_U_$P(X,U,11)
     21 Q Y
     22 ;
     23ESGHPNL(IBIFN,COB) ; return employer name and location if the bill policy defined by COB is an Employer Sponsored Group Health Plan
     24 ; ESGHP FLAG (2.312,2.1) ^ employer name (2.312,2.015) ^ employer city (2.312,2.05)
     25 ;                        ^ employer state abbr (2.312,2.06) ^ employer state ifn  (2.312,2.06)
     26 ;
     27 N PPOL,DFN,X,Y S Y=""
     28 S PPOL=$$PPOL^IBCEF2($G(IBIFN),$G(COB)),DFN=$P($G(^DGCR(399,+$G(IBIFN),0)),U,2)
     29 I +PPOL,+DFN S X=$G(^DPT(DFN,.312,+PPOL,2)) S Y=+$P(X,U,10)_U_$P(X,U,9)_U_$P(X,U,5)_U_$P($G(^DIC(5,+$P(X,U,6),0)),U,2)_U_$P(X,U,6)
     30 Q Y
     31 ;
     32REMARKS(IBIFN) ; Compile array of bill remarks
     33 ;IBIFN = bill ien
     34 N Z,Z0,Z1,IBARRAY,IBSM
     35 S Z=0
     36 ;S:$P($G(^DGCR(399,IBIFN,"U1")),U,2) Z=Z+1,Z0=$P(^("U1"),U,2),IBXDATA(Z)="OFFSET AMOUNT: "_"$"_+$P(Z0,".")_"."_$E($P(Z0,".",2)_"00",1,2)
     37 S:$P($G(^DGCR(399,IBIFN,"U1")),U,8)'="" Z=Z+1,IBXDATA(Z)=$P(^("U1"),U,8) ;Bill comment on bill
     38 S Z0=$G(^DGCR(399,IBIFN,0)),Z1=$G(^DGCR(399.3,+$P(Z0,U,7),0))
     39 D SET^IBCSC5B(IBIFN,.IBARRAY)
     40 I $P($G(IBARRAY),U,2) D  ;Prosthetics
     41 . S Z0=0 F  S Z0=$O(IBARRAY(Z0)) Q:Z0=""  S Z1=0 F  S Z1=$O(IBARRAY(Z0,Z1)) Q:'Z1  S Z=Z+1,IBXDATA(Z)="Prosthetic: "_$E($P($$PIN^IBCSC5B(Z1),U,2),1,39)_" "_$E(Z0,4,5)_"/"_$E(Z0,6,7)_"/"_$E(Z0,1,2)
     42 Q
     43 ;
     44CREM(IBIFN) ; Compile array of bill remarks common to every bill
     45 ;IBIFN = bill ien
     46 N Z
     47 S Z=0
     48 S:$P($G(^IBE(350.9,1,1)),U,4)'="" Z=Z+1,IBXDATA(Z)=$P(^(1),U,4) ;Site specific 'every bill' comment
     49 Q
     50 ;
     51ADMDT(IBIFN,NOOUTCK) ; Calculate admission/start of care date/time
     52 ; IBIFN = bill ien
     53 ; NOOUTCK = flag that will:
     54 ;          (1) no check for inpt episode overlap for outpt
     55 ;          (0 or null) performs check for inpt episode overlap for outpt
     56 ;                                     
     57 ; Returns IBXDATA = fileman date format
     58 N Z,Z0,Z1
     59 S Z=$G(^DGCR(399,IBIFN,0)),Z1=$P($G(^("U")),U,20),Z0=$$INPAT^IBCEF(IBIFN,1)
     60 S IBXDATA=$S(Z0&$P(Z,U,8):$P($G(^DGPT(+$P(Z,U,8),0)),U,2),1:"")
     61 S:'IBXDATA IBXDATA=$P(Z,U,3)_$S(Z0&(Z1<25):"."_$E("0",$L(Z1))_Z1,1:"")
     62 ; Check to see if outpt episode (date in event date) overlaps inpt
     63 ;  episode - use admit date if it does
     64 I 'Z0,IBXDATA,'$G(NOOUTCK) D
     65 . N VAINDT,VAIN,DFN
     66 . S VAINDT=IBXDATA,DFN=$P($G(^DGCR(399,IBIFN,0)),U)
     67 . D INP^VADPT S IBXDATA=+VAIN(7) S:'IBXDATA IBXDATA=""
     68 I 'IBXDATA,'Z0 S IBXDATA=$$SERVDT^IBCEF(IBIFN,,2)
     69 Q
     70 ;
     71DISDT(IBIFN) ; Calculate discharge date
     72 ; IBIFN = bill ien
     73 N Z,Z0
     74 S Z=$$INPAT^IBCEF(IBIFN,1),Z0=$G(^DGCR(399,IBIFN,0))
     75 I Z S IBXDATA=+$G(^DGPT(+$P(Z0,U,8),70)) S:'IBXDATA IBXDATA=$P(Z0,U,16)
     76 I 'Z N VAINDT,VAIN,DFN S DFN=$P($G(^DGCR(399,IBIFN,0)),U,2) D INP^VADPT I VAIN(1) S IBXDATA=+$G(^DGPM(+$P($G(^DGPM(+VAIN(1),0)),U,17),0))
     77 Q
     78 ;

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF22.m

    r613 r623  
    1 IBCEF22 ;ALB/TMP - FORMATTER SPECIFIC BILL FUNCTIONS ;06-FEB-96
    2         ;;2.0;INTEGRATED BILLING;**51,137,135,155,309,349,389**;21-MAR-94;Build 6
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5         ;  OVERFLOW FROM ROUTINE IBCEF2
    6 HOS(IBIFN)      ; Extract rev codes for episode billed on a UB-04 into IBXDATA
    7         ; IBIFN = bill ien
    8         ; Format: IBXDATA(n) =
    9         ;  rev cd ptr ^ CPT CODE ptr ^ unit chg ^ units ^ tot charge
    10         ;    ^ tot uncov^ FL49 value ^ ien of rev code multiple entry(s)
    11         ;      (separated by ";")
    12         ;    ^ modifiers specific to rev code/proc (separated by ",")
    13         ;    ^ rev code date, if it can be determined by a corresponding proc
    14         ;
    15         ;   Also Returns IBXDATA(IBI,"COB",COB,m) with COB data for each line
    16         ;      item found in an accepted EOB for the bill and = the reference
    17         ;      line in the first '^' piece followed by the '0' node of file
    18         ;      361.115 (LINE LEVEL ADJUSTMENTS)
    19         ;       COB = COB seq # of adjustment's ins co, m = seq #
    20         ;         -- AND --
    21         ;    IBXDATA(IBI,"COB",COB,m,z,p)=
    22         ;           the '0' node for each subordinate entry of file
    23         ;           361.11511 (REASONS) (Only first 3 pieces for 837)
    24         ;       z = group code, sometimes preceeded by a space   p = seq #
    25         ;
    26         N IBDA,IBCOMB,IBINPAT,IBLN,IBX,IBY,IBZ,IBS,IBSS,IBXTRA,IBX1,IBXS,IBP,IBPO,IBP1,IBDEF,Z,Z0,Z1,ZX,QQ,IBMOD
    27         S IBINPAT=$$INPAT^IBCEF(IBIFN,1)
    28         I 'IBINPAT D F^IBCEF("N-STATEMENT COVERS FROM DATE","IBZ",,IBIFN)
    29         S IBDEF=$G(IBZ)
    30         ; loop through all proc codes - sort by procedure, modifiers and print order
    31         S IBDA=0 F  S IBDA=$O(^DGCR(399,IBIFN,"CP",IBDA)) Q:'IBDA  S IBZ=$G(^(IBDA,0)) I IBZ D
    32         . S IBP(+$P(IBZ,U)_U_$$GETMOD^IBEFUNC(IBIFN,IBDA,1),$S($P(IBZ,U,4):$P(IBZ,U,4),1:999),IBDA)=$P(IBZ,U,2)
    33         ; loop through all rev codes - sort by rev code
    34         S IBDA=0 F  S IBDA=$O(^DGCR(399,IBIFN,"RC",IBDA)) Q:'IBDA  S IBZ=$G(^(IBDA,0)) I IBZ S IBMOD="" D
    35         . S IBX=$G(^DGCR(399.2,+IBZ,0)),IBX1="",IBPO=0
    36         . ; Auto-added procedure charge
    37         . I $P(IBZ,U,10)=4,$P(IBZ,U,11) D  ; Soft link to proc
    38         .. S Z=$G(^DGCR(399,IBIFN,"CP",$P(IBZ,U,11),0))
    39         .. Q:Z=""
    40         .. S ZX=+Z_U_$$GETMOD^IBEFUNC(IBIFN,$P(IBZ,U,11),1)
    41         .. Q:'$O(IBP(ZX,0))&'$O(IBP1(ZX,0))
    42         .. I $P(IBZ,U,6) Q:$S($P(Z,U)'["ICPT":1,1:+$P(Z,U)'=$P(IBZ,U,6))
    43         .. S Z0=$S($D(IBP(ZX)):$O(IBP(ZX,0)),1:$O(IBP1(ZX,0)))
    44         .. S:'Z0 Z0=999
    45         .. Q:'$D(IBP(ZX,+Z0,$P(IBZ,U,11)))&'$D(IBP1(ZX,+Z0,$P(IBZ,U,11)))
    46         .. I '$D(IBP1(ZX,+Z0,$P(IBZ,U,11))) S IBP1(ZX,+Z0,$P(IBZ,U,11))=IBP(ZX,+Z0,$P(IBZ,U,11)) K IBP(ZX,+Z0,$P(IBZ,U,11))
    47         .. S IBX1=$P(Z,U,2),IBPO=+Z0,IBMOD=$P(ZX,U,2)
    48         . ; Manually added charge with a procedure
    49         . I $P(IBZ,U,6),$S($P(IBZ,U,10)=4:'$P(IBZ,U,11),1:1),+$O(IBP($P(IBZ,U,6)))=$P(IBZ,U,6) D
    50         .. ; No direct link, but a proc exists on rev code and in procedure mult without and then with modifiers
    51         .. S ZX=$O(IBP($P(IBZ,U,6)))
    52         .. F QQ=1,2 Q:IBPO  S Z="" F  S Z=$O(IBP(ZX,Z),-1) Q:'Z!(IBPO)  S Z0=0 F  S Z0=$O(IBP(ZX,Z,Z0)) Q:'Z0  S Z1=$G(^DGCR(399,IBIFN,"CP",Z0,0)) D  Q:IBPO
    53         ... ; Ignore if not a CPT or a modifier exists and this is first pass
    54         ... S IBMOD=$$GETMOD^IBEFUNC(IBIFN,Z0,1)
    55         ... Q:$S($P(Z1,U)'["ICPT":1,QQ=1:IBMOD'="",1:0)
    56         ... S IBPO=+$P(Z1,U,4),IBX1=$P(Z1,U,2)
    57         ... K IBP(+Z1_U_IBMOD,Z,Z0)
    58         . ;
    59         . I IBX'="" D  ; revenue code is valid
    60         .. F Z=900:1 S Z0=$S(IBPO:IBPO,$D(IBX(" "_$P(IBX,U),Z)):0,1:Z) I Z0 S IBPO=Z0 Q
    61         .. S IBX(" "_$P(IBX,U),IBPO,IBDA)=IBX,IBX(" "_$P(IBX,U),IBPO,IBDA,"DT")=$S(IBX1:IBX1,1:IBDEF),IBX(" "_$P(IBX,U),IBPO,IBDA,"MOD")=IBMOD
    62         ;
    63         S IBS="" F  S IBS=$O(IBX(IBS)) Q:IBS=""  S IBPO=0 F  S IBPO=$O(IBX(IBS,IBPO)) Q:'IBPO  D
    64         . S IBDA=0 F  S IBDA=$O(IBX(IBS,IBPO,IBDA)) Q:'IBDA  S IBX=$G(IBX(IBS,IBPO,IBDA)),IBZ=$G(^DGCR(399,IBIFN,"RC",IBDA,0)) I IBX'="" D
    65         .. ;S IBXS=$P(IBZ,U,2)_U_$P(IBZ,U,6)_U_$G(IBX(IBS,IBPO,IBDA,"MOD"))
    66         .. S IBXS=U_$P(IBZ,U,6)_U_$G(IBX(IBS,IBPO,IBDA,"MOD")) ;combine same proc and modifiers regardless of rate
    67         .. S:IBPO'<900&'$$ACCRV($P(IBS," ",2))&$S(IBINPAT:$P(IBZ,U,6),1:1) IBCOMB(IBS,IBXS,IBPO)=IBDA
    68         .. S:'$D(IBX1(IBS,IBPO,IBXS,1)) IBX1(IBS,IBPO,IBXS,1)=IBX,IBX1(IBS,IBPO,IBXS,2)=IBZ
    69         .. S $P(IBX1(IBS,IBPO,IBXS),U)=$P($G(IBX1(IBS,IBPO,IBXS)),U)+$P(IBZ,U,3)
    70         .. S $P(IBX1(IBS,IBPO,IBXS),U,2)=$P($G(IBX1(IBS,IBPO,IBXS)),U,2)+$P(IBZ,U,4)
    71         .. S IBX1(IBS,IBPO,IBXS,"DT")=$G(IBX(IBS,IBPO,IBDA,"DT")),IBX1(IBS,IBPO,IBXS,"IEN")=$G(IBX1(IBS,IBPO,IBXS,"IEN"))_$S($G(IBX1(IBS,IBPO,IBXS,"IEN")):";",1:"")_IBDA
    72         ;
    73         S IBS="" F  S IBS=$O(IBX1(IBS)) Q:IBS=""  S IBPO=899 F  S IBPO=$O(IBX1(IBS,IBPO)) Q:'IBPO  D  ; Check to combine like rev codes without print order
    74         . N Q,Q0,Q1,Z,Z0,Z1,Z2,IBZ1,IBZ2
    75         . S Z=""
    76         . N IBACC
    77         . F  S Z=$O(IBX1(IBS,IBPO,Z)) Q:Z=""  S Q=IBPO F  S Q=$O(IBCOMB(IBS,Z,Q)) Q:'Q  I Q'=IBPO S IBZ1=$G(IBX1(IBS,IBPO,Z,1)),IBZ2=$G(IBX1(IBS,IBPO,Z,2)) D
    78         .. Q:$G(IBX1(IBS,IBPO,Z,1))'=$G(IBX1(IBS,Q,Z,1))
    79         .. S Q1=1,IBACC=$$ACCRV(+$P(IBS," ",2))
    80         .. F Q0=1,5:1:7,10:1:13,15 D  Q:'Q1
    81         ... I IBACC Q:Q0=5!(Q0>6)
    82         ... I (Q0=11!(Q0=15))&($P($G(IBX1(IBS,Q,Z,2)),U,10)=3) Q
    83         ... I Q0=5,'IBINPAT Q
    84         ... I $P($G(IBX1(IBS,IBPO,Z,2)),U,Q0)'=$P($G(IBX1(IBS,Q,Z,2)),U,Q0) S Q1=0
    85         .. Q:'Q1
    86         .. S $P(IBX1(IBS,IBPO,Z,2),U,3)=$P(IBX1(IBS,IBPO,Z,2),U,3)+$P(IBX1(IBS,Q,Z,2),U,3)
    87         .. S $P(IBX1(IBS,IBPO,Z,2),U,4)=$P(IBX1(IBS,IBPO,Z,2),U,4)+$P(IBX1(IBS,Q,Z,2),U,4)
    88         .. S $P(IBX1(IBS,IBPO,Z,2),U,9)=$P(IBX1(IBS,IBPO,Z,2),U,9)+$P(IBX1(IBS,Q,Z,2),U,9)
    89         .. S IBX1(IBS,IBPO,Z)=$P(IBX1(IBS,IBPO,Z,2),U,3)_U_$P(IBX1(IBS,IBPO,Z,2),U,4)
    90         .. S IBX1(IBS,IBPO,Z,"IEN")=IBX1(IBS,IBPO,Z,"IEN")_";"_IBX1(IBS,Q,Z,"IEN")
    91         .. K IBX1(IBS,Q,Z)
    92         ;
    93         S IBS="",IBLN=0
    94         F  S IBS=$O(IBX1(IBS)) Q:IBS=""  S IBPO=0 F  S IBPO=$O(IBX1(IBS,IBPO)) Q:'IBPO  S IBSS="" F  S IBSS=$O(IBX1(IBS,IBPO,IBSS)) Q:IBSS=""  D
    95         . S IBX=$G(IBX1(IBS,IBPO,IBSS,1)),IBZ=$G(IBX1(IBS,IBPO,IBSS,2))
    96         . S IBLN=$G(IBLN)+1,IBXDATA(IBLN)=$P(IBX,U)_U_$P(IBZ,U,6)_U_$P(IBZ,U,2)_U_+IBX1(IBS,IBPO,IBSS)_U_+$P(IBX1(IBS,IBPO,IBSS),U,2),$P(IBXDATA(IBLN),U,10)=$G(IBX1(IBS,IBPO,IBSS,"DT"))
    97         . S $P(IBXDATA(IBLN),U,6)=$P(IBZ,U,9),$P(IBXDATA(IBLN),U,7)=$P(IBZ,U,13),$P(IBXDATA(IBLN),U,8)=$G(IBX1(IBS,IBPO,IBSS,"IEN")),$P(IBXDATA(IBLN),U,9)=$P($P(IBSS,U,3),",",1,2)
    98         . ; Extract line lev COB data for sec or tert bill
    99         . I $$COBN^IBCEF(IBIFN)>1 D COBLINE^IBCEU6(IBIFN,IBLN,.IBXDATA,,.IBXTRA) I $D(IBXTRA) D COMBO^IBCEU2(.IBXDATA,.IBXTRA,1) ;Handle bundled/unbundled
    100         I $D(^IBA(362.4,"AIFN"_IBIFN))!$D(^IBA(362.5,"AIFN"_IBIFN)) D
    101         . N IBARRAY,IBX,IBZ,IBRX,IBLCNT
    102         . S IBLCNT=0
    103         . ; Print prescriptions, prosthetics on front of UB-04
    104         . D SET^IBCSC5A(IBIFN,.IBARRAY)
    105         . I $P(IBARRAY,U,2) D
    106         .. S IBX=+$P(IBARRAY,U,2)+2
    107         .. S IBLCNT=IBLCNT+1,IBXSAVE("RX-UB-04",IBLCNT)=""
    108         .. S IBLCNT=IBLCNT+1,IBXSAVE("RX-UB-04",IBLCNT)="PRESCRIPTION REFILLS:",IBLCNT=2
    109         .. S IBX=0 F  S IBX=$O(IBARRAY(IBX)) Q:IBX=""  S IBY=0 F  S IBY=$O(IBARRAY(IBX,IBY)) Q:'IBY  S IBRX=IBARRAY(IBX,IBY) D
    110         ... D ZERO^IBRXUTL(+$P(IBRX,U,2))
    111         ... S IBLCNT=IBLCNT+1,IBXSAVE("RX-UB-04",IBLCNT)=IBX_$J(" ",(11-$L(IBX)))_" "_$J($S($P(IBRX,U,6):"$"_$FN($P(IBRX,U,6),",",2),1:""),10)_"  "_$J($$FMTE^XLFDT(IBY,2),8)_"  "_$G(^TMP($J,"IBDRUG",+$P(IBRX,U,2),.01))
    112         ... S IBZ=$S(+$P(IBRX,U,4):"QTY: "_$P(IBRX,U,4)_" ",1:"")_$S(+$P(IBRX,U,3):"for "_$P(IBRX,U,3)_" days supply ",1:"") I IBZ'="" S IBLCNT=IBLCNT+1,IBXSAVE("RX-UB-04",IBLCNT)=$J(" ",35)_IBZ
    113         ... S IBZ=$S($P(IBRX,U,5)'="":"NDC #: "_$P(IBRX,U,5),1:"") I IBZ'="" S IBLCNT=IBLCNT+1,IBXSAVE("RX-UB-04",IBLCNT)=$J(" ",35)_IBZ
    114         ... K ^TMP($J,"IBDRUG")
    115         ... Q
    116         . ;
    117         . D SET^IBCSC5B(IBIFN,.IBARRAY)
    118         . I $P(IBARRAY,U,2) D
    119         .. S IBLCNT=0
    120         .. S IBX=+$P(IBARRAY,U,2)+2
    121         .. S IBLCNT=IBLCNT+1,IBXSAVE("PROS-UB-04",IBLCNT)=""
    122         .. S IBLCNT=IBLCNT+1,IBXSAVE("PROS-UB-04",IBLCNT)="PROSTHETIC REFILLS:",IBLCNT=2
    123         .. S IBX=0 F  S IBX=$O(IBARRAY(IBX)) Q:IBX=""  S IBY=0 F  S IBY=$O(IBARRAY(IBX,IBY)) Q:'IBY  D
    124         ... S IBLCNT=IBLCNT+1,IBXSAVE("PROS-UB-04",IBLCNT)=$$FMTE^XLFDT(IBX,2)_" "_$J($S($P(IBARRAY(IBX,IBY),U,2):"$"_$FN($P(IBARRAY(IBX,IBY),U,2),",",2),1:""),10)_"  "_$E($$PINB^IBCSC5B(+IBARRAY(IBX,IBY)),1,54)
    125         Q
    126         ;
    127 ACCRV(X)        ; Returns 1 if X is an accomodation RC, 0 if not
    128         Q ((X'<100&(X'>219))!(X=224))
    129         ;
     1IBCEF22 ;ALB/TMP - FORMATTER SPECIFIC BILL FUNCTIONS ;06-FEB-96
     2 ;;2.0;INTEGRATED BILLING;**51,137,135,155,309,349**;21-MAR-94;Build 46
     3 ;;Per VHA Directive 2004-038, this routine should not be modified.
     4 ;
     5 ;  OVERFLOW FROM ROUTINE IBCEF2
     6HOS(IBIFN) ; Extract rev codes for episode billed on a UB-04 into IBXDATA
     7 ; IBIFN = bill ien
     8 ; Format: IBXDATA(n) =
     9 ;  rev cd ptr ^ CPT CODE ptr ^ unit chg ^ units ^ tot charge
     10 ;    ^ tot uncov^ FL49 value ^ ien of rev code multiple entry(s)
     11 ;      (separated by ";")
     12 ;    ^ modifiers specific to rev code/proc (separated by ",")
     13 ;    ^ rev code date, if it can be determined by a corresponding proc
     14 ;
     15 ;   Also Returns IBXDATA(IBI,"COB",COB,m) with COB data for each line
     16 ;      item found in an accepted EOB for the bill and = the reference
     17 ;      line in the first '^' piece followed by the '0' node of file
     18 ;      361.115 (LINE LEVEL ADJUSTMENTS)
     19 ;       COB = COB seq # of adjustment's ins co, m = seq #
     20 ;         -- AND --
     21 ;    IBXDATA(IBI,"COB",COB,m,z,p)=
     22 ;           the '0' node for each subordinate entry of file
     23 ;           361.11511 (REASONS) (Only first 3 pieces for 837)
     24 ;       z = group code, sometimes preceeded by a space   p = seq #
     25 ;
     26 N IBDA,IBCOMB,IBINPAT,IBLN,IBX,IBY,IBZ,IBS,IBSS,IBXTRA,IBX1,IBXS,IBP,IBPO,IBP1,IBDEF,Z,Z0,Z1,ZX,QQ,IBMOD
     27 S IBINPAT=$$INPAT^IBCEF(IBIFN,1)
     28 I 'IBINPAT D F^IBCEF("N-STATEMENT COVERS FROM DATE","IBZ",,IBIFN)
     29 S IBDEF=$G(IBZ)
     30 ; loop through all proc codes - sort by procedure, modifiers and print order
     31 S IBDA=0 F  S IBDA=$O(^DGCR(399,IBIFN,"CP",IBDA)) Q:'IBDA  S IBZ=$G(^(IBDA,0)) I IBZ D
     32 . S IBP(+$P(IBZ,U)_U_$$GETMOD^IBEFUNC(IBIFN,IBDA,1),$S($P(IBZ,U,4):$P(IBZ,U,4),1:999),IBDA)=$P(IBZ,U,2)
     33 ; loop through all rev codes - sort by rev code
     34 S IBDA=0 F  S IBDA=$O(^DGCR(399,IBIFN,"RC",IBDA)) Q:'IBDA  S IBZ=$G(^(IBDA,0)) I IBZ S IBMOD="" D
     35 . S IBX=$G(^DGCR(399.2,+IBZ,0)),IBX1="",IBPO=0
     36 . ; Auto-added procedure charge
     37 . I $P(IBZ,U,10)=4,$P(IBZ,U,11) D  ; Soft link to proc
     38 .. S Z=$G(^DGCR(399,IBIFN,"CP",$P(IBZ,U,11),0))
     39 .. Q:Z=""
     40 .. S ZX=+Z_U_$$GETMOD^IBEFUNC(IBIFN,$P(IBZ,U,11),1)
     41 .. Q:'$O(IBP(ZX,0))&'$O(IBP1(ZX,0))
     42 .. I $P(IBZ,U,6) Q:$S($P(Z,U)'["ICPT":1,1:+$P(Z,U)'=$P(IBZ,U,6))
     43 .. S Z0=$S($D(IBP(ZX)):$O(IBP(ZX,0)),1:$O(IBP1(ZX,0)))
     44 .. S:'Z0 Z0=999
     45 .. Q:'$D(IBP(ZX,+Z0,$P(IBZ,U,11)))&'$D(IBP1(ZX,+Z0,$P(IBZ,U,11)))
     46 .. I '$D(IBP1(ZX,+Z0,$P(IBZ,U,11))) S IBP1(ZX,+Z0,$P(IBZ,U,11))=IBP(ZX,+Z0,$P(IBZ,U,11)) K IBP(ZX,+Z0,$P(IBZ,U,11))
     47 .. S IBX1=$P(Z,U,2),IBPO=+Z0,IBMOD=$P(ZX,U,2)
     48 . ; Manually added charge with a procedure
     49 . I $P(IBZ,U,6),$S($P(IBZ,U,10)=4:'$P(IBZ,U,11),1:1),+$O(IBP($P(IBZ,U,6)))=$P(IBZ,U,6) D
     50 .. ; No direct link, but a proc exists on rev code and in procedure mult without and then with modifiers
     51 .. S ZX=$O(IBP($P(IBZ,U,6)))
     52 .. F QQ=1,2 Q:IBPO  S Z="" F  S Z=$O(IBP(ZX,Z),-1) Q:'Z!(IBPO)  S Z0=0 F  S Z0=$O(IBP(ZX,Z,Z0)) Q:'Z0  S Z1=$G(^DGCR(399,IBIFN,"CP",Z0,0)) D  Q:IBPO
     53 ... ; Ignore if not a CPT or a modifier exists and this is first pass
     54 ... S IBMOD=$$GETMOD^IBEFUNC(IBIFN,Z0,1)
     55 ... Q:$S($P(Z1,U)'["ICPT":1,QQ=1:IBMOD'="",1:0)
     56 ... S IBPO=+$P(Z1,U,4),IBX1=$P(Z1,U,2)
     57 ... K IBP(+Z1_U_IBMOD,Z,Z0)
     58 . ;
     59 . I IBX'="" D  ; revenue code is valid
     60 .. F Z=900:1 S Z0=$S(IBPO:IBPO,$D(IBX(" "_$P(IBX,U),Z)):0,1:Z) I Z0 S IBPO=Z0 Q
     61 .. S IBX(" "_$P(IBX,U),IBPO,IBDA)=IBX,IBX(" "_$P(IBX,U),IBPO,IBDA,"DT")=$S(IBX1:IBX1,1:IBDEF),IBX(" "_$P(IBX,U),IBPO,IBDA,"MOD")=IBMOD
     62 ;
     63 S IBS="" F  S IBS=$O(IBX(IBS)) Q:IBS=""  S IBPO=0 F  S IBPO=$O(IBX(IBS,IBPO)) Q:'IBPO  D
     64 . S IBDA=0 F  S IBDA=$O(IBX(IBS,IBPO,IBDA)) Q:'IBDA  S IBX=$G(IBX(IBS,IBPO,IBDA)),IBZ=$G(^DGCR(399,IBIFN,"RC",IBDA,0)) I IBX'="" D
     65 .. ;S IBXS=$P(IBZ,U,2)_U_$P(IBZ,U,6)_U_$G(IBX(IBS,IBPO,IBDA,"MOD"))
     66 .. S IBXS=U_$P(IBZ,U,6)_U_$G(IBX(IBS,IBPO,IBDA,"MOD")) ;combine same proc and modifiers regardless of rate
     67 .. S:IBPO'<900&'$$ACCRV($P(IBS," ",2))&$S(IBINPAT:$P(IBZ,U,6),1:1) IBCOMB(IBS,IBXS,IBPO)=IBDA
     68 .. S:'$D(IBX1(IBS,IBPO,IBXS,1)) IBX1(IBS,IBPO,IBXS,1)=IBX,IBX1(IBS,IBPO,IBXS,2)=IBZ
     69 .. S $P(IBX1(IBS,IBPO,IBXS),U)=$P($G(IBX1(IBS,IBPO,IBXS)),U)+$P(IBZ,U,3)
     70 .. S $P(IBX1(IBS,IBPO,IBXS),U,2)=$P($G(IBX1(IBS,IBPO,IBXS)),U,2)+$P(IBZ,U,4)
     71 .. S IBX1(IBS,IBPO,IBXS,"DT")=$G(IBX(IBS,IBPO,IBDA,"DT")),IBX1(IBS,IBPO,IBXS,"IEN")=$G(IBX1(IBS,IBPO,IBXS,"IEN"))_$S($G(IBX1(IBS,IBPO,IBXS,"IEN")):";",1:"")_IBDA
     72 ;
     73 S IBS="" F  S IBS=$O(IBX1(IBS)) Q:IBS=""  S IBPO=899 F  S IBPO=$O(IBX1(IBS,IBPO)) Q:'IBPO  D  ; Check to combine like rev codes without print order
     74 . N Q,Q0,Q1,Z,Z0,Z1,Z2,IBZ1,IBZ2
     75 . S Z=""
     76 . N IBACC
     77 . F  S Z=$O(IBX1(IBS,IBPO,Z)) Q:Z=""  S Q=IBPO F  S Q=$O(IBCOMB(IBS,Z,Q)) Q:'Q  I Q'=IBPO S IBZ1=$G(IBX1(IBS,IBPO,Z,1)),IBZ2=$G(IBX1(IBS,IBPO,Z,2)) D
     78 .. Q:$G(IBX1(IBS,IBPO,Z,1))'=$G(IBX1(IBS,Q,Z,1))
     79 .. S Q1=1,IBACC=$$ACCRV(+$P(IBS," ",2))
     80 .. F Q0=1,5:1:7,10:1:13,15 D  Q:'Q1
     81 ... I IBACC Q:Q0=5!(Q0>6)
     82 ... I (Q0=11!(Q0=15))&($P($G(IBX1(IBS,Q,Z,2)),U,10)=3) Q
     83 ... I Q0=5,'IBINPAT Q
     84 ... I $P($G(IBX1(IBS,IBPO,Z,2)),U,Q0)'=$P($G(IBX1(IBS,Q,Z,2)),U,Q0) S Q1=0
     85 .. Q:'Q1
     86 .. S $P(IBX1(IBS,IBPO,Z,2),U,3)=$P(IBX1(IBS,IBPO,Z,2),U,3)+$P(IBX1(IBS,Q,Z,2),U,3)
     87 .. S $P(IBX1(IBS,IBPO,Z,2),U,4)=$P(IBX1(IBS,IBPO,Z,2),U,4)+$P(IBX1(IBS,Q,Z,2),U,4)
     88 .. S $P(IBX1(IBS,IBPO,Z,2),U,9)=$P(IBX1(IBS,IBPO,Z,2),U,9)+$P(IBX1(IBS,Q,Z,2),U,9)
     89 .. S IBX1(IBS,IBPO,Z)=$P(IBX1(IBS,IBPO,Z,2),U,3)_U_$P(IBX1(IBS,IBPO,Z,2),U,4)
     90 .. S IBX1(IBS,IBPO,Z,"IEN")=IBX1(IBS,IBPO,Z,"IEN")_";"_IBX1(IBS,Q,Z,"IEN")
     91 .. K IBX1(IBS,Q,Z)
     92 ;
     93 S IBS="",IBLN=0
     94 F  S IBS=$O(IBX1(IBS)) Q:IBS=""  S IBPO=0 F  S IBPO=$O(IBX1(IBS,IBPO)) Q:'IBPO  S IBSS="" F  S IBSS=$O(IBX1(IBS,IBPO,IBSS)) Q:IBSS=""  D
     95 . S IBX=$G(IBX1(IBS,IBPO,IBSS,1)),IBZ=$G(IBX1(IBS,IBPO,IBSS,2))
     96 . S IBLN=$G(IBLN)+1,IBXDATA(IBLN)=$P(IBX,U)_U_$P(IBZ,U,6)_U_$P(IBZ,U,2)_U_+IBX1(IBS,IBPO,IBSS)_U_+$P(IBX1(IBS,IBPO,IBSS),U,2),$P(IBXDATA(IBLN),U,10)=$G(IBX1(IBS,IBPO,IBSS,"DT"))
     97 . S $P(IBXDATA(IBLN),U,6)=$P(IBZ,U,9),$P(IBXDATA(IBLN),U,7)=$P(IBZ,U,13),$P(IBXDATA(IBLN),U,8)=$G(IBX1(IBS,IBPO,IBSS,"IEN")),$P(IBXDATA(IBLN),U,9)=$P($P(IBSS,U,3),",",1,2)
     98 . ; Extract line lev COB data for sec or tert bill
     99 . I $$COBN^IBCEF(IBIFN)>1 D COBLINE^IBCEU6(IBIFN,IBLN,.IBXDATA,,.IBXTRA) I $D(IBXTRA) D COMBO^IBCEU2(.IBXDATA,.IBXTRA,1) ;Handle bundled/unbundled
     100 I $D(^IBA(362.4,"AIFN"_IBIFN))!$D(^IBA(362.5,"AIFN"_IBIFN)) D
     101 . N IBARRAY,IBX,IBZ,IBRX,IBLCNT
     102 . S IBLCNT=0
     103 . ; Print prescriptions, prosthetics on front of UB-04
     104 . D SET^IBCSC5A(IBIFN,.IBARRAY)
     105 . I $P(IBARRAY,U,2) D
     106 .. S IBX=+$P(IBARRAY,U,2)+2
     107 .. S IBLCNT=IBLCNT+1,IBXSAVE("RX-UB-04",IBLCNT)=""
     108 .. S IBLCNT=IBLCNT+1,IBXSAVE("RX-UB-04",IBLCNT)="PRESCRIPTION REFILLS:",IBLCNT=2
     109 .. S IBX=0 F  S IBX=$O(IBARRAY(IBX)) Q:IBX=""  S IBY=0 F  S IBY=$O(IBARRAY(IBX,IBY)) Q:'IBY  S IBRX=IBARRAY(IBX,IBY) D
     110 ... D ZERO^IBRXUTL(+$P(IBRX,U,2))
     111 ... S IBLCNT=IBLCNT+1,IBXSAVE("RX-UB-04",IBLCNT)=IBX_$J(" ",(11-$L(IBX)))_" "_$J($S($P(IBRX,U,6):"$"_$FN($P(IBRX,U,6),",",2),1:""),10)_"  "_$J($$FMTE^XLFDT(IBY,2),8)_"  "_$G(^TMP($J,"IBDRUG",+$P(IBRX,U,2),.01))
     112 ... S IBZ=$S(+$P(IBRX,U,4):"QTY: "_$P(IBRX,U,4)_" ",1:"")_$S(+$P(IBRX,U,3):"for "_$P(IBRX,U,3)_" days supply ",1:"") I IBZ'="" S IBLCNT=IBLCNT+1,IBXSAVE("RX-UB-04",IBLCNT)=$J(" ",35)_IBZ
     113 ... S IBZ=$S($P(IBRX,U,5)'="":"NDC #: "_$P(IBRX,U,5),1:"") I IBZ'="" S IBLCNT=IBLCNT+1,IBXSAVE("RX-UB-04",IBLCNT)=$J(" ",35)_IBZ
     114 ... K ^TMP($J,"IBDRUG")
     115 ... Q
     116 . ;
     117 . D SET^IBCSC5B(IBIFN,.IBARRAY)
     118 . I $P(IBARRAY,U,2) D
     119 .. S IBLCNT=0
     120 .. S IBX=+$P(IBARRAY,U,2)+2
     121 .. S IBLCNT=IBLCNT+1,IBXSAVE("PROS-UB-04",IBLCNT)=""
     122 .. S IBLCNT=IBLCNT+1,IBXSAVE("PROS-UB-04",IBLCNT)="PROSTHETIC REFILLS:",IBLCNT=2
     123 .. S IBX=0 F  S IBX=$O(IBARRAY(IBX)) Q:IBX=""  S IBY=0 F  S IBY=$O(IBARRAY(IBX,IBY)) Q:'IBY  D
     124 ... S IBLCNT=IBLCNT+1,IBXSAVE("PROS-UB-04",IBLCNT)=$$FMTE^XLFDT(IBX,2)_" "_$J($S($P(IBARRAY(IBX,IBY),U,2):"$"_$FN($P(IBARRAY(IBX,IBY),U,2),",",2),1:""),10)_"  "_$E($P($$PIN^IBCSC5B(IBY),U,2),1,54)
     125 Q
     126 ;
     127ACCRV(X) ; Returns 1 if X is an accomodation RC, 0 if not
     128 Q ((X'<100&(X'>219))!(X=224))
     129 ;

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF3.m

    r613 r623  
    1 IBCEF3  ;ALB/TMP - FORMATTER SPECIFIC BILL FLD FUNCTIONS ;17-JUNE-96
    2         ;;2.0;INTEGRATED BILLING;**52,84,121,51,152,210,155,348,349,389**;21-MAR-94;Build 6
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5 MPG(PG,FLDS,FORM)       ; Set static flds on pages after page 1
    6         ;        for either 1500 or UB
    7         ;  PG = page #
    8         ; FORM= 1 for UB, otherwise for 1500
    9         ;  FLDS: array passed by reference and containing lines OR
    10         ;        line/column from pg 1 to repeat on subsequent pages
    11         ;        Format: FLDS(LINE,COL)  or  FLDS(LINE) for whole line
    12         ;   CMS-1500:        LINES 1-5,7-43,57 from col 1 to 50, 58-63
    13         ;         UB:        see CKPGUB for lines and columns
    14         ;
    15         N Z,Z0,Z1,LPG
    16         S FORM=$S($G(FORM)=1:3,1:2)
    17         I FORM=2 D  ; print page # on each pg, totals on last page of 1500
    18         . S LPG=+$O(^TMP("IBXDATA",$J,IBXREC,""),-1)
    19         . S Z="[Page "_PG_" of "_LPG_"]"
    20         . S Z=$$FO^IBCNEUT1(Z,17,"R")
    21         . D SETGBL^IBCEFG(PG,6,61,Z,.IBXSIZE)
    22         . I PG=2 S Z=$P(Z,"[",1)_"[Page 1 of "_LPG_"]" D SETGBL^IBCEFG(1,6,61,Z,.IBXSIZE)
    23         . I LPG=PG D
    24         .. ;
    25         .. ; esg - IB*2*348 - update dollar format for last page of 1500
    26         .. ;
    27         .. D SETGBL^IBCEFG(PG,57,51,$$DOL^IBCEF77($G(IBXSAVE("TOT")),9),.IBXSIZE)
    28         .. D SETGBL^IBCEFG(PG,57,62,$$DOL^IBCEF77($G(IBXSAVE("PAID")),8),.IBXSIZE)
    29         .. D SETGBL^IBCEFG(PG,57,71,$$DOL^IBCEF77($G(IBXSAVE("BDUE")),8),.IBXSIZE)
    30         .. K IBXSAVE("PTOT"),IBXSAVE("TOT"),IBXSAVE("BDUE"),IBXSAVE("PAID")
    31         ;
    32         S Z=0 F  S Z=$O(FLDS(Z)) Q:'Z  D
    33         . I $O(FLDS(Z,""))="" D  Q  ;repeats line
    34         .. S Z0=0 F  S Z0=$O(^TMP("IBXDATA",$J,IBXREC,1,Z,Z0)) Q:'Z0  S Z1=$G(^(Z0)) I Z1'="" D SETGBL^IBCEFG(PG,Z,Z0,Z1,.IBXSIZE)
    35         . S Z0=0 F  S Z0=$O(FLDS(Z,Z0)) Q:'Z0  S Z1=$G(^TMP("IBXDATA",$J,IBXREC,1,Z,Z0)) I Z1'="" D SETGBL^IBCEFG(PG,Z,Z0,Z1,.IBXSIZE)
    36         . I FORM=2,LPG'=PG D
    37         .. D SETGBL^IBCEFG(PG,57,51,"",.IBXSIZE)
    38         .. D SETGBL^IBCEFG(PG,57,71,"",.IBXSIZE)
    39         Q
    40         ;
    41 NONSERV(Z,Z0)   ; Set variable if non-service/non-text data is present for box
    42         ;  24 of CMS-1500
    43         ; Z = sequence of IBXSAVE being processed
    44         ; Z0 = sequnce within IBXDATA to indicate actual line #
    45         I $P(IBXSAVE("BOX24",Z),U)="" S IBXSAVE("NON-SERV",Z0)=""
    46         Q
    47         ;
    48 PG(VAL,LNCT)    ;Set next pg for CMS-1500 lines
    49         ;VAL = value of fld
    50         ;LNCT = line # from IBXSAVE("BOX24") array
    51         N IBP,IBL
    52         S IBP=LNCT\12+(LNCT#12>0),IBL=LNCT-(12*(IBP-1))-1
    53         I IBL'<0 S VAL=$$FORMAT(VAL,$G(IBXLOOP("IBX0")),$G(IBXDA)) D SETGBL^IBCEFG(IBP,IBXLN+IBL,IBXCOL,VAL,.IBXSIZE)
    54         K IBXDATA(LNCT)
    55         Q
    56         ;
    57 MPGUB(PG,OFFSET,VAL,IBLN,IBCOL,NOFORM)  ; Set up pages > 1 for UB overflows
    58         ; PG = Page # to set (REQUIRED)
    59         ; OFFSET = offset from first line this should be extracted into
    60         ;          0 = first line (REQUIRED)
    61         ; VAL = value to set (REQUIRED)
    62         ; IBLN = line to set data at (if null, uses IBXLN)
    63         ; IBCOL = column to set data at (if null, uses IBXCOL)
    64         ; NOFORM = don't format, just output data as passed
    65         ; Assumes formatter IBXLN,IBXCOL variables exist
    66         ;
    67         I $G(IBLN)="" S IBLN=IBXLN
    68         I $G(IBCOL)="" S IBCOL=IBXCOL
    69         S:'$G(NOFORM) VAL=$$FORMAT(VAL,$G(IBXLOOP("IBX0")),$G(IBXDA))
    70         D SETGBL^IBCEFG(PG,IBLN+OFFSET,IBCOL,VAL,.IBXSIZE)
    71         Q
    72         ;
    73 CKREV(CT,VAL)   ; Check too many rev code lines to fit on page
    74         ; This procedure is only called when CT>22 (i.e. 23 or more)
    75         ;
    76         D MPGUB((CT-1)\22+1,CT-1#22,VAL) ; 22 codes on a single page
    77         Q
    78         ;
    79 CKPGUB  ; Check to see if multiple UB pages are needed then populate
    80         ; static flds from page 1, add page numbers
    81         ;
    82         N FLDS,LPG,IBPG,IBP,Z,Z0,TOT1,TOT2
    83         ;
    84         S LPG=$O(^TMP("IBXDATA",$J,IBXREC,""),-1),IBP=0
    85         S Z="" F  S Z=$O(^TMP("IBXDATA",$J,IBXREC,LPG,Z),-1) Q:'Z  S Z0=0 F  S Z0=$O(^TMP("IBXDATA",$J,IBXREC,LPG,Z,Z0)) Q:'Z0  I $G(^(Z0))'="" S IBP=1 Q
    86         I 'IBP K ^TMP("IBXDATA",$J,IBXREC,LPG) S LPG=$O(^TMP("IBXDATA",$J,IBXREC,""),-1) Q:LPG=1
    87         ;
    88         ; Static flds
    89         F Z=2:1:7 S FLDS(Z)=""    ; FL-1 thru FL-9
    90         F Z=1,10,13,19,22,25,28,31 S FLDS(9,Z)=""    ; FL-10 thru FL-17
    91         F Z=13:1:17 S FLDS(Z,1)=""   ; payer address in FL-38
    92         S FLDS(41,46)=""     ; creation date
    93         F Z=42,43,44,45,47,48,49,51,52,53 S FLDS(Z)=""   ; FL-50 thru FL-65
    94         F Z=57,59,61,63 S (FLDS(Z,59),FLDS(Z,72),FLDS(Z,74))=""   ; FL-76-79 ID's
    95         F Z=58,60,62,64 S (FLDS(Z,53),FLDS(Z,71))=""    ; FL-76-79 Names
    96         ;
    97         F IBPG=1:1:LPG D
    98         . ; Add pg # to last line of rev codes if multiple pages
    99         . N IB,IBP
    100         . S IB=$G(^TMP("IBXDATA",$J,IBXREC,IBPG,41,6))
    101         . D MPGUB(IBPG,0,IBPG,41,10,1)
    102         . D MPGUB(IBPG,0,LPG,41,16,1)
    103         . D:IBPG>1 MPG(IBPG,.FLDS,1)
    104         . Q
    105         ; print totals on line 41 of the last page
    106         S (TOT1,TOT2)=0
    107         F Z=1:1 Q:'$D(^TMP($J,"IBC-RC",Z))  S Z0=^(Z) I +Z0=1 S TOT1=TOT1+$P(Z0,U,7),TOT2=TOT2+$P(Z0,U,8)
    108         D MPGUB(IBPG,0,"0001",41,1,1)
    109         D MPGUB(IBPG,0,$$DOL^IBCEF77(TOT1,9),41,61,1)
    110         D MPGUB(IBPG,0,$$DOL^IBCEF77(TOT2,9),41,71,1)
    111         ;
    112         Q
    113         ;
    114 HCPC(R) ;FORMAT HCPC fld FOR UB (returns formatted value)
    115         ; R = flag for type of fld (1/2/3) being printed in rev code block
    116         Q R  ;No longer used as of patch IB*2.0*51
    117         ;
    118 PROS(IBIFN)     ; Extract billable prosthetics for 837
    119         N IBARRAY,Z,Z0,CT,PROS
    120         D SET^IBCSC5B(IBIFN,.IBARRAY)
    121         I '$P(IBARRAY,U,2) S CT="" G PROSQ
    122         S Z="",CT=0
    123         F  S Z=$O(IBARRAY(Z)) Q:Z=""  S Z0="" F  S Z0=$O(IBARRAY(Z,Z0)) Q:Z0=""  S CT=CT+1 D
    124         .S PROS=$$PINB^IBCSC5B(+IBARRAY(Z,Z0)) ; P389 removed p2 - item ptr file 661
    125         .;date^^short descr^entry # in file 362.5
    126         .S IBXDATA(CT)=Z_U_U_PROS_U_+IBARRAY(Z,Z0)
    127 PROSQ   Q CT
    128         ;
    129 B24(IBXSV,IBIFN,IBNOSHOW)       ; Code to execute to set up IBXSV("BOX24") for
    130         ;   print or IBXSAVE("OUTPT") for transmit - called by output formatter
    131         ; IBNOSHOW = 1 if not to show error/warning text lines
    132         ; Pass IBXSV by reference
    133         N IBSUB
    134         S IBSUB=$S('$G(^TMP("IBTX",$J,IBIFN)):"BOX24",1:"OUTPT")
    135         K IBXSV(IBSUB)
    136         I '$D(IBIFN) S IBIFN=$G(IBXIEN)
    137         I IBIFN D F^IBCEF("N-HCFA 1500 SERVICE"_$S(IBSUB["24":"S (PRINT",1:" LINE (EDI")_")",,,IBIFN)
    138         I $S(IBSUB'["24":1,1:'$G(IBNOSHOW)) D
    139         . M IBXSV(IBSUB)=IBXDATA
    140         E  D
    141         . N Z,CT
    142         . S (Z,CT)=0 F  S Z=$O(IBXDATA(Z)) Q:'Z  I '$D(IBXDATA(Z,"ARX")) S CT=CT+1 M IBXSV(IBSUB,CT)=IBXDATA(Z)
    143         Q
    144         ;
    145         ; esg - 11/14/03 - Moved the below functions due to space constraints
    146         ;
    147 ALLTYP(IBIFN)   Q $$ALLTYP^IBCEF31(IBIFN)
    148 INSTYP(IBIFN,SEQ)       Q $$INSTYP^IBCEF31(IBIFN,$G(SEQ))
    149 POLTYP(IBIFN,IBSEQ)     Q $$POLTYP^IBCEF31(IBIFN,$G(IBSEQ))
    150 ALLPTYP(IBIFN)  Q $$ALLPTYP^IBCEF31(IBIFN)
    151         ;
    152 FILL(Z) ;
    153         Q
    154         ;
    155         ;  *****
    156         ;  The following code performs the multi-page set up for
    157         ;  printing overflow data on the UB
    158         ;  *****
    159         ;
    160 XPROC(DATA,CT)  ; Output any UB procedures after 6 on new page(s)
    161         ; DATA = output data from IBXSAVE("PROC",CT)
    162         ; CT = array sequence # of the procedure being output
    163         ; Only used for local prints
    164         N OFFSET,PG,COL,PRCODE,Q
    165         S Q=(CT-1)\3#2,OFFSET=$S('Q:0,1:2)
    166         S PG=(CT-1)\6+1,COL=1+(CT-1#3*15)
    167         D MPGUB(PG,OFFSET,$P(DATA,U,1),58,COL)
    168         D MPGUB(PG,OFFSET,$P(DATA,U,2),58,COL+9)
    169         Q
    170         ;
    171 XDIAG(DATA,CT)  ; Output any UB other diagnoses after 8 on new page(s)
    172         ; DATA = output data from IBXSAVE("DX",CT)
    173         ; CT = array sequence # of the diagnosis being output
    174         ; Only used for local prints
    175         N COL,PG
    176         S PG=(CT-1)\8+1,COL=8+(CT-1#9*7)
    177         S DATA=$P($$ICD9^IBACSV(+DATA),U,1)
    178         D MPGUB(PG,0,DATA,56,COL)
    179         Q
    180         ;
    181 XVAL(DATA,CT)   ; Output any UB value codes after 12 on new page(s)
    182         ; DATA = output data from IBXSAVE("VC",CT)
    183         ; CT = array sequence # of the value code being output
    184         ;
    185         N COL,PG,OFFSET
    186         S PG=(CT-1)\12+1,COL=44+(CT-1#3*13),OFFSET=(CT-(12*(PG-1))-1)\3
    187         D MPGUB(PG,OFFSET,$P(DATA,U,1),14,COL)
    188         D MPGUB(PG,OFFSET,$P(DATA,U,2),14,COL+3)
    189         Q
    190         ;
    191 XCC(DATA,CT)    ; Output any UB condition codes after 11 on new page(s)
    192         ; 11 condition codes per page, starting columns 34 thru 64
    193         ; DATA = output data from IBXSAVE("CC",CT)
    194         ; CT = array sequence # of the condition code being output
    195         ;
    196         N COL,PG
    197         S PG=(CT-1)\11+1,COL=34+(CT-1#11*3)
    198         D MPGUB(PG,0,DATA,9,COL)
    199         Q
    200         ;
    201 XOCC(DATA,CT,FL)        ; Output any UB occurrence codes after 8 (2 per form
    202         ;  locators 31-34) on new page(s)
    203         ; DATA = data from IBXSAVE("OCC",z) to be output
    204         ; CT = array sequence # of occurrence code being output
    205         ; FL = # of form locator being populated with the occ code
    206         ;
    207         N COL,PG,OFFSET
    208         S PG=(CT-1)\2+1,COL=1+((FL-31)*10),OFFSET=$S(CT#2:0,1:1)
    209         D MPGUB(PG,OFFSET,$P(DATA,U,1),11,COL)
    210         D MPGUB(PG,OFFSET,$P(DATA,U,2),11,COL+4)
    211         Q
    212         ;
    213 XOCCS(DATA,CT,FL)       ; Output any UB occurrence span codes after 4 on new page(s)
    214         ; DATA = data from IBXSAVE("OCCS",z) to be output
    215         ; CT = array sequence # of occurrence span code being output
    216         ; FL = # of form locator being populated (either FL 35 or 36)
    217         ;
    218         N COL,PG,OFFSET
    219         S PG=(CT-1)\2+1,OFFSET=$S(CT#2:0,1:1)
    220         S COL=41+((FL-35)*17)
    221         D MPGUB(PG,OFFSET,$P(DATA,U,1),11,COL)
    222         D MPGUB(PG,OFFSET,$P(DATA,U,2),11,COL+4)
    223         D MPGUB(PG,OFFSET,$P(DATA,U,3),11,COL+11)
    224         Q
    225         ;
    226 FORMAT(VAL,IBX0,IBXDA)  ;
    227         I IBX0'="",IBXDA S VAL=$$FORMAT^IBCEFG(VAL,$P($G(^IBA(364.6,+IBXDA,0)),U,9),$P(IBX0,U,7),IBX0)
    228         Q VAL
    229         ;
    230 OUTPDT(IBIFN,IBXSAVE,IBXDATA)   ; Returns outpatient service to date
    231         ;  formatted CCYYMMDD for UB 837
    232         ; IBIFN = ien of bill (file 399)
    233         ; IBXSAVE = pass by reference for IBXSAVE("INPT") and IBXSAVE("DATE")
    234         ; IBXDATA = array with formatted date or each line item - CCYYMMDD
    235         N Z
    236         S Z=0 F  S Z=$O(IBXSAVE("INPT",Z)) Q:'Z  S IBXDATA(Z)=$S($P(IBXSAVE("INPT",Z),U,10):$$DT^IBCEFG1($P(IBXSAVE("INPT",Z),U,10),,"D8"),1:IBXSAVE("DATE"))
    237         K IBXSAVE("DATE")
    238         Q
    239         ;
     1IBCEF3 ;ALB/TMP - FORMATTER SPECIFIC BILL FLD FUNCTIONS ;17-JUNE-96
     2 ;;2.0;INTEGRATED BILLING;**52,84,121,51,152,210,155,348,349**;21-MAR-94;Build 46
     3 ;;Per VHA Directive 2004-038, this routine should not be modified.
     4 ;
     5MPG(PG,FLDS,FORM) ; Set static flds on pages after page 1
     6 ;        for either 1500 or UB
     7 ;  PG = page #
     8 ; FORM= 1 for UB, otherwise for 1500
     9 ;  FLDS: array passed by reference and containing lines OR
     10 ;        line/column from pg 1 to repeat on subsequent pages
     11 ;        Format: FLDS(LINE,COL)  or  FLDS(LINE) for whole line
     12 ;   CMS-1500:        LINES 1-5,7-43,57 from col 1 to 50, 58-63
     13 ;         UB:        see CKPGUB for lines and columns
     14 ;
     15 N Z,Z0,Z1,LPG
     16 S FORM=$S($G(FORM)=1:3,1:2)
     17 I FORM=2 D  ; print page # on each pg, totals on last page of 1500
     18 . S LPG=+$O(^TMP("IBXDATA",$J,IBXREC,""),-1)
     19 . S Z="[Page "_PG_" of "_LPG_"]"
     20 . S Z=$$FO^IBCNEUT1(Z,17,"R")
     21 . D SETGBL^IBCEFG(PG,6,61,Z,.IBXSIZE)
     22 . I PG=2 S Z=$P(Z,"[",1)_"[Page 1 of "_LPG_"]" D SETGBL^IBCEFG(1,6,61,Z,.IBXSIZE)
     23 . I LPG=PG D
     24 .. ;
     25 .. ; esg - IB*2*348 - update dollar format for last page of 1500
     26 .. ;
     27 .. D SETGBL^IBCEFG(PG,57,51,$$DOL^IBCEF77($G(IBXSAVE("TOT")),9),.IBXSIZE)
     28 .. D SETGBL^IBCEFG(PG,57,62,$$DOL^IBCEF77($G(IBXSAVE("PAID")),8),.IBXSIZE)
     29 .. D SETGBL^IBCEFG(PG,57,71,$$DOL^IBCEF77($G(IBXSAVE("BDUE")),8),.IBXSIZE)
     30 .. K IBXSAVE("PTOT"),IBXSAVE("TOT"),IBXSAVE("BDUE"),IBXSAVE("PAID")
     31 ;
     32 S Z=0 F  S Z=$O(FLDS(Z)) Q:'Z  D
     33 . I $O(FLDS(Z,""))="" D  Q  ;repeats line
     34 .. S Z0=0 F  S Z0=$O(^TMP("IBXDATA",$J,IBXREC,1,Z,Z0)) Q:'Z0  S Z1=$G(^(Z0)) I Z1'="" D SETGBL^IBCEFG(PG,Z,Z0,Z1,.IBXSIZE)
     35 . S Z0=0 F  S Z0=$O(FLDS(Z,Z0)) Q:'Z0  S Z1=$G(^TMP("IBXDATA",$J,IBXREC,1,Z,Z0)) I Z1'="" D SETGBL^IBCEFG(PG,Z,Z0,Z1,.IBXSIZE)
     36 . I FORM=2,LPG'=PG D
     37 .. D SETGBL^IBCEFG(PG,57,51,"",.IBXSIZE)
     38 .. D SETGBL^IBCEFG(PG,57,71,"",.IBXSIZE)
     39 Q
     40 ;
     41NONSERV(Z,Z0) ; Set variable if non-service/non-text data is present for box
     42 ;  24 of CMS-1500
     43 ; Z = sequence of IBXSAVE being processed
     44 ; Z0 = sequnce within IBXDATA to indicate actual line #
     45 I $P(IBXSAVE("BOX24",Z),U)="" S IBXSAVE("NON-SERV",Z0)=""
     46 Q
     47 ;
     48PG(VAL,LNCT) ;Set next pg for CMS-1500 lines
     49 ;VAL = value of fld
     50 ;LNCT = line # from IBXSAVE("BOX24") array
     51 N IBP,IBL
     52 S IBP=LNCT\12+(LNCT#12>0),IBL=LNCT-(12*(IBP-1))-1
     53 I IBL'<0 S VAL=$$FORMAT(VAL,$G(IBXLOOP("IBX0")),$G(IBXDA)) D SETGBL^IBCEFG(IBP,IBXLN+IBL,IBXCOL,VAL,.IBXSIZE)
     54 K IBXDATA(LNCT)
     55 Q
     56 ;
     57MPGUB(PG,OFFSET,VAL,IBLN,IBCOL,NOFORM) ; Set up pages > 1 for UB overflows
     58 ; PG = Page # to set (REQUIRED)
     59 ; OFFSET = offset from first line this should be extracted into
     60 ;          0 = first line (REQUIRED)
     61 ; VAL = value to set (REQUIRED)
     62 ; IBLN = line to set data at (if null, uses IBXLN)
     63 ; IBCOL = column to set data at (if null, uses IBXCOL)
     64 ; NOFORM = don't format, just output data as passed
     65 ; Assumes formatter IBXLN,IBXCOL variables exist
     66 ;
     67 I $G(IBLN)="" S IBLN=IBXLN
     68 I $G(IBCOL)="" S IBCOL=IBXCOL
     69 S:'$G(NOFORM) VAL=$$FORMAT(VAL,$G(IBXLOOP("IBX0")),$G(IBXDA))
     70 D SETGBL^IBCEFG(PG,IBLN+OFFSET,IBCOL,VAL,.IBXSIZE)
     71 Q
     72 ;
     73CKREV(CT,VAL) ; Check too many rev code lines to fit on page
     74 ; This procedure is only called when CT>22 (i.e. 23 or more)
     75 ;
     76 D MPGUB((CT-1)\22+1,CT-1#22,VAL) ; 22 codes on a single page
     77 Q
     78 ;
     79CKPGUB ; Check to see if multiple UB pages are needed then populate
     80 ; static flds from page 1, add page numbers
     81 ;
     82 N FLDS,LPG,IBPG,IBP,Z,Z0,TOT1,TOT2
     83 ;
     84 S LPG=$O(^TMP("IBXDATA",$J,IBXREC,""),-1),IBP=0
     85 S Z="" F  S Z=$O(^TMP("IBXDATA",$J,IBXREC,LPG,Z),-1) Q:'Z  S Z0=0 F  S Z0=$O(^TMP("IBXDATA",$J,IBXREC,LPG,Z,Z0)) Q:'Z0  I $G(^(Z0))'="" S IBP=1 Q
     86 I 'IBP K ^TMP("IBXDATA",$J,IBXREC,LPG) S LPG=$O(^TMP("IBXDATA",$J,IBXREC,""),-1) Q:LPG=1
     87 ;
     88 ; Static flds
     89 F Z=2:1:7 S FLDS(Z)=""    ; FL-1 thru FL-9
     90 F Z=1,10,13,19,22,25,28,31 S FLDS(9,Z)=""    ; FL-10 thru FL-17
     91 F Z=13:1:17 S FLDS(Z,1)=""   ; payer address in FL-38
     92 S FLDS(41,46)=""     ; creation date
     93 F Z=42,43,44,45,47,48,49,51,52,53 S FLDS(Z)=""   ; FL-50 thru FL-65
     94 F Z=57,59,61,63 S (FLDS(Z,59),FLDS(Z,72),FLDS(Z,74))=""   ; FL-76-79 ID's
     95 F Z=58,60,62,64 S (FLDS(Z,53),FLDS(Z,71))=""    ; FL-76-79 Names
     96 ;
     97 F IBPG=1:1:LPG D
     98 . ; Add pg # to last line of rev codes if multiple pages
     99 . N IB,IBP
     100 . S IB=$G(^TMP("IBXDATA",$J,IBXREC,IBPG,41,6))
     101 . D MPGUB(IBPG,0,IBPG,41,10,1)
     102 . D MPGUB(IBPG,0,LPG,41,16,1)
     103 . D:IBPG>1 MPG(IBPG,.FLDS,1)
     104 . Q
     105 ; print totals on line 41 of the last page
     106 S (TOT1,TOT2)=0
     107 F Z=1:1 Q:'$D(^TMP($J,"IBC-RC",Z))  S Z0=^(Z) I +Z0=1 S TOT1=TOT1+$P(Z0,U,7),TOT2=TOT2+$P(Z0,U,8)
     108 D MPGUB(IBPG,0,"0001",41,1,1)
     109 D MPGUB(IBPG,0,$$DOL^IBCEF77(TOT1,9),41,61,1)
     110 D MPGUB(IBPG,0,$$DOL^IBCEF77(TOT2,9),41,71,1)
     111 ;
     112 Q
     113 ;
     114HCPC(R) ;FORMAT HCPC fld FOR UB (returns formatted value)
     115 ; R = flag for type of fld (1/2/3) being printed in rev code block
     116 Q R  ;No longer used as of patch IB*2.0*51
     117 ;
     118PROS(IBIFN) ; Extract billable prosthetics for 837
     119 N IBARRAY,Z,Z0,CT,PROS
     120 D SET^IBCSC5B(IBIFN,.IBARRAY)
     121 I '$P(IBARRAY,U,2) S CT="" G PROSQ
     122 S Z="",CT=0
     123 F  S Z=$O(IBARRAY(Z)) Q:Z=""  S Z0="" F  S Z0=$O(IBARRAY(Z,Z0)) Q:Z0=""  S CT=CT+1 D
     124 .S PROS=$P($$PIN^IBCSC5B(+$P($G(^IBA(362.5,+IBARRAY(Z,Z0),0)),U,3)),U,2)
     125 .;date^item ptr file 661^short descr from file 441^entry # in file 362.5
     126 .S IBXDATA(CT)=Z_U_Z0_U_PROS_U_+IBARRAY(Z,Z0)
     127PROSQ Q CT
     128 ;
     129B24(IBXSV,IBIFN,IBNOSHOW) ; Code to execute to set up IBXSV("BOX24") for
     130 ;   print or IBXSAVE("OUTPT") for transmit - called by output formatter
     131 ; IBNOSHOW = 1 if not to show error/warning text lines
     132 ; Pass IBXSV by reference
     133 N IBSUB
     134 S IBSUB=$S('$G(^TMP("IBTX",$J,IBIFN)):"BOX24",1:"OUTPT")
     135 K IBXSV(IBSUB)
     136 I '$D(IBIFN) S IBIFN=$G(IBXIEN)
     137 I IBIFN D F^IBCEF("N-HCFA 1500 SERVICE"_$S(IBSUB["24":"S (PRINT",1:" LINE (EDI")_")",,,IBIFN)
     138 I $S(IBSUB'["24":1,1:'$G(IBNOSHOW)) D
     139 . M IBXSV(IBSUB)=IBXDATA
     140 E  D
     141 . N Z,CT
     142 . S (Z,CT)=0 F  S Z=$O(IBXDATA(Z)) Q:'Z  I '$D(IBXDATA(Z,"ARX")) S CT=CT+1 M IBXSV(IBSUB,CT)=IBXDATA(Z)
     143 Q
     144 ;
     145 ; esg - 11/14/03 - Moved the below functions due to space constraints
     146 ;
     147ALLTYP(IBIFN) Q $$ALLTYP^IBCEF31(IBIFN)
     148INSTYP(IBIFN,SEQ) Q $$INSTYP^IBCEF31(IBIFN,$G(SEQ))
     149POLTYP(IBIFN,IBSEQ) Q $$POLTYP^IBCEF31(IBIFN,$G(IBSEQ))
     150ALLPTYP(IBIFN) Q $$ALLPTYP^IBCEF31(IBIFN)
     151 ;
     152FILL(Z) ;
     153 Q
     154 ;
     155 ;  *****
     156 ;  The following code performs the multi-page set up for
     157 ;  printing overflow data on the UB
     158 ;  *****
     159 ;
     160XPROC(DATA,CT) ; Output any UB procedures after 6 on new page(s)
     161 ; DATA = output data from IBXSAVE("PROC",CT)
     162 ; CT = array sequence # of the procedure being output
     163 ; Only used for local prints
     164 N OFFSET,PG,COL,PRCODE,Q
     165 S Q=(CT-1)\3#2,OFFSET=$S('Q:0,1:2)
     166 S PG=(CT-1)\6+1,COL=1+(CT-1#3*15)
     167 D MPGUB(PG,OFFSET,$P(DATA,U,1),58,COL)
     168 D MPGUB(PG,OFFSET,$P(DATA,U,2),58,COL+9)
     169 Q
     170 ;
     171XDIAG(DATA,CT) ; Output any UB other diagnoses after 8 on new page(s)
     172 ; DATA = output data from IBXSAVE("DX",CT)
     173 ; CT = array sequence # of the diagnosis being output
     174 ; Only used for local prints
     175 N COL,PG
     176 S PG=(CT-1)\8+1,COL=8+(CT-1#9*7)
     177 S DATA=$P($$ICD9^IBACSV(+DATA),U,1)
     178 D MPGUB(PG,0,DATA,56,COL)
     179 Q
     180 ;
     181XVAL(DATA,CT) ; Output any UB value codes after 12 on new page(s)
     182 ; DATA = output data from IBXSAVE("VC",CT)
     183 ; CT = array sequence # of the value code being output
     184 ;
     185 N COL,PG,OFFSET
     186 S PG=(CT-1)\12+1,COL=44+(CT-1#3*13),OFFSET=(CT-(12*(PG-1))-1)\3
     187 D MPGUB(PG,OFFSET,$P(DATA,U,1),14,COL)
     188 D MPGUB(PG,OFFSET,$P(DATA,U,2),14,COL+3)
     189 Q
     190 ;
     191XCC(DATA,CT) ; Output any UB condition codes after 11 on new page(s)
     192 ; 11 condition codes per page, starting columns 34 thru 64
     193 ; DATA = output data from IBXSAVE("CC",CT)
     194 ; CT = array sequence # of the condition code being output
     195 ;
     196 N COL,PG
     197 S PG=(CT-1)\11+1,COL=34+(CT-1#11*3)
     198 D MPGUB(PG,0,DATA,9,COL)
     199 Q
     200 ;
     201XOCC(DATA,CT,FL) ; Output any UB occurrence codes after 8 (2 per form
     202 ;  locators 31-34) on new page(s)
     203 ; DATA = data from IBXSAVE("OCC",z) to be output
     204 ; CT = array sequence # of occurrence code being output
     205 ; FL = # of form locator being populated with the occ code
     206 ;
     207 N COL,PG,OFFSET
     208 S PG=(CT-1)\2+1,COL=1+((FL-31)*10),OFFSET=$S(CT#2:0,1:1)
     209 D MPGUB(PG,OFFSET,$P(DATA,U,1),11,COL)
     210 D MPGUB(PG,OFFSET,$P(DATA,U,2),11,COL+4)
     211 Q
     212 ;
     213XOCCS(DATA,CT,FL) ; Output any UB occurrence span codes after 4 on new page(s)
     214 ; DATA = data from IBXSAVE("OCCS",z) to be output
     215 ; CT = array sequence # of occurrence span code being output
     216 ; FL = # of form locator being populated (either FL 35 or 36)
     217 ;
     218 N COL,PG,OFFSET
     219 S PG=(CT-1)\2+1,OFFSET=$S(CT#2:0,1:1)
     220 S COL=41+((FL-35)*17)
     221 D MPGUB(PG,OFFSET,$P(DATA,U,1),11,COL)
     222 D MPGUB(PG,OFFSET,$P(DATA,U,2),11,COL+4)
     223 D MPGUB(PG,OFFSET,$P(DATA,U,3),11,COL+11)
     224 Q
     225 ;
     226FORMAT(VAL,IBX0,IBXDA) ;
     227 I IBX0'="",IBXDA S VAL=$$FORMAT^IBCEFG(VAL,$P($G(^IBA(364.6,+IBXDA,0)),U,9),$P(IBX0,U,7),IBX0)
     228 Q VAL
     229 ;
     230OUTPDT(IBIFN,IBXSAVE,IBXDATA) ; Returns outpatient service to date
     231 ;  formatted CCYYMMDD for UB 837
     232 ; IBIFN = ien of bill (file 399)
     233 ; IBXSAVE = pass by reference for IBXSAVE("INPT") and IBXSAVE("DATE")
     234 ; IBXDATA = array with formatted date or each line item - CCYYMMDD
     235 N Z
     236 S Z=0 F  S Z=$O(IBXSAVE("INPT",Z)) Q:'Z  S IBXDATA(Z)=$S($P(IBXSAVE("INPT",Z),U,10):$$DT^IBCEFG1($P(IBXSAVE("INPT",Z),U,10),,"D8"),1:IBXSAVE("DATE"))
     237 K IBXSAVE("DATE")
     238 Q
     239 ;

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF73.m

    r613 r623  
    1 IBCEF73 ;WOIFO/SS - FORMATTER AND EXTRACTOR SPECIFIC BILL FUNCTIONS ;8/6/03 10:56am
    2         ;;2.0;INTEGRATED BILLING;**232,320,358,349,377**;21-MAR-94;Build 23
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5         ;check qualifier
    6         ;IBFRM 0-both, 1=UB,2=1500
    7         ;IBPROV - function in #399 (1-referring, 2-operating,etc)
    8         ;IBTYPE - "C"-current insurance, "O"-other insurance
    9         ;IBVAL - value to check
    10 CHCKSEC(IBFRM,IBPROV,IBTYPE,IBVAL)      ;
    11         I IBFRM=0 Q:$$CHSEC(1,IBPROV,IBTYPE,IBVAL) 1  Q $$CHSEC(2,IBPROV,IBTYPE,IBVAL)
    12         Q $$CHSEC(IBFRM,IBPROV,IBTYPE,IBVAL)
    13         ;
    14 CHSEC(IBFRM,IBPROV,IBTYPE,IBVAL)        ;
    15         N IBSTR S IBSTR=""
    16         ;referring
    17         I IBPROV=1 S IBSTR=$S(IBTYPE="C":$$OPR5(IBFRM),IBTYPE="O":$$OP4(IBFRM),1:"")
    18         ;operating
    19         I IBPROV=2 S IBSTR=$S(IBTYPE="C":$$OPR3(IBFRM),IBTYPE="O":$$OP2(IBFRM),1:"")
    20         ;rendering
    21         I IBPROV=3 S IBSTR=$S(IBTYPE="C":$$OPR2(IBFRM),IBTYPE="O":$$OP1(IBFRM),1:"")
    22         ;attending
    23         I IBPROV=4 S IBSTR=$S(IBTYPE="C":$$OPR2(IBFRM),IBTYPE="O":$$OP1(IBFRM),1:"")
    24         ;supervising
    25         I IBPROV=5 S IBSTR=$S(IBTYPE="C":$$OPR8(IBFRM),IBTYPE="O":$$OP8(IBFRM),1:"")
    26         ;other
    27         I IBPROV=9 S IBSTR=$S(IBTYPE="C":$$OPR4(IBFRM),IBTYPE="O":$$OP9(IBFRM),1:"")
    28         Q:IBPROV=0!(IBSTR="") 1  ;if "" or facility id always return 1
    29         Q IBSTR[("^"_IBVAL_"^")
    30         ;
    31         ;Filter invalid qualifier entries for records SUB1,SUB2,OP6,OP7,OP3
    32         ; Rebuild the IBXSAVE("PROVINF" or IBXSAVE("PROVINF_FAC" array with
    33         ;  only ids that have valid qualifiers
    34         ;IBFRM 0-both, 1=UB,2=1500
    35         ;IBREC record ID whose ids are being filtered (SUB1,SUB2,etc)
    36         ;IBFAC - 1 if facility check, 0 if attending/rendering check
    37         ;IBTYPE - "C"-current insurance, "O"-other insurance
    38         ;IBXSAVE - the array of provider ids extracted, returned filtered -
    39         ;   passed by reference
    40 CHCKSUB(IBFRM,IBREC,IBFAC,IBTYPE,IBXSAVE)       ;
    41         N Z,Z0,Z1,Z2,CT,IBSAVE
    42         S Z="PROVINF"_$P("^_FAC",U,$G(IBFAC)+1)
    43         I '$G(IBXSAVE(Z,IBXIEN)) D
    44         . D F^IBCEF("N-ALL "_$S($G(IBFAC):"OUTSIDE FAC PROVIDER INF",1:"CUR/OTH PROVIDER INFO"))
    45         M IBSAVE(Z,IBXIEN,IBTYPE)=IBXSAVE(Z,IBXIEN,IBTYPE) K IBXSAVE(Z,IBXIEN,IBTYPE)
    46         S Z0=0 F  S Z0=$O(IBSAVE(Z,IBXIEN,IBTYPE,Z0)) Q:'Z0  S Z1="" F  S Z1=$O(IBSAVE(Z,IBXIEN,IBTYPE,Z0,Z1)) Q:Z1=""  S (Z2,CT)=0 F  S Z2=$O(IBSAVE(Z,IBXIEN,IBTYPE,Z0,Z1,Z2)) Q:'Z2  D
    47         . N IBVAL
    48         . S IBVAL=$P(IBSAVE(Z,IBXIEN,IBTYPE,Z0,Z1,Z2),U,3)
    49         . I IBFRM=0 D  Q
    50         .. I $S($$CHSUB(1,IBREC,IBVAL):1,1:$$CHSUB(2,IBPROV,IBTYPE,IBVAL)) D
    51         ... S CT=CT+1,IBXSAVE(Z,IBXIEN,IBTYPE,Z0,Z1,CT)=IBSAVE(Z,IBXIEN,IBTYPE,Z0,Z1,Z2)
    52         ... I $G(IBXSAVE(Z,IBXIEN,IBTYPE,Z0))="",$G(IBSAVE(Z,IBXIEN,IBTYPE,Z0))'="" S IBXSAVE(Z,IBXIEN,IBTYPE,Z0)=IBSAVE(Z,IBXIEN,IBTYPE,Z0)
    53         . I $$CHSUB(IBFRM,IBREC,IBVAL) D
    54         .. S CT=CT+1,IBXSAVE(Z,IBXIEN,IBTYPE,Z0,Z1,CT)=IBSAVE(Z,IBXIEN,IBTYPE,Z0,Z1,Z2)
    55         .. I $G(IBXSAVE(Z,IBXIEN,IBTYPE,Z0))="",$G(IBSAVE(Z,IBXIEN,IBTYPE,Z0))'="" S IBXSAVE(Z,IBXIEN,IBTYPE,Z0)=IBSAVE(Z,IBXIEN,IBTYPE,Z0)
    56         Q
    57         ;
    58         ; Check if valid qualifier
    59         ;IBFRM 0-both, 1=UB,2=1500
    60         ;IBREC record ID whose ids are being filtered (SUB1,SUB2,etc)
    61         ;IBVAL - value to check
    62 CHSUB(IBFRM,IBREC,IBVAL)        ;
    63         N IBSTR
    64         I IBREC="SUB1" S IBSTR=$$SUB1(IBFRM)
    65         I IBREC="SUB2" S IBSTR=$$SUB2(IBFRM)
    66         I IBREC="OP7" S IBSTR=$$OP7(IBFRM)
    67         I IBREC="OP3" S IBSTR=$$OP3(IBFRM)
    68         I IBREC="OP6" S IBSTR=$$OP6(IBFRM)
    69         Q:$G(IBSTR)="" 1  ;if "" always return 1
    70         Q IBSTR[("^"_IBVAL_"^")
    71         ;
    72         ;IBFRM 0-both, 1=UB,2=1500
    73 OPR2(IBFRM)     ;
    74         Q:IBFRM=1 "^0B^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^SY^X5^"
    75         Q:IBFRM=2 "^0B^1B^1C^1D^1G^1H^EI^G2^LU^N5^SY^X5^"
    76         Q ""
    77         ;
    78         ;IBFRM 0-both, 1=UB,2=1500
    79 OP1(IBFRM)      ;
    80         Q:IBFRM=1 "^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^"
    81         Q:IBFRM=2 "^1B^1C^1D^EI^G2^LU^N5^"
    82         Q ""
    83         ;
    84         ;IBFRM 0-both, 1=UB,2=1500
    85 OPR3(IBFRM)     ;
    86         Q:IBFRM=1 "^0B^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^SY^X5^"
    87         Q ""
    88         ;
    89         ;IBFRM 0-both, 1=UB,2=1500
    90 OP2(IBFRM)      ;
    91         Q:IBFRM=1 "^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^"
    92         Q ""
    93         ;
    94         ;IBFRM 0-both, 1=UB,2=1500
    95 SUB1(IBFRM)     ;
    96         Q:IBFRM=1 "^0B^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^SY^X5^"
    97         Q:IBFRM=2 "^0B^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^U3^SY^X5^"
    98         Q ""
    99         ;
    100         ;IBFRM 0-both, 1=UB,2=1500
    101 OPR4(IBFRM)     ;
    102         Q:IBFRM=1 "^0B^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^SY^X5^"
    103         Q ""
    104         ;
    105         ;IBFRM 0-both, 1=UB,2=1500
    106 OP9(IBFRM)      ;
    107         Q:IBFRM=1 "^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^"
    108         Q ""
    109         ;
    110         ;IBFRM 0-both, 1=UB,2=1500
    111 SUB2(IBFRM)     ;
    112         Q:IBFRM=1 "^0B^1A^1B^1C^1G^1H^1J^EI^FH^G2^G5^LU^N5^X5^TJ^B3^BQ^SY^U3^"
    113         Q:IBFRM=2 "^0B^X4^1A^1B^1C^1G^1H^G2^LU^X5^TJ^B3^BQ^SY^U3^"
    114         Q ""
    115         ;
    116         ;IBFRM 0-both, 1=UB,2=1500
    117 OP3(IBFRM)      ;
    118         Q:IBFRM=1 "^1B^1C^EI^G2^LU^N5^"
    119         Q ""
    120         ;
    121         ;IBFRM 0-both, 1=UB,2=1500
    122 OPR5(IBFRM)     ;
    123         Q:IBFRM=2 "^0B^1B^1C^1D^1G^1H^EI^G2^LU^N5^SY^X5^"
    124         Q ""
    125         ;
    126         ;IBFRM 0-both, 1=UB,2=1500
    127 OPR8(IBFRM)     ;
    128         Q:IBFRM=2 "^0B^1B^1C^1D^1G^1H^EI^G2^LU^N5^SY^X5^"
    129         Q ""
    130         ;
    131         ;IBFRM 0-both, 1=UB,2=1500
    132 OP4(IBFRM)      ;
    133         Q:IBFRM=2 "^1B^1C^1D^EI^G2^LU^N5^"
    134         Q ""
    135         ;
    136         ;IBFRM 0-both, 1=UB,2=1500
    137 OP8(IBFRM)      ;
    138         Q:IBFRM=2 "^1B^1C^1D^EI^G2^N5^"
    139         Q ""
    140         ;
    141         ;IBFRM 0-both, 1=UB,2=1500
    142 OP6(IBFRM)      ;
    143         Q:IBFRM=2 "^1A^1B^1C^G2^LU^N5^"
    144         Q ""
    145         ;
    146         ;IBFRM 0-both, 1=UB,2=1500
    147 OP7(IBFRM)      ;
    148         Q:IBFRM=2 "^1A^1B^1C^G2^LU^N5^"
    149         Q ""
    150         ;
    151         ;check qualifier for PRV1
    152         ;IBFRM 0-both, 1=UB,2=1500
    153         ;IBVAL - value to check
    154 CHCKPRV1(IBFRM,IBVAL)   ;
    155         I IBFRM=0 Q:$$CHPRV1(1,IBVAL) 1  Q $$CHPRV1(2,IBVAL)
    156         Q $$CHPRV1(IBFRM,IBVAL)
    157         ;IBFRM 0-both, 1=UB,2=1500
    158 CHPRV1(IBFRM,IBVAL)     ;
    159         N IBSTR S IBSTR=""
    160         S IBSTR=$$PRV1(IBFRM)
    161         Q:IBSTR="" 1
    162         Q IBSTR[("^"_IBVAL_"^")
    163         ;
    164 PRV1(IBFRM)     ;
    165         Q:IBFRM=1 "^1A^1C^1D^1G^1H^1J^B3^BQ^EI^FH^G2^G5^LU^SY^X5^"
    166         Q:IBFRM=2 "^1B^1C^1D^1G^1H^1J^B3^BQ^EI^FH^G2^G5^LU^U3^SY^X5^"
    167         Q ""
    168         ;
    169 PTSELF  ;This tag is for the CI2 segment. If the IBXSAVE("IADR") is empty
    170         ;check to see if the relationship to pt is 18 (self) if so pull info
    171         ;from PT1 calls
    172         ;See if relationship to insured is 18 if not or if "" quit
    173         N IBZ
    174         D F^IBCEF("N-ALL INSURED PT RELATION","IBZ",,IBXIEN)
    175         S IBZ=$G(IBZ(+$$COBN^IBCEF(IBXIEN)))
    176         S IBZ=$$PRELCNV^IBCNSP1(IBZ,1)
    177         I IBZ'="18" S IBXDATA="" Q
    178         N IBZ D F^IBCEF("N-PATIENT STREET ADDRESS 1-3","IBZ",,IBXIEN)
    179         S IBXDATA="18"
    180         Q
    181         ;
    182 NOPUNCT(X,SPACE,EXC)    ; Strip punctuation from data in X
    183         ; SPACE = flag if 1 strip SPACES
    184         ; EXC = list of punct not to strip
    185         ;
    186         N PUNCT,Z
    187         S PUNCT=".,-+(){}[]\/><:;?|=_*&%$#@!~`^'"""
    188         I $G(SPACE) S PUNCT=PUNCT_" "
    189         I $G(EXC)'="" S PUNCT=$TR(PUNCT,EXC)
    190         N L S L=""
    191         F  S L=$O(X(L)) Q:L=""  D
    192         . S X(L)=$TR(X(L),PUNCT)
    193         I $G(X)'="" D
    194         . S X=$TR(X,PUNCT)
    195         Q
    196         ;
    197 PROVID(IBXIEN)  ;This modified version of prov id call is to acquire the SSN
    198         ;first, if the ssn is not available then we need to get the tax id.
    199         ;we also need to provide the modifier for which value it is
    200         Q:+$G(IBXIEN)=0 ""
    201         S IBXSAVE("ID")=""
    202         S IBXSAVE=""
    203         S IBXSAVE=$$PROVSSN^IBCEF7(IBXIEN)
    204         N I
    205         F I=1:1:9 D
    206         . I $P(IBXSAVE,"^",I)]"" S $P(IBXSAVE("ID"),U,I)="34"
    207         ;If no ibxdata go look in 355.97 for 24
    208         N IBRETVAL S IBRETVAL=""
    209         N IBPTR,IBFT
    210         F IBFT=1:1:9 D
    211         . Q:$P(IBXSAVE,U,IBFT)]""
    212         . S IBPTR=$$PROVPTR^IBCEF7(IBXIEN,IBFT)
    213         . S $P(IBRETVAL,"^",IBFT)=$$TAX3559(IBPTR)
    214         . I $P(IBRETVAL,U,IBFT)]"" D
    215         . . S $P(IBXSAVE,U,IBFT)=$P(IBRETVAL,U,IBFT)
    216         . . S $P(IBXSAVE("ID"),U,IBFT)="24"
    217         Q IBXSAVE
    218         ;
    219 TAX3559(IBPROV) ;
    220         I $P(IBPROV,";",2)'["IBA(355.9" Q ""
    221         N IB2,IB3559,IBIDTYP,IBID,IBQFL
    222         S (IB3559,IBQFL)=0
    223         S IBID=""
    224         Q:+$G(IBPROV)=0 ""
    225         F IB2=1:1 S IB3559=$O(^IBA(355.9,"B",IBPROV,IB3559)) Q:IB3559=""!IBQFL  D
    226         . S IBIDTYP=+$P($G(^IBA(355.9,IB3559,0)),"^",6) ;provider ID type, ptr to #355.97
    227         . S IBIDTYP=$P($G(^IBE(355.97,IBIDTYP,0)),"^",3)
    228         . S:IBIDTYP="EI" IBID=$P($G(^IBA(355.9,IB3559,0)),"^",7),IBQFL=1
    229         ; if nothing found yet, look in file 355.93 for Facility Default ID
    230         I IBID="",IBPROV["IBA(355.93" D
    231         .N IB0,IBFID,IBQ
    232         .S IB0=$G(^IBA(355.93,+IBPROV,0)) Q:IB0=""!($P(IB0,U,2)'=1)  ; not a facility - bail out
    233         .S IBFID=$P(IB0,U,9) Q:IBFID=""  ; no default id on file - bail out
    234         .S IBQ=$P(IB0,U,13) I +IBQ>0,$P($G(^IBE(355.97,IBQ,0)),U,3)=24 S IBID=IBFID
    235         .Q
    236         Q $$NOPUNCT^IBCEF(IBID)
    237         ;
    238         ;IBFULL-full name
    239         ;IBEL - Name element : "FAMILY","GIVEN","MIDDLE","SUFFIX"
    240         ;
    241 SSN200(IBPTR)     ;
    242         I $P(IBPTR,";",2)'="VA(200," Q ""
    243         Q $$NOPUNCT^IBCEF($$GET1^DIQ(200,+$P(IBPTR,";")_",",9))
    244         ;
    245         ;Input:
    246         ; IBIEN399 - ien in #399
    247         ;Output:
    248         ; returns a string with "^" delimiters that contains SSNs (if any)
    249         ; in the position that equal to FUNCTION number
    250         ; i.e. if RENDERING function # is 3 then SSN will be
    251         ; in $P(return value,"^",3), etc.
    252         ;
    253 SSN3559(IBPROV) ;
    254         N IB2,IB3559,IBIDTYP,IBID,IBQFL
    255         S (IB3559,IBQFL)=0
    256         S IBID=""
    257         Q:+$G(IBPROV)=0 ""
    258         F IB2=1:1 S IB3559=$O(^IBA(355.9,"B",IBPROV,IB3559)) Q:IB3559=""!IBQFL  D
    259         . S IBIDTYP=+$P($G(^IBA(355.9,IB3559,0)),"^",6)
    260         . S IBIDTYP=$P($G(^IBE(355.97,IBIDTYP,0)),"^",3)
    261         . S:IBIDTYP="SY" IBID=$P($G(^IBA(355.9,IB3559,0)),"^",7),IBQFL=1
    262         Q $$NOPUNCT^IBCEF(IBID)
    263         ;
    264         ;IBIDTYP-provider ID type, ptr to #355.97
    265         ;IBFULL-full name
    266         ;IBEL - Name element : "FAMILY","GIVEN","MIDDLE","SUFFIX"
    267         ;
    268 PRV1FMT(P)      ;FORMAT CODE FOR PRV1 SEGMENT THAT WON'T FIT ON LINE
    269         K IBXDATA
    270         S:'$D(IBXSAVE("BIL-PROV-SEC")) IBXSAVE("BIL-PROV-SEC")=$$PRV1^IBCEF7(IBXIEN)
    271         S IBXDATA=$P($G(IBXSAVE("BIL-PROV-SEC")),"^",P)
    272         I $G(IBXDATA)'="" S IBXDATA=$$NOPUNCT^IBCEF(IBXDATA,1)
    273         Q
    274         ;
     1IBCEF73 ;WOIFO/SS - FORMATTER AND EXTRACTOR SPECIFIC BILL FUNCTIONS ;8/6/03 10:56am
     2 ;;2.0;INTEGRATED BILLING;**232,320,358,349**;21-MAR-94;Build 46
     3 ;;Per VHA Directive 2004-038, this routine should not be modified.
     4 ;
     5 ;check qualifier
     6 ;IBFRM 0-both, 1=UB,2=1500
     7 ;IBPROV - function in #399 (1-referring, 2-operating,etc)
     8 ;IBTYPE - "C"-current insurance, "O"-other insurance
     9 ;IBVAL - value to check
     10CHCKSEC(IBFRM,IBPROV,IBTYPE,IBVAL) ;
     11 I IBFRM=0 Q:$$CHSEC(1,IBPROV,IBTYPE,IBVAL) 1  Q $$CHSEC(2,IBPROV,IBTYPE,IBVAL)
     12 Q $$CHSEC(IBFRM,IBPROV,IBTYPE,IBVAL)
     13 ;
     14CHSEC(IBFRM,IBPROV,IBTYPE,IBVAL) ;
     15 N IBSTR S IBSTR=""
     16 ;referring
     17 I IBPROV=1 S IBSTR=$S(IBTYPE="C":$$OPR5(IBFRM),IBTYPE="O":$$OP4(IBFRM),1:"")
     18 ;operating
     19 I IBPROV=2 S IBSTR=$S(IBTYPE="C":$$OPR3(IBFRM),IBTYPE="O":$$OP2(IBFRM),1:"")
     20 ;rendering
     21 I IBPROV=3 S IBSTR=$S(IBTYPE="C":$$OPR2(IBFRM),IBTYPE="O":$$OP1(IBFRM),1:"")
     22 ;attending
     23 I IBPROV=4 S IBSTR=$S(IBTYPE="C":$$OPR2(IBFRM),IBTYPE="O":$$OP1(IBFRM),1:"")
     24 ;supervising
     25 I IBPROV=5 S IBSTR=$S(IBTYPE="C":$$OPR8(IBFRM),IBTYPE="O":$$OP8(IBFRM),1:"")
     26 ;other
     27 I IBPROV=9 S IBSTR=$S(IBTYPE="C":$$OPR4(IBFRM),IBTYPE="O":$$OP9(IBFRM),1:"")
     28 Q:IBPROV=0!(IBSTR="") 1  ;if "" or facility id always return 1
     29 Q IBSTR[("^"_IBVAL_"^")
     30 ;
     31 ;Filter invalid qualifier entries for records SUB1,SUB2,OP6,OP7,OP3
     32 ; Rebuild the IBXSAVE("PROVINF" or IBXSAVE("PROVINF_FAC" array with
     33 ;  only ids that have valid qualifiers
     34 ;IBFRM 0-both, 1=UB,2=1500
     35 ;IBREC record ID whose ids are being filtered (SUB1,SUB2,etc)
     36 ;IBFAC - 1 if facility check, 0 if attending/rendering check
     37 ;IBTYPE - "C"-current insurance, "O"-other insurance
     38 ;IBXSAVE - the array of provider ids extracted, returned filtered -
     39 ;   passed by reference
     40CHCKSUB(IBFRM,IBREC,IBFAC,IBTYPE,IBXSAVE) ;
     41 N Z,Z0,Z1,Z2,CT,IBSAVE
     42 S Z="PROVINF"_$P("^_FAC",U,$G(IBFAC)+1)
     43 I '$G(IBXSAVE(Z,IBXIEN)) D
     44 . D F^IBCEF("N-ALL "_$S($G(IBFAC):"OUTSIDE FAC PROVIDER INF",1:"CUR/OTH PROVIDER INFO"))
     45 M IBSAVE(Z,IBXIEN,IBTYPE)=IBXSAVE(Z,IBXIEN,IBTYPE) K IBXSAVE(Z,IBXIEN,IBTYPE)
     46 S Z0=0 F  S Z0=$O(IBSAVE(Z,IBXIEN,IBTYPE,Z0)) Q:'Z0  S Z1="" F  S Z1=$O(IBSAVE(Z,IBXIEN,IBTYPE,Z0,Z1)) Q:Z1=""  S (Z2,CT)=0 F  S Z2=$O(IBSAVE(Z,IBXIEN,IBTYPE,Z0,Z1,Z2)) Q:'Z2  D
     47 . N IBVAL
     48 . S IBVAL=$P(IBSAVE(Z,IBXIEN,IBTYPE,Z0,Z1,Z2),U,3)
     49 . I IBFRM=0 D  Q
     50 .. I $S($$CHSUB(1,IBREC,IBVAL):1,1:$$CHSUB(2,IBPROV,IBTYPE,IBVAL)) D
     51 ... S CT=CT+1,IBXSAVE(Z,IBXIEN,IBTYPE,Z0,Z1,CT)=IBSAVE(Z,IBXIEN,IBTYPE,Z0,Z1,Z2)
     52 ... I $G(IBXSAVE(Z,IBXIEN,IBTYPE,Z0))="",$G(IBSAVE(Z,IBXIEN,IBTYPE,Z0))'="" S IBXSAVE(Z,IBXIEN,IBTYPE,Z0)=IBSAVE(Z,IBXIEN,IBTYPE,Z0)
     53 . I $$CHSUB(IBFRM,IBREC,IBVAL) D
     54 .. S CT=CT+1,IBXSAVE(Z,IBXIEN,IBTYPE,Z0,Z1,CT)=IBSAVE(Z,IBXIEN,IBTYPE,Z0,Z1,Z2)
     55 .. I $G(IBXSAVE(Z,IBXIEN,IBTYPE,Z0))="",$G(IBSAVE(Z,IBXIEN,IBTYPE,Z0))'="" S IBXSAVE(Z,IBXIEN,IBTYPE,Z0)=IBSAVE(Z,IBXIEN,IBTYPE,Z0)
     56 Q
     57 ;
     58 ; Check if valid qualifier
     59 ;IBFRM 0-both, 1=UB,2=1500
     60 ;IBREC record ID whose ids are being filtered (SUB1,SUB2,etc)
     61 ;IBVAL - value to check
     62CHSUB(IBFRM,IBREC,IBVAL) ;
     63 N IBSTR
     64 I IBREC="SUB1" S IBSTR=$$SUB1(IBFRM)
     65 I IBREC="SUB2" S IBSTR=$$SUB2(IBFRM)
     66 I IBREC="OP7" S IBSTR=$$OP7(IBFRM)
     67 I IBREC="OP3" S IBSTR=$$OP3(IBFRM)
     68 I IBREC="OP6" S IBSTR=$$OP6(IBFRM)
     69 Q:$G(IBSTR)="" 1  ;if "" always return 1
     70 Q IBSTR[("^"_IBVAL_"^")
     71 ;
     72 ;IBFRM 0-both, 1=UB,2=1500
     73OPR2(IBFRM) ;
     74 Q:IBFRM=1 "^0B^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^SY^X5^"
     75 Q:IBFRM=2 "^0B^1B^1C^1D^1G^1H^EI^G2^LU^N5^SY^X5^"
     76 Q ""
     77 ;
     78 ;IBFRM 0-both, 1=UB,2=1500
     79OP1(IBFRM) ;
     80 Q:IBFRM=1 "^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^"
     81 Q:IBFRM=2 "^1B^1C^1D^EI^G2^LU^N5^"
     82 Q ""
     83 ;
     84 ;IBFRM 0-both, 1=UB,2=1500
     85OPR3(IBFRM) ;
     86 Q:IBFRM=1 "^0B^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^SY^X5^"
     87 Q ""
     88 ;
     89 ;IBFRM 0-both, 1=UB,2=1500
     90OP2(IBFRM) ;
     91 Q:IBFRM=1 "^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^"
     92 Q ""
     93 ;
     94 ;IBFRM 0-both, 1=UB,2=1500
     95SUB1(IBFRM) ;
     96 Q:IBFRM=1 "^0B^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^SY^X5^"
     97 Q:IBFRM=2 "^0B^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^U3^SY^X5^"
     98 Q ""
     99 ;
     100 ;IBFRM 0-both, 1=UB,2=1500
     101OPR4(IBFRM) ;
     102 Q:IBFRM=1 "^0B^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^SY^X5^"
     103 Q ""
     104 ;
     105 ;IBFRM 0-both, 1=UB,2=1500
     106OP9(IBFRM) ;
     107 Q:IBFRM=1 "^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^"
     108 Q ""
     109 ;
     110 ;IBFRM 0-both, 1=UB,2=1500
     111SUB2(IBFRM) ;
     112 Q:IBFRM=1 "^0B^1A^1B^1C^1G^1H^1J^EI^FH^G2^G5^LU^N5^X5^TJ^B3^BQ^SY^U3^"
     113 Q:IBFRM=2 "^0B^X4^1A^1B^1C^1G^1H^G2^LU^X5^TJ^B3^BQ^SY^U3^"
     114 Q ""
     115 ;
     116 ;IBFRM 0-both, 1=UB,2=1500
     117OP3(IBFRM) ;
     118 Q:IBFRM=1 "^1B^1C^EI^G2^LU^N5^"
     119 Q ""
     120 ;
     121 ;IBFRM 0-both, 1=UB,2=1500
     122OPR5(IBFRM) ;
     123 Q:IBFRM=2 "^0B^1B^1C^1D^1G^1H^EI^G2^LU^N5^SY^X5^"
     124 Q ""
     125 ;
     126 ;IBFRM 0-both, 1=UB,2=1500
     127OPR8(IBFRM) ;
     128 Q:IBFRM=2 "^0B^1B^1C^1D^1G^1H^EI^G2^LU^N5^SY^X5^"
     129 Q ""
     130 ;
     131 ;IBFRM 0-both, 1=UB,2=1500
     132OP4(IBFRM) ;
     133 Q:IBFRM=2 "^1B^1C^1D^EI^G2^LU^N5^"
     134 Q ""
     135 ;
     136 ;IBFRM 0-both, 1=UB,2=1500
     137OP8(IBFRM) ;
     138 Q:IBFRM=2 "^1B^1C^1D^EI^G2^N5^"
     139 Q ""
     140 ;
     141 ;IBFRM 0-both, 1=UB,2=1500
     142OP6(IBFRM) ;
     143 Q:IBFRM=2 "^1A^1B^1C^G2^LU^N5^"
     144 Q ""
     145 ;
     146 ;IBFRM 0-both, 1=UB,2=1500
     147OP7(IBFRM) ;
     148 Q:IBFRM=2 "^1A^1B^1C^G2^LU^N5^"
     149 Q ""
     150 ;
     151 ;check qualifier for PRV1
     152 ;IBFRM 0-both, 1=UB,2=1500
     153 ;IBVAL - value to check
     154CHCKPRV1(IBFRM,IBVAL) ;
     155 I IBFRM=0 Q:$$CHPRV1(1,IBVAL) 1  Q $$CHPRV1(2,IBVAL)
     156 Q $$CHPRV1(IBFRM,IBVAL)
     157 ;IBFRM 0-both, 1=UB,2=1500
     158CHPRV1(IBFRM,IBVAL) ;
     159 N IBSTR S IBSTR=""
     160 S IBSTR=$$PRV1(IBFRM)
     161 Q:IBSTR="" 1
     162 Q IBSTR[("^"_IBVAL_"^")
     163 ;
     164PRV1(IBFRM) ;
     165 Q:IBFRM=1 "^1A^1C^1D^1G^1H^1J^B3^BQ^EI^FH^G2^G5^LU^SY^X5^"
     166 Q:IBFRM=2 "^1B^1C^1D^1G^1H^1J^B3^BQ^EI^FH^G2^G5^LU^U3^SY^X5^"
     167 Q ""
     168 ;
     169PTSELF ;This tag is for the CI2 segment. If the IBXSAVE("IADR") is empty
     170 ;check to see if the relationship to pt is 18 (self) if so pull info
     171 ;from PT1 calls
     172 ;See if relationship to insured is 18 if not or if "" quit
     173 N IBZ
     174 D F^IBCEF("N-ALL INSURED PT RELATION","IBZ",,IBXIEN)
     175 S IBZ=$G(IBZ(+$$COBN^IBCEF(IBXIEN)))
     176 S IBZ=$$RELATION^IBCEFG1(IBZ)
     177 I IBZ'="18" S IBXDATA="" Q
     178 N IBZ D F^IBCEF("N-PATIENT STREET ADDRESS 1-3","IBZ",,IBXIEN)
     179 S IBXDATA="18"
     180 Q
     181 ;
     182NOPUNCT(X,SPACE,EXC) ; Strip punctuation from data in X
     183 ; SPACE = flag if 1 strip SPACES
     184 ; EXC = list of punct not to strip
     185 ;
     186 N PUNCT,Z
     187 S PUNCT=".,-+(){}[]\/><:;?|=_*&%$#@!~`^'"""
     188 I $G(SPACE) S PUNCT=PUNCT_" "
     189 I $G(EXC)'="" S PUNCT=$TR(PUNCT,EXC)
     190 N L S L=""
     191 F  S L=$O(X(L)) Q:L=""  D
     192 . S X(L)=$TR(X(L),PUNCT)
     193 I $G(X)'="" D
     194 . S X=$TR(X,PUNCT)
     195 Q
     196 ;
     197PROVID(IBXIEN) ;This modified version of prov id call is to acquire the SSN
     198 ;first, if the ssn is not available then we need to get the tax id.
     199 ;we also need to provide the modifier for which value it is
     200 Q:+$G(IBXIEN)=0 ""
     201 S IBXSAVE("ID")=""
     202 S IBXSAVE=""
     203 S IBXSAVE=$$PROVSSN^IBCEF7(IBXIEN)
     204 N I
     205 F I=1:1:9 D
     206 . I $P(IBXSAVE,"^",I)]"" S $P(IBXSAVE("ID"),U,I)="34"
     207 ;If no ibxdata go look in 355.97 for 24
     208 N IBRETVAL S IBRETVAL=""
     209 N IBPTR,IBFT
     210 F IBFT=1:1:9 D
     211 . Q:$P(IBXSAVE,U,IBFT)]""
     212 . S IBPTR=$$PROVPTR^IBCEF7(IBXIEN,IBFT)
     213 . S $P(IBRETVAL,"^",IBFT)=$$TAX3559(IBPTR)
     214 . I $P(IBRETVAL,U,IBFT)]"" D
     215 . . S $P(IBXSAVE,U,IBFT)=$P(IBRETVAL,U,IBFT)
     216 . . S $P(IBXSAVE("ID"),U,IBFT)="24"
     217 Q IBXSAVE
     218 ;
     219TAX3559(IBPROV) ;
     220 I $P(IBPROV,";",2)'["IBA(355.9" Q ""
     221 N IB2,IB3559,IBIDTYP,IBID,IBQFL
     222 S (IB3559,IBQFL)=0
     223 S IBID=""
     224 Q:+$G(IBPROV)=0 ""
     225 F IB2=1:1 S IB3559=$O(^IBA(355.9,"B",IBPROV,IB3559)) Q:IB3559=""!IBQFL  D
     226 . S IBIDTYP=+$P($G(^IBA(355.9,IB3559,0)),"^",6) ;provider ID type, ptr to #355.97
     227 . S IBIDTYP=$P($G(^IBE(355.97,IBIDTYP,0)),"^",3)
     228 . S:IBIDTYP="EI" IBID=$P($G(^IBA(355.9,IB3559,0)),"^",7),IBQFL=1
     229 Q $$NOPUNCT^IBCEF(IBID)
     230 ;
     231 ;IBFULL-full name
     232 ;IBEL - Name element : "FAMILY","GIVEN","MIDDLE","SUFFIX"
     233 ;
     234SSN200(IBPTR)   ;
     235 I $P(IBPTR,";",2)'="VA(200," Q ""
     236 Q $$NOPUNCT^IBCEF($$GET1^DIQ(200,+$P(IBPTR,";")_",",9))
     237 ;
     238 ;Input:
     239 ; IBIEN399 - ien in #399
     240 ;Output:
     241 ; returns a string with "^" delimiters that contains SSNs (if any)
     242 ; in the position that equal to FUNCTION number
     243 ; i.e. if RENDERING function # is 3 then SSN will be
     244 ; in $P(return value,"^",3), etc.
     245 ;
     246SSN3559(IBPROV) ;
     247 N IB2,IB3559,IBIDTYP,IBID,IBQFL
     248 S (IB3559,IBQFL)=0
     249 S IBID=""
     250 Q:+$G(IBPROV)=0 ""
     251 F IB2=1:1 S IB3559=$O(^IBA(355.9,"B",IBPROV,IB3559)) Q:IB3559=""!IBQFL  D
     252 . S IBIDTYP=+$P($G(^IBA(355.9,IB3559,0)),"^",6)
     253 . S IBIDTYP=$P($G(^IBE(355.97,IBIDTYP,0)),"^",3)
     254 . S:IBIDTYP="SY" IBID=$P($G(^IBA(355.9,IB3559,0)),"^",7),IBQFL=1
     255 Q $$NOPUNCT^IBCEF(IBID)
     256 ;
     257 ;IBIDTYP-provider ID type, ptr to #355.97
     258 ;IBFULL-full name
     259 ;IBEL - Name element : "FAMILY","GIVEN","MIDDLE","SUFFIX"
     260 ;
     261PRV1FMT(P) ;FORMAT CODE FOR PRV1 SEGMENT THAT WON'T FIT ON LINE
     262 K IBXDATA
     263 S:'$D(IBXSAVE("BIL-PROV-SEC")) IBXSAVE("BIL-PROV-SEC")=$$PRV1^IBCEF7(IBXIEN)
     264 S IBXDATA=$P($G(IBXSAVE("BIL-PROV-SEC")),"^",P)
     265 I $G(IBXDATA)'="" S IBXDATA=$$NOPUNCT^IBCEF(IBXDATA,1)
     266 Q
     267 ;

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF73A.m

    r613 r623  
    1 IBCEF73A        ;ALB/KJH - FORMATTER AND EXTRACTOR SPECIFIC (NPI) BILL FUNCTIONS ;30 Aug 2006  10:38 AM
    2         ;;2.0;INTEGRATED BILLING;**343,374,395,391**;21-MAR-94;Build 39
    3         ;; Per VHA Directive 10-93-142, this routine should not be modified.
    4         ;
    5 PROVNPI(IBIEN399,IBNONPI)       ;
    6         ;Retrieves NPIs from #200 or 355.93
    7         ; Input:
    8         ;       IBIEN399 - IEN of record in BILL/CLAIMS file 399
    9         ;       IBNONPI - variable to pass info on missing NPI to calling routine.  Pass by reference
    10         ; Output:
    11         ;       NPI codes for all providers
    12         ;       IBNONPI - U-delimited list of provider types with missing NPIs
    13         N IBRETVAL,IBPTR,IBFT
    14         S IBRETVAL="",IBNONPI=""
    15         F IBFT=1:1:9 D
    16         . S IBPTR=$$PROVPTR^IBCEF7(IBIEN399,IBFT)
    17         . I IBPTR S $P(IBRETVAL,"^",IBFT)=$$GETNPI(IBPTR)
    18         Q IBRETVAL
    19 GETNPI(IBPTR)   ;look for NPI in #200 or #355.93
    20         ;Input: IBPTR from 399.0222, field .02
    21         ;Output: NPI
    22         ;if in file #200
    23         N NPI
    24         S NPI=""
    25         ;if in 200 then get it from 200
    26         I $P(IBPTR,";",2)="VA(200," S NPI=$P($$NPI^XUSNPI("Individual_ID",$P(IBPTR,";")),U) S:NPI<1 NPI=""
    27         ;if in 355.93 then use 355.93
    28         I $P(IBPTR,";",2)="IBA(355.93," S NPI=$$NPIGET^IBCEP81($P(IBPTR,";"))
    29         I NPI="",$D(IBNONPI) S IBNONPI=$S(IBNONPI="":IBFT,1:IBNONPI_U_IBFT)
    30         Q NPI
    31         ;
    32 SPECTAX(IBIEN399,IBNOSPEC)      ;
    33         ;Retrieves Specialty Codes from Current Taxonomy entries for a claim from #399
    34         ; Input:
    35         ;       IBIEN399 - IEN of record in BILL/CLAIMS file 399
    36         ;       IBNOSPEC - variable to pass info on missing taxonomies to calling routine.  Pass by reference
    37         ; Output:
    38         ;       Taxonomy Specialty Codes for all providers
    39         ;       IBNOSPEC - U-delimited list of provider types with missing Taxonomy Specialty codes
    40         N IBRETVAL,IBN,IBFT,IBSPEC,SPEC
    41         S IBRETVAL="",IBNOSPEC=""
    42         I $G(IBIEN399)="" Q ""
    43         F IBFT=1:1:9 D
    44         . S IBN=$O(^DGCR(399,IBIEN399,"PRV","B",IBFT,0))
    45         . I +IBN=0 Q
    46         . S IBSPEC=$P($G(^DGCR(399,IBIEN399,"PRV",+IBN,0)),"^",15)
    47         . S SPEC=$$GET1^DIQ(8932.1,IBSPEC,"SPECIALTY CODE")
    48         . S $P(IBRETVAL,"^",IBFT)=SPEC
    49         . I SPEC="",$D(IBNOSPEC) S IBNOSPEC=$S(IBNOSPEC="":IBFT,1:IBNOSPEC_U_IBFT)
    50         Q IBRETVAL
    51         ;
    52 PROVTAX(IBIEN399,IBNOTAX)       ;
    53         ;Retrieves Current Taxonomy entries for a claim from #399
    54         ; Input:
    55         ;       IBIEN399 - IEN of record in BILL/CLAIMS file 399
    56         ;       IBNOTAX - variable to pass info on missing taxonomies to calling routine.  Pass by reference
    57         ; Output:
    58         ;       Taxonomy X12 codes for all providers
    59         ;       IBNOTAX - U-delimited list of provider types with missing Taxonomy X12 codes
    60         N IBRETVAL,IBN,IBFT,IBTAX,TAX
    61         S IBRETVAL="",IBNOTAX=""
    62         I $G(IBIEN399)="" Q ""
    63         F IBFT=1:1:9 D
    64         . S IBN=$O(^DGCR(399,IBIEN399,"PRV","B",IBFT,0))
    65         . I +IBN=0 Q
    66         . S IBTAX=$P($G(^DGCR(399,IBIEN399,"PRV",+IBN,0)),"^",15)
    67         . S TAX=$$GET1^DIQ(8932.1,IBTAX,"X12 CODE")
    68         . S $P(IBRETVAL,"^",IBFT)=TAX
    69         . I TAX="",$D(IBNOTAX) S IBNOTAX=$S(IBNOTAX="":IBFT,1:IBNOTAX_U_IBFT)
    70         Q IBRETVAL
    71 GETTAX(IBPTR)   ;look for Taxonomy in #200 or #355.93
    72         ;Input: IBPTR from 399.0222, field .02
    73         ;Output: Taxonomy X12 code_"^"_IEN
    74         N TAX
    75         S TAX="^"
    76         ;if in 200 then get it from 200
    77         I $P(IBPTR,";",2)="VA(200," S TAX=$$TAXIND^XUSTAX($P(IBPTR,";"))
    78         ;if in 355.93 then use 355.93
    79         I $P(IBPTR,";",2)="IBA(355.93," S TAX=$$TAXGET^IBCEP81($P(IBPTR,";"))
    80         Q TAX
    81         ;
    82 ORGNPI(IBIEN399,IBNONPI)        ; Extract NPIs for organizations on this claim
    83         ; Input
    84         ;       IBIEN399 - Claim IEN in file 399
    85         ;       IBNONPI - Variable to pass info on missing NPI back to calling routine.  Pass by reference.
    86         ; Output - NPI codes for facilities
    87         ;        Piece 1) Division (Responsible Institution) NPI code
    88         ;        Piece 2) Non-VA Service Facility NPI code
    89         ;        Piece 3) Billing Provider NPI code (main VA division)
    90         N IBRETVAL,IBORG,IBEVDT,IBDIV,NPI
    91         S IBNONPI=""
    92         I $G(IBIEN399)="" Q ""
    93         S IBRETVAL=""
    94         S IBEVDT=$$GET1^DIQ(399,IBIEN399_",",.03,"I")
    95         I IBEVDT="" S IBEVDT=DT
    96         S IBDIV=$$GET1^DIQ(399,IBIEN399_",",.22,"I")
    97         I IBDIV="" S IBDIV=$$PRIM^VASITE(IBEVDT)
    98         S IBORG=$P($$SITE^VASITE(IBEVDT,IBDIV),U),NPI=""
    99         I IBORG S NPI=$P($$NPI^XUSNPI("Organization_ID",IBORG),U) S:NPI>0 $P(IBRETVAL,U)=NPI
    100         I NPI<1,$D(IBNONPI) S IBNONPI=1
    101         S IBORG=$$GET1^DIQ(399,IBIEN399_",",232,"I")
    102         I IBORG S NPI=$$NPIGET^IBCEP81(IBORG),$P(IBRETVAL,U,2)=NPI I 'NPI,$D(IBNONPI) S IBNONPI=$S(IBNONPI="":2,1:IBNONPI_U_2)
    103         S IBORG=$P($$SITE^VASITE,U),NPI=""
    104         I IBORG S NPI=$P($$NPI^XUSNPI("Organization_ID",IBORG),U) S:NPI>0 $P(IBRETVAL,U,3)=NPI
    105         I NPI<1,$D(IBNONPI) S IBNONPI=$S(IBNONPI="":3,1:IBNONPI_U_3)
    106         I $$ISRX^IBCEF1(IBIEN399) S IBORG=$$RXSITE(IBIEN399) I IBORG S NPI=$P($$NPI^XUSNPI("Organization_ID",IBORG),U) S:NPI>0 $P(IBRETVAL,U,3)=NPI
    107         Q IBRETVAL
    108         ;
    109 ORGTAX(IBIEN399,IBNOTAX)        ; Extract Taxonomies for organizations on this claim
    110         ; Input
    111         ;       IBIEN399 - Claim IEN in file 399
    112         ;       IBNOTAX - Variable to pass info on missing taxonomies back to calling routine.  Pass by reference.
    113         ; Output - Taxonomy X12 codes for facilities
    114         ;        Piece 1) Division (Responsible Institution) Taxonomy X12 code
    115         ;        Piece 2) Non-VA Service Facility Taxonomy X12 code
    116         ;        Piece 3) Billing Provider Taxonomy X12 code (main VA division)
    117         N IBRETVAL,IBTAX,TAX
    118         S IBTAX=$$GET1^DIQ(399,IBIEN399_",",243,"I")
    119         S TAX=$$GET1^DIQ(8932.1,IBTAX,"X12 CODE")
    120         S $P(IBRETVAL,U)=TAX
    121         I '$L(TAX),$D(IBNOTAX) S IBNOTAX=1
    122         S IBTAX=$$GET1^DIQ(399,IBIEN399_",",244,"I")
    123         S TAX=$$GET1^DIQ(8932.1,IBTAX,"X12 CODE")
    124         S $P(IBRETVAL,U,2)=TAX
    125         I '$L(TAX),$$GET1^DIQ(399,IBIEN399_",",232,"I"),$D(IBNOTAX) S IBNOTAX=$S(IBNOTAX="":2,1:IBNOTAX_U_2)
    126         S IBORG=$P($$SITE^VASITE,U)
    127         S TAX=$P($$TAXORG^XUSTAX(IBORG),U)
    128         S $P(IBRETVAL,U,3)=TAX
    129         I '$L(TAX),$D(IBNOTAX) S IBNOTAX=$S(IBNOTAX="":3,1:IBNOTAX_U_3)
    130         Q IBRETVAL
    131         ;
    132 RXSITE(IBIEN399,IBLIST) ; returns prescription organization (file 4) pointer
    133         ; for the given bill.  If IBLIST passed by reference, then a list of
    134         ; the possible organizations are returned for a bill, since a bill may
    135         ; have more than one prescription.  If more than one rx on the bill, the
    136         ; $$ return is the pointer of the last prescription found.
    137         ; IBLIST(rx ien,fill date)=ORGINATION (file 4 pointer)
    138         ;
    139         N IBX,IBDATA,IBORG,IBRX,IBDT,IBY,IBRXN,DFN
    140         K ^TMP($J,"IBCEF73A")
    141         S IBORG=0,DFN=$P($G(^DGCR(399,IBIEN399,0)),"^",2),IBLIST="IBCEF73A"
    142         S IBRXN=0 F  S IBRXN=$O(^IBA(362.4,"AIFN"_IBIEN399,IBRXN)) Q:'IBRXN  S IBX=0 F  S IBX=$O(^IBA(362.4,"AIFN"_IBIEN399,IBRXN,IBX)) Q:'IBX  D
    143         . S IBDATA=$G(^IBA(362.4,IBX,0))
    144         . S IBRX=$P(IBDATA,"^",5),IBDT=$P(IBDATA,"^",3) Q:'IBRX!('IBDT)
    145         . D RX^PSO52API(DFN,IBLIST,IBRX,,"0,2,R")
    146         . I IBDT=+$G(^TMP($J,"IBCEF73A",DFN,IBRX,22)) S (IBORG,IBLIST(IBRX,IBDT))=$$PSONPI(+$G(^TMP($J,"IBCEF73A",DFN,IBRX,20))) Q
    147         . S IBY=0 F  S IBY=$O(^TMP($J,"IBCEF73A",DFN,IBRX,"RF",IBY)) Q:'IBY  I IBDT=+$G(^TMP($J,"IBCEF73A",DFN,IBRX,"RF",IBY,.01)) S (IBORG,IBLIST(IBRX,IBDT))=$$PSONPI(+$G(^TMP($J,"IBCEF73A",DFN,IBRX,"RF",IBY,8))) Q
    148         K ^TMP($J,"IBCEF73A")
    149         Q IBORG
    150         ;
    151 PSONPI(IB59IEN) ; returns institution ien for a file 59 ien
    152         N IB4IEN
    153         K ^TMP($J,"IBCEF59")
    154         D PSS^PSO59(IB59IEN,,"IBCEF59")
    155         S IB4IEN=+$G(^TMP($J,"IBCEF59",IB59IEN,101))
    156         K ^TMP($J,"IBCEF59")
    157         Q IB4IEN
     1IBCEF73A ;ALB/KJH - FORMATTER AND EXTRACTOR SPECIFIC (NPI) BILL FUNCTIONS ; 30 Aug 2006  10:38 AM
     2 ;;2.0;INTEGRATED BILLING;**343,374**;21-MAR-94;Build 16
     3 ;; Per VHA Directive 10-93-142, this routine should not be modified.
     4 ;
     5PROVNPI(IBIEN399,IBNONPI) ;
     6 ;Retrieves NPIs from #200 or 355.93
     7 ; Input:
     8 ;       IBIEN399 - IEN of record in BILL/CLAIMS file 399
     9 ;       IBNONPI - variable to pass info on missing NPI to calling routine.  Pass by reference
     10 ; Output:
     11 ;       NPI codes for all providers
     12 ;       IBNONPI - U-delimited list of provider types with missing NPIs
     13 N IBRETVAL,IBPTR,IBFT
     14 S IBRETVAL="",IBNONPI=""
     15 F IBFT=1:1:9 D
     16 . S IBPTR=$$PROVPTR^IBCEF7(IBIEN399,IBFT)
     17 . I IBPTR S $P(IBRETVAL,"^",IBFT)=$$GETNPI(IBPTR)
     18 Q IBRETVAL
     19GETNPI(IBPTR) ;look for NPI in #200 or #355.93
     20 ;Input: IBPTR from 399.0222, field .02
     21 ;Output: NPI
     22 ;if in file #200
     23 N NPI
     24 S NPI=""
     25 ;if in 200 then get it from 200
     26 I $P(IBPTR,";",2)="VA(200," S NPI=$P($$NPI^XUSNPI("Individual_ID",$P(IBPTR,";")),U) S:NPI=-1 NPI=""
     27 ;if in 355.93 then use 355.93
     28 I $P(IBPTR,";",2)="IBA(355.93," S NPI=$$NPIGET^IBCEP81($P(IBPTR,";"))
     29 I NPI="",$D(IBNONPI) S IBNONPI=$S(IBNONPI="":IBFT,1:IBNONPI_U_IBFT)
     30 Q NPI
     31 ;
     32SPECTAX(IBIEN399,IBNOSPEC) ;
     33 ;Retrieves Specialty Codes from Current Taxonomy entries for a claim from #399
     34 ; Input:
     35 ;       IBIEN399 - IEN of record in BILL/CLAIMS file 399
     36 ;       IBNOSPEC - variable to pass info on missing taxonomies to calling routine.  Pass by reference
     37 ; Output:
     38 ;       Taxonomy Specialty Codes for all providers
     39 ;       IBNOSPEC - U-delimited list of provider types with missing Taxonomy Specialty codes
     40 N IBRETVAL,IBN,IBFT,IBSPEC,SPEC
     41 S IBRETVAL="",IBNOSPEC=""
     42 I $G(IBIEN399)="" Q ""
     43 F IBFT=1:1:9 D
     44 . S IBN=$O(^DGCR(399,IBIEN399,"PRV","B",IBFT,0))
     45 . I +IBN=0 Q
     46 . S IBSPEC=$P($G(^DGCR(399,IBIEN399,"PRV",+IBN,0)),"^",15)
     47 . S SPEC=$$GET1^DIQ(8932.1,IBSPEC,"SPECIALTY CODE")
     48 . S $P(IBRETVAL,"^",IBFT)=SPEC
     49 . I SPEC="",$D(IBNOSPEC) S IBNOSPEC=$S(IBNOSPEC="":IBFT,1:IBNOSPEC_U_IBFT)
     50 Q IBRETVAL
     51 ;
     52PROVTAX(IBIEN399,IBNOTAX) ;
     53 ;Retrieves Current Taxonomy entries for a claim from #399
     54 ; Input:
     55 ;       IBIEN399 - IEN of record in BILL/CLAIMS file 399
     56 ;       IBNOTAX - variable to pass info on missing taxonomies to calling routine.  Pass by reference
     57 ; Output:
     58 ;       Taxonomy X12 codes for all providers
     59 ;       IBNOTAX - U-delimited list of provider types with missing Taxonomy X12 codes
     60 N IBRETVAL,IBN,IBFT,IBTAX,TAX
     61 S IBRETVAL="",IBNOTAX=""
     62 I $G(IBIEN399)="" Q ""
     63 F IBFT=1:1:9 D
     64 . S IBN=$O(^DGCR(399,IBIEN399,"PRV","B",IBFT,0))
     65 . I +IBN=0 Q
     66 . S IBTAX=$P($G(^DGCR(399,IBIEN399,"PRV",+IBN,0)),"^",15)
     67 . S TAX=$$GET1^DIQ(8932.1,IBTAX,"X12 CODE")
     68 . S $P(IBRETVAL,"^",IBFT)=TAX
     69 . I TAX="",$D(IBNOTAX) S IBNOTAX=$S(IBNOTAX="":IBFT,1:IBNOTAX_U_IBFT)
     70 Q IBRETVAL
     71GETTAX(IBPTR) ;look for Taxonomy in #200 or #355.93
     72 ;Input: IBPTR from 399.0222, field .02
     73 ;Output: Taxonomy X12 code_"^"_IEN
     74 N TAX
     75 S TAX="^"
     76 ;if in 200 then get it from 200
     77 I $P(IBPTR,";",2)="VA(200," S TAX=$$TAXIND^XUSTAX($P(IBPTR,";"))
     78 ;if in 355.93 then use 355.93
     79 I $P(IBPTR,";",2)="IBA(355.93," S TAX=$$TAXGET^IBCEP81($P(IBPTR,";"))
     80 Q TAX
     81 ;
     82ORGNPI(IBIEN399,IBNONPI) ; Extract NPIs for organizations on this claim
     83 ; Input
     84 ;       IBIEN399 - Claim IEN in file 399
     85 ;       IBNONPI - Variable to pass info on missing NPI back to calling routine.  Pass by reference.
     86 ; Output - NPI codes for facilities
     87 ;        Piece 1) Division (Responsible Institution) NPI code
     88 ;        Piece 2) Non-VA Service Facility NPI code
     89 ;        Piece 3) Billing Provider NPI code (main VA division)
     90 N IBRETVAL,IBORG,IBEVDT,IBDIV,NPI
     91 S IBNONPI=""
     92 I $G(IBIEN399)="" Q ""
     93 S IBRETVAL=""
     94 S IBEVDT=$$GET1^DIQ(399,IBIEN399_",",.03,"I")
     95 I IBEVDT="" S IBEVDT=DT
     96 S IBDIV=$$GET1^DIQ(399,IBIEN399_",",.22,"I")
     97 I IBDIV="" S IBDIV=$$PRIM^VASITE(IBEVDT)
     98 S IBORG=$P($$SITE^VASITE(IBEVDT,IBDIV),U),NPI=""
     99 I IBORG S NPI=$P($$NPI^XUSNPI("Organization_ID",IBORG),U) S:NPI'=-1 $P(IBRETVAL,U)=NPI
     100 I NPI<1,$D(IBNONPI) S IBNONPI=1
     101 S IBORG=$$GET1^DIQ(399,IBIEN399_",",232,"I")
     102 I IBORG S NPI=$$NPIGET^IBCEP81(IBORG),$P(IBRETVAL,U,2)=NPI I 'NPI,$D(IBNONPI) S IBNONPI=$S(IBNONPI="":2,1:IBNONPI_U_2)
     103 S IBORG=$P($$SITE^VASITE,U),NPI=""
     104 I IBORG S NPI=$P($$NPI^XUSNPI("Organization_ID",IBORG),U) S:NPI'=-1 $P(IBRETVAL,U,3)=NPI
     105 I NPI<1,$D(IBNONPI) S IBNONPI=$S(IBNONPI="":3,1:IBNONPI_U_3)
     106 Q IBRETVAL
     107 ;
     108ORGTAX(IBIEN399,IBNOTAX) ; Extract Taxonomies for organizations on this claim
     109 ; Input
     110 ;       IBIEN399 - Claim IEN in file 399
     111 ;       IBNOTAX - Variable to pass info on missing taxonomies back to calling routine.  Pass by reference.
     112 ; Output - Taxonomy X12 codes for facilities
     113 ;        Piece 1) Division (Responsible Institution) Taxonomy X12 code
     114 ;        Piece 2) Non-VA Service Facility Taxonomy X12 code
     115 ;        Piece 3) Billing Provider Taxonomy X12 code (main VA division)
     116 N IBRETVAL,IBTAX,TAX
     117 S IBTAX=$$GET1^DIQ(399,IBIEN399_",",243,"I")
     118 S TAX=$$GET1^DIQ(8932.1,IBTAX,"X12 CODE")
     119 S $P(IBRETVAL,U)=TAX
     120 I '$L(TAX),$D(IBNOTAX) S IBNOTAX=1
     121 S IBTAX=$$GET1^DIQ(399,IBIEN399_",",244,"I")
     122 S TAX=$$GET1^DIQ(8932.1,IBTAX,"X12 CODE")
     123 S $P(IBRETVAL,U,2)=TAX
     124 I '$L(TAX),$$GET1^DIQ(399,IBIEN399_",",232,"I"),$D(IBNOTAX) S IBNOTAX=$S(IBNOTAX="":2,1:IBNOTAX_U_2)
     125 S IBORG=$P($$SITE^VASITE,U)
     126 S TAX=$P($$TAXORG^XUSTAX(IBORG),U)
     127 S $P(IBRETVAL,U,3)=TAX
     128 I '$L(TAX),$D(IBNOTAX) S IBNOTAX=$S(IBNOTAX="":3,1:IBNOTAX_U_3)
     129 Q IBRETVAL

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF74A.m

    r613 r623  
    1 IBCEF74A        ;ALB/ESG - Provider ID maint ?ID continuation ;7 Mar 2006
    2         ;;2.0;INTEGRATED BILLING;**320,343,349,395**;21-MAR-94;Build 3
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5         Q
    6         ;
    7 EN(IBIFN,IBQUIT)        ; Display billing provider and service provider IDs as part
    8         ; of the ?ID display/help in the billing screens.
    9         ; Called from DISPID^IBCEF74.
    10         NEW IBID,IBX,Z,ZI,ZN,SEQ,PSIN,DATA,QUALNM,IDNUM,FACNAME,IBZ,IBXIEN,IBSSFI,ORGNPI
    11         ;
    12         D ALLIDS^IBCEF75(IBIFN,.IBID)
    13         ;
    14         ; Re-sort array by insurance sequence (P/S/T)
    15         K IBX
    16         F Z="BILLING PRV","LAB/FAC" F ZI="C","O" S ZN=0 F  S ZN=$O(IBID(Z,IBIFN,ZI,ZN)) Q:'ZN  D
    17         . S SEQ=$P($G(IBID(Z,IBIFN,ZI,ZN)),U,1) Q:SEQ=""
    18         . S IBX(Z,SEQ,ZI,ZN)=""
    19         . Q
    20         ;
    21         ; Display billing provider secondary ID's (current ins only)
    22         I ($Y+5)>IOSL S IBQUIT=$$NOMORE^IBCEF74() I IBQUIT G EX
    23         S Z="BILLING PRV"
    24         ; PRXM/KJH - Removed "I $D(IBX(Z))" from next line. Caused header to not display even though there would be a "None Found' message.
    25         W !!,"Billing Provider Secondary IDs (VistA Record CI1A):"
    26         D SECID(Z,.IBQUIT)
    27         I IBQUIT G EX
    28         ;
    29         ; Now display the lab or facility primary and secondary IDs
    30         ; This is the service facility information
    31         ;
    32         ; Facility name, same code as found in SUB-2
    33         I ($Y+5)>IOSL S IBQUIT=$$NOMORE^IBCEF74() I IBQUIT G EX
    34         W !!,"Service Facility Name and ID Information"
    35         S IBXIEN=IBIFN
    36         D F^IBCEF("N-RENDERING INSTITUTION","IBZ",,IBIFN)
    37         I $$ISRX^IBCEF1(IBIFN) S Z=$$RXSITE^IBCEF73A(IBIFN) I Z S $P(IBZ,"^")=+Z
    38         S FACNAME=$$GETFAC^IBCEP8(+IBZ,+$P(IBZ,U,2),0,"SUB")
    39         S Z="LAB/FAC"
    40         ;
    41         ; determine if flag to suppress lab/fac data is set
    42         D VAMCFD^IBCEF75(IBIFN,.IBSSFI)
    43         I $D(IBSSFI),'$G(IBSSFI("C",1)) D  I IBQUIT G EX
    44         . I ($Y+5)>IOSL S IBQUIT=$$NOMORE^IBCEF74() Q:IBQUIT
    45         . W !!,"Note:  Service Facility Data not sent for Current Insurance"
    46         . W !,"       'Send VA Lab/Facility IDs or Facility Data for VAMC?' is set to NO",!
    47         . Q
    48         ;
    49         ; facility name
    50         I ($Y+5)>IOSL S IBQUIT=$$NOMORE^IBCEF74() I IBQUIT G EX
    51         I FACNAME="" S FACNAME="n/a"
    52         W !,"Facility:  ",FACNAME
    53         ;
    54         ; PRXM/KJH - Add NPI to display for patch 343.
    55         S ORGNPI=$$ORGNPI^IBCEF73A(IBIFN)
    56         S DATA=$S($$ISRX^IBCEF1(IBIFN):$P(ORGNPI,U,3),$P($G(IBZ),U,2)=1:$P(ORGNPI,U,2),$P($G(IBZ),U,2)=0:$P(ORGNPI,U,1),1:$P(ORGNPI,U,3))
    57         I ($Y+5)>IOSL S IBQUIT=$$NOMORE^IBCEF74() I IBQUIT G EX
    58         W !?5,"Lab or Facility NPI:"
    59         W !?12,$S(DATA'="":DATA,1:"***MISSING***")
    60         ; primary ID
    61         S DATA=$G(IBID(Z,IBIFN,"C",1,0))   ; lab/facility current ins primary
    62         S QUALNM=$$QUAL($P(DATA,U,1),$$FT^IBCEF(IBIFN))
    63         S IDNUM=$P(DATA,U,2)
    64         I ($Y+5)>IOSL S IBQUIT=$$NOMORE^IBCEF74() I IBQUIT G EX
    65         W !?5,"Lab or Facility Primary ID (VistA Record SUB):"
    66         I DATA'="" W !?8,"(",$P($G(IBID(Z,IBIFN,"C",1)),U,1),") ",QUALNM,?40,IDNUM
    67         I DATA="" W !?8,"(-) None Found"
    68         ;
    69         ; secondary IDs
    70         I ($Y+5)>IOSL S IBQUIT=$$NOMORE^IBCEF74() I IBQUIT G EX
    71         W !?5,"Lab or Facility Secondary IDs (VistA Records SUB1,SUB2,OP3,OP6,OP7):"
    72         D SECID(Z,.IBQUIT)
    73         I IBQUIT G EX
    74         ;
    75 EX      ;
    76         Q
    77         ;
    78 QUAL(Z,FORMTYPE)        ; turn the qualifier code into a qualifier description
    79         NEW QUAL,IEN
    80         S QUAL=""
    81         I $G(Z)="" G QUALX
    82         I Z="1C" D  G QUALX   ; qualifier for Medicare Part ?
    83         . I $G(FORMTYPE)=2 S QUAL="MEDICARE PART B"   ; 1500
    84         . I $G(FORMTYPE)=3 S QUAL="MEDICARE PART A"   ; ub
    85         . Q
    86         I Z=34 S Z="SY"       ; qualifier for SSN
    87         S IEN=+$O(^IBE(355.97,"C",Z,"")) I 'IEN G QUALX
    88         S QUAL=$P($G(^IBE(355.97,IEN,0)),U,1)
    89 QUALX   ;
    90         Q QUAL
    91         ;
    92 SECID(Z,IBQUIT) ; Display secondary ID and qualifier information
    93         ; Z is the type of IDs passed in; either BILLING PRV or LAB/FAC
    94         ; IBQUIT is returned if passed by reference
    95         NEW SEQ,ZI,ZN,PSIN,DATA,QUALNM,IDNUM,NODATA
    96         S IBQUIT=0,NODATA=1
    97         F SEQ="P","S","T" D  Q:IBQUIT
    98         . ;
    99         . ; current ins only for billing provider secondary IDs
    100         . I Z="BILLING PRV",SEQ'=$$COB^IBCEF(IBIFN) Q
    101         . S ZI=""
    102         . F  S ZI=$O(IBX(Z,SEQ,ZI)) Q:ZI=""  D  Q:IBQUIT
    103         .. S ZN=0
    104         .. F  S ZN=$O(IBX(Z,SEQ,ZI,ZN)) Q:'ZN  D  Q:IBQUIT
    105         ... S PSIN=0   ; start at 0 to skip primary IDs
    106         ... F  S PSIN=$O(IBID(Z,IBIFN,ZI,ZN,PSIN)) Q:PSIN=""  D  Q:IBQUIT
    107         .... S DATA=$G(IBID(Z,IBIFN,ZI,ZN,PSIN))
    108         .... S QUALNM=$$QUAL($P(DATA,U,1),$$FT^IBCEF(IBIFN))
    109         .... S IDNUM=$P(DATA,U,2)
    110         .... I ($Y+5)>IOSL S IBQUIT=$$NOMORE^IBCEF74() Q:IBQUIT
    111         .... S NODATA=0
    112         .... W !?8,"(",SEQ,") ",QUALNM,?40,IDNUM
    113         .... I Z="LAB/FAC",$D(^DGCR(399,IBIFN,"I2")),SEQ=$$COB^IBCEF(IBIFN) W ?54,"<<<Current Ins"
    114         .... I Z="BILLING PRV",PSIN=1 W ?54,"<<<System Generated ID"
    115         .... Q
    116         ... Q
    117         .. Q
    118         . Q
    119         I NODATA,'IBQUIT W !?8,"(-) None Found"
    120 SECIDX  ;
    121         Q
    122         ;
     1IBCEF74A ;ALB/ESG - Provider ID maint ?ID continuation ;7 Mar 2006
     2 ;;2.0;INTEGRATED BILLING;**320,343,349**;21-MAR-94;Build 46
     3 ;;Per VHA Directive 2004-038, this routine should not be modified.
     4 ;
     5 Q
     6 ;
     7EN(IBIFN,IBQUIT) ; Display billing provider and service provider IDs as part
     8 ; of the ?ID display/help in the billing screens.
     9 ; Called from DISPID^IBCEF74.
     10 NEW IBID,IBX,Z,ZI,ZN,SEQ,PSIN,DATA,QUALNM,IDNUM,FACNAME,IBZ,IBXIEN,IBSSFI,ORGNPI
     11 ;
     12 D ALLIDS^IBCEF75(IBIFN,.IBID)
     13 ;
     14 ; Re-sort array by insurance sequence (P/S/T)
     15 K IBX
     16 F Z="BILLING PRV","LAB/FAC" F ZI="C","O" S ZN=0 F  S ZN=$O(IBID(Z,IBIFN,ZI,ZN)) Q:'ZN  D
     17 . S SEQ=$P($G(IBID(Z,IBIFN,ZI,ZN)),U,1) Q:SEQ=""
     18 . S IBX(Z,SEQ,ZI,ZN)=""
     19 . Q
     20 ;
     21 ; Display billing provider secondary ID's (current ins only)
     22 I ($Y+5)>IOSL S IBQUIT=$$NOMORE^IBCEF74() I IBQUIT G EX
     23 S Z="BILLING PRV"
     24 ; PRXM/KJH - Removed "I $D(IBX(Z))" from next line. Caused header to not display even though there would be a "None Found' message.
     25 W !!,"Billing Provider Secondary IDs (VistA Record CI1A):"
     26 D SECID(Z,.IBQUIT)
     27 I IBQUIT G EX
     28 ;
     29 ; Now display the lab or facility primary and secondary IDs
     30 ; This is the service facility information
     31 ;
     32 ; Facility name, same code as found in SUB-2
     33 I ($Y+5)>IOSL S IBQUIT=$$NOMORE^IBCEF74() I IBQUIT G EX
     34 W !!,"Service Facility Name and ID Information"
     35 S IBXIEN=IBIFN
     36 D F^IBCEF("N-RENDERING INSTITUTION","IBZ",,IBIFN)
     37 S FACNAME=$$GETFAC^IBCEP8(+IBZ,+$P(IBZ,U,2),0,"SUB")
     38 S Z="LAB/FAC"
     39 ;
     40 ; determine if flag to suppress lab/fac data is set
     41 D VAMCFD^IBCEF75(IBIFN,.IBSSFI)
     42 I $D(IBSSFI),'$G(IBSSFI("C",1)) D  I IBQUIT G EX
     43 . I ($Y+5)>IOSL S IBQUIT=$$NOMORE^IBCEF74() Q:IBQUIT
     44 . W !!,"Note:  Service Facility Data not sent for Current Insurance"
     45 . W !,"       'Send VA Lab/Facility IDs or Facility Data for VAMC?' is set to NO",!
     46 . Q
     47 ;
     48 ; facility name
     49 I ($Y+5)>IOSL S IBQUIT=$$NOMORE^IBCEF74() I IBQUIT G EX
     50 I FACNAME="" S FACNAME="n/a"
     51 W !,"Facility:  ",FACNAME
     52 ;
     53 ; PRXM/KJH - Add NPI to display for patch 343.
     54 S ORGNPI=$$ORGNPI^IBCEF73A(IBIFN)
     55 S DATA=$S($P($G(IBZ),U,2)=1:$P(ORGNPI,U,2),$P($G(IBZ),U,2)=0:$P(ORGNPI,U,1),1:$P(ORGNPI,U,3))
     56 I ($Y+5)>IOSL S IBQUIT=$$NOMORE^IBCEF74() I IBQUIT G EX
     57 W !?5,"Lab or Facility NPI:"
     58 W !?12,$S(DATA'="":DATA,1:"***MISSING***")
     59 ; primary ID
     60 S DATA=$G(IBID(Z,IBIFN,"C",1,0))   ; lab/facility current ins primary
     61 S QUALNM=$$QUAL($P(DATA,U,1),$$FT^IBCEF(IBIFN))
     62 S IDNUM=$P(DATA,U,2)
     63 I ($Y+5)>IOSL S IBQUIT=$$NOMORE^IBCEF74() I IBQUIT G EX
     64 W !?5,"Lab or Facility Primary ID (VistA Record SUB):"
     65 I DATA'="" W !?8,"(",$P($G(IBID(Z,IBIFN,"C",1)),U,1),") ",QUALNM,?40,IDNUM
     66 I DATA="" W !?8,"(-) None Found"
     67 ;
     68 ; secondary IDs
     69 I ($Y+5)>IOSL S IBQUIT=$$NOMORE^IBCEF74() I IBQUIT G EX
     70 W !?5,"Lab or Facility Secondary IDs (VistA Records SUB1,SUB2,OP3,OP6,OP7):"
     71 D SECID(Z,.IBQUIT)
     72 I IBQUIT G EX
     73 ;
     74EX ;
     75 Q
     76 ;
     77QUAL(Z,FORMTYPE) ; turn the qualifier code into a qualifier description
     78 NEW QUAL,IEN
     79 S QUAL=""
     80 I $G(Z)="" G QUALX
     81 I Z="1C" D  G QUALX   ; qualifier for Medicare Part ?
     82 . I $G(FORMTYPE)=2 S QUAL="MEDICARE PART B"   ; 1500
     83 . I $G(FORMTYPE)=3 S QUAL="MEDICARE PART A"   ; ub
     84 . Q
     85 I Z=34 S Z="SY"       ; qualifier for SSN
     86 S IEN=+$O(^IBE(355.97,"C",Z,"")) I 'IEN G QUALX
     87 S QUAL=$P($G(^IBE(355.97,IEN,0)),U,1)
     88QUALX ;
     89 Q QUAL
     90 ;
     91SECID(Z,IBQUIT) ; Display secondary ID and qualifier information
     92 ; Z is the type of IDs passed in; either BILLING PRV or LAB/FAC
     93 ; IBQUIT is returned if passed by reference
     94 NEW SEQ,ZI,ZN,PSIN,DATA,QUALNM,IDNUM,NODATA
     95 S IBQUIT=0,NODATA=1
     96 F SEQ="P","S","T" D  Q:IBQUIT
     97 . ;
     98 . ; current ins only for billing provider secondary IDs
     99 . I Z="BILLING PRV",SEQ'=$$COB^IBCEF(IBIFN) Q
     100 . S ZI=""
     101 . F  S ZI=$O(IBX(Z,SEQ,ZI)) Q:ZI=""  D  Q:IBQUIT
     102 .. S ZN=0
     103 .. F  S ZN=$O(IBX(Z,SEQ,ZI,ZN)) Q:'ZN  D  Q:IBQUIT
     104 ... S PSIN=0   ; start at 0 to skip primary IDs
     105 ... F  S PSIN=$O(IBID(Z,IBIFN,ZI,ZN,PSIN)) Q:PSIN=""  D  Q:IBQUIT
     106 .... S DATA=$G(IBID(Z,IBIFN,ZI,ZN,PSIN))
     107 .... S QUALNM=$$QUAL($P(DATA,U,1),$$FT^IBCEF(IBIFN))
     108 .... S IDNUM=$P(DATA,U,2)
     109 .... I ($Y+5)>IOSL S IBQUIT=$$NOMORE^IBCEF74() Q:IBQUIT
     110 .... S NODATA=0
     111 .... W !?8,"(",SEQ,") ",QUALNM,?40,IDNUM
     112 .... I Z="LAB/FAC",$D(^DGCR(399,IBIFN,"I2")),SEQ=$$COB^IBCEF(IBIFN) W ?54,"<<<Current Ins"
     113 .... I Z="BILLING PRV",PSIN=1 W ?54,"<<<System Generated ID"
     114 .... Q
     115 ... Q
     116 .. Q
     117 . Q
     118 I NODATA,'IBQUIT W !?8,"(-) None Found"
     119SECIDX ;
     120 Q
     121 ;

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF75.m

    r613 r623  
    1 IBCEF75 ;ALB/WCJ - Provider ID functions ;13 Feb 2006
    2         ;;2.0;INTEGRATED BILLING;**320,371**;21-MAR-94;Build 57
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5         G AWAY
    6 AWAY    Q
    7         ;
    8 ALLIDS(IBIFN,IBXSAVE,IBSTRIP,SEG)       ; Return all of the Provider IDS
    9         I '$D(IBSTRIP) S IBSTRIP=0
    10         I '$D(SEG) S SEG=""
    11         N IBXIEN,ARINFO,ARID,ARQ,IBFRMTYP,ARIEN,ARINS,Z0,DAT,I,SORT1,SORT2,SORT3,COB,IBCCOB
    12         ;
    13         S IBXIEN=IBIFN
    14         D ALLPROV^IBCEF7    ; Get the Person ID's (Returns IBXSAVE)
    15         S DAT=$$PROVID^IBCEF73(IBIFN)
    16         S DAT("QUAL")=IBXSAVE("ID")  ; this value was also passed back by above function
    17         S SORT1="" F  S SORT1=$O(IBXSAVE("PROVINF",IBIFN,SORT1)) Q:SORT1=""  D
    18         . S SORT2=0 F  S SORT2=$O(IBXSAVE("PROVINF",IBIFN,SORT1,SORT2)) Q:SORT2=""  D
    19         .. S SORT3=0 F  S SORT3=$O(IBXSAVE("PROVINF",IBIFN,SORT1,SORT2,SORT3))  Q:SORT3=""  D
    20         ... S IBXSAVE("PROVINF",IBIFN,SORT1,SORT2,SORT3,0)="PRIMARY"_U_U_$$STRIP^IBCEF76($P(DAT("QUAL"),U,SORT3)_U_$P(DAT,U,SORT3),1,U,IBSTRIP)
    21         ... F I=1:1 Q:'$D(IBXSAVE("PROVINF",IBIFN,SORT1,SORT2,SORT3,I))  D
    22         .... S $P(IBXSAVE("PROVINF",IBIFN,SORT1,SORT2,SORT3,I),U,3,4)=$$STRIP^IBCEF76($P(IBXSAVE("PROVINF",IBIFN,SORT1,SORT2,SORT3,I),U,3,4),1,U,IBSTRIP)
    23         ;
    24         D LFIDS^IBCEF76(IBIFN,.IBXSAVE,IBSTRIP,SEG)   ; Get the Lab/Facility IDs
    25         ;
    26         S IBFRMTYP=$$FT^IBCEF(IBIFN)
    27         S ARIEN=$S(IBFRMTYP=2:3,1:4)
    28         S IBCCOB=$$COBN^IBCEF(IBIFN)  ; Current Insurance
    29         F COB=1:1:3 D
    30         . S SORT1=$S(COB=IBCCOB:"C",1:"O")
    31         . S SORT2=$S(SORT1="C":1,COB=1:1,COB=2&(IBCCOB=1):1,1:2)
    32         . S ARINFO=$G(IBXSAVE("PROVINF",IBIFN,SORT1,SORT2,ARIEN,1))
    33         . ;
    34         . D BPIDS(IBIFN,.IBXSAVE,SORT1,SORT2,COB,IBSTRIP,SEG)
    35         Q
    36         ;
    37 BPIDS(IBIFN,IDS,SORT1,SORT2,COB,IBSTRIP,SEG)    ; Get all the billing provider IDs and qualifiers from the claim and file 355.92
    38         N DAT,IBFRMTYP,IBCARE,IBDIV,IBINS,MAIN,IBCCOB,USED,PLANTYPE,I,CNT,QUAL,ARF,M1,DEF,IDDIV,IBLIMIT,IEN,ID,IB2
    39         ;
    40         S DAT=$G(^DGCR(399,IBIFN,0))
    41         S IBFRMTYP=$$FT^IBCEF(IBIFN),IBFRMTYP=$S(IBFRMTYP=2:2,IBFRMTYP=3:1,1:0)
    42         S IBCARE=$S($$ISRX^IBCEF1(IBIFN):3,1:0) ;if an Rx refill bill
    43         S:IBCARE=0 IBCARE=$$INPAT^IBCEF(IBIFN,1) S:'IBCARE IBCARE=2 ;1-inp,2-out
    44         S IBDIV=+$P(DAT,U,22)
    45         S MAIN=$$MAIN^IBCEP2B()  ; get the IEN for main Division
    46         S IBCCOB=$$COBN^IBCEF(IBIFN)  ; Current Insurance
    47         S IBINS=$P($G(^DGCR(399,IBIFN,"I"_COB)),U)
    48         Q:IBINS=""
    49         ;
    50         S IDS("BILLING PRV",IBIFN,SORT1,SORT2)=$E("PST",COB)
    51         ;
    52         ; Primary ID
    53         S IDS("BILLING PRV",IBIFN,SORT1,SORT2,0)=$$STRIP^IBCEF76($$TAXID(),1,U,IBSTRIP)
    54         S USED($P(IDS("BILLING PRV",IBIFN,SORT1,SORT2,0),U))=""
    55         ;
    56         ; Secondary #1 - This is the ID Emdeon uses for sorting
    57         S IDS("BILLING PRV",IBIFN,SORT1,SORT2,1)=$$STRIP^IBCEF76($$BPSID1(IBDIV),1,U,IBSTRIP)
    58         S USED($P(IDS("BILLING PRV",IBIFN,SORT1,SORT2,1),U))=""
    59         ;
    60         ; Check if this is a plan type which gets no secondary IDs
    61         S M1=$G(^DGCR(399,IBIFN,"M1"))
    62         ; the following check is the current value of the flag, not when the claim was created.
    63         S PLANTYPE=$$POLTYP^IBCEF3(IBIFN,COB)
    64         I PLANTYPE]"",$D(^DIC(36,IBINS,13,"B",PLANTYPE)) Q
    65         ;
    66         ; Secondary #2
    67         ; If there is a ID  send with quailifer (stored or computed)
    68         I $TR($P(M1,U,COB+1)," ")]"" D
    69         . S QUAL=""
    70         . S DAT=$P(M1,U,COB+9)
    71         . I DAT S QUAL=$$STRIP^IBCEF76($P($G(^IBE(355.97,DAT,0)),U,3),1,,IBSTRIP)
    72         . ; the null check is needed to be backwards compatible
    73         . I QUAL=""!(QUAL="1J") S QUAL=$$STRIP^IBCEF76($$OLDWAY(IBIFN,COB),1,,IBSTRIP)
    74         . S IB2=QUAL_U_$$STRIP^IBCEF76($P(M1,U,COB+1),1,,IBSTRIP)
    75         ;
    76         I $TR($P(M1,U,COB+1)," ")="" S IB2=$$STRIP^IBCEF76($$OLDWAY(IBIFN,COB),1,,IBSTRIP)_U_$$STRIP^IBCEF76($$GET1^DIQ(350.9,1,1.05),1,,IBSTRIP)
    77         ;
    78         S IDS("BILLING PRV",IBIFN,SORT1,SORT2,2)=IB2
    79         S IDS("BILLING PRV",IBIFN,SORT1,SORT2,2,"PTQ")=$$OLDWAY(IBIFN,COB)
    80         S USED($P(IB2,U))=""
    81         ;
    82         S CNT=$S('$D(IDS("BILLING PRV",IBIFN,SORT1,SORT2,2)):2,1:3)
    83         S IBLIMIT=8
    84         S IEN=0 F  S IEN=$O(^IBA(355.92,"B",IBINS,IEN)) Q:IEN=""  D  Q:CNT>IBLIMIT
    85         . S DAT=$G(^IBA(355.92,IEN,0))
    86         . Q:$P(DAT,U,8)'="A"   ; only allow additional IDs
    87         . Q:$P(DAT,U,7)=""  ; No Provider ID
    88         . Q:$P(DAT,U,6)=""  ; No ID Qualifier
    89         . I IBFRMTYP=1 Q:$P(DAT,U,4)=2
    90         . I IBFRMTYP=2 Q:$P(DAT,U,4)=1
    91         . ;
    92         . ; Check if we already have one of these
    93         . S QUAL=$$STRIP^IBCEF76($P(DAT,U,6),1,,IBSTRIP)
    94         . S QUAL=$P($G(^IBE(355.97,QUAL,0)),U,3)
    95         . Q:QUAL=""
    96         . Q:$D(USED(QUAL))
    97         . ;
    98         . S IDS("BILLING PRV",IBIFN,SORT1,SORT2,CNT)=QUAL_U_$$STRIP^IBCEF76($P(DAT,U,7),1,,IBSTRIP)
    99         . S CNT=CNT+1,USED(QUAL)=""
    100         ;
    101         Q
    102         ;
    103 OLDWAY(IBIFN,COB)       ; Figure out the qualifier the old way if it's not stored with the claim.
    104         ; It's based on the plan type.  This is used for Billing Provider Secondary ID #2
    105         N PLANTYPE
    106         S PLANTYPE=$$POLTYP^IBCEF3(IBIFN,COB)
    107         Q $$SOP^IBCEP2B(IBIFN,PLANTYPE)
    108         ;
    109 BPSID1(DIV)     ; Return the Billing Provider Secondary ID #1 and qualifier which Emdeon uses to sort IBIFNs
    110         N DATA
    111         S DATA=$P($$SITE^VASITE(DT,$S(DIV:DIV,1:+$$SITE^VASITE())),U,3)
    112         S DATA=$E("0000",1,7-$L(DATA))_$E(DATA,4,7)
    113         Q "G5"_U_DATA
    114         ;
    115 TAXID() ; Return the Billing Provider Primary ID and qualifier which is the TAXID for the site and also the qualifier
    116         N DATA
    117         S DATA=$P($G(^IBE(350.9,1,1)),U,5)
    118         S DATA=$$NOPUNCT^IBCEF(DATA,1)
    119         Q 24_U_DATA
    120         ;
    121 VAMCFD(IBIFN,IBRET)     ;
    122         ;
    123         ; This procedure returns data based on flag in insurance company file which is set in the insurance co editor
    124         ; Send VA Lab/Facility IDs or Facility Data for VAMC?
    125         ; The return value will be set to 1 (yes) if the division in the claim is not the main division (VAMC) or
    126         ; if the flag in the dictionary for that insurance company says to send the data.
    127         ;
    128         ; Input - IBFN - IEN 399
    129         ; Output - IBRET(IBSORT1,IBSORT2)=FLAG
    130         ;    IBSORT1 = "C"urrent or "O"ther insurance
    131         ;    IBSORT2 = order with IBSORT1
    132         ;    FLAG = 0 No or 1 Yes
    133         ;
    134         N IBDIV,MAIN,IBCCOB,IBSORT1,IBSORT2,DAT,IBINS,COB,OUTFAC
    135         S IBDIV=+$P($G(^DGCR(399,IBIFN,0)),U,22)
    136         S MAIN=$$MAIN^IBCEP2B()  ; get the IEN for main Division
    137         S IBCCOB=$$COBN^IBCEF(IBIFN)
    138         F COB=1:1:3 D
    139         . S IBSORT1=$S(COB=IBCCOB:"C",1:"O")
    140         . S IBSORT2=$S(IBSORT1="C":1,COB=1:1,COB=2&(IBCCOB=1):1,1:2)
    141         . S IBINS=+$G(^DGCR(399,IBIFN,"I"_COB))
    142         . Q:'IBINS
    143         . S IBRET(IBSORT1,IBSORT2)=1
    144         . S OUTFAC=$P($G(^DGCR(399,IBIFN,"U2")),U,10)
    145         . Q:OUTFAC]""
    146         . Q:IBDIV'=MAIN
    147         . ; [7] Send VA Lab/Facility IDs or Facility Data for VAMC?(0 - NO, 1 - YES)
    148         . S DAT(3647)=$P($G(^DIC(36,IBINS,4)),U,7)
    149         . I DAT(3647) Q
    150         . S IBRET(IBSORT1,IBSORT2)=0
    151         Q
    152         ;
    153 CLEANUP(IBXSAVE)        ; Clean up
    154         K IBXSAVE("PROVINF")
    155         K IBXSAVE("LAB/FAC")
    156         K IBXSAVE("BILLING PRV")
    157         K IBXSAVE("ID")
    158         Q
     1IBCEF75 ;ALB/WCJ - Provider ID functions ;13 Feb 2006
     2 ;;2.0;INTEGRATED BILLING;**320**;21-MAR-94
     3 ;; Per VHA Directive 10-93-142, this routine should not be modified.
     4 ;
     5 G AWAY
     6AWAY Q
     7 ;
     8ALLIDS(IBIFN,IBXSAVE,IBSTRIP,SEG) ; Return all of the Provider IDS
     9 I '$D(IBSTRIP) S IBSTRIP=0
     10 I '$D(SEG) S SEG=""
     11 N IBXIEN,ARINFO,ARID,ARQ,IBFRMTYP,ARIEN,ARINS,Z0,DAT,I,SORT1,SORT2,SORT3,COB,IBCCOB
     12 ;
     13 S IBXIEN=IBIFN
     14 D ALLPROV^IBCEF7    ; Get the Person ID's (Returns IBXSAVE)
     15 S DAT=$$PROVID^IBCEF73(IBIFN)
     16 S DAT("QUAL")=IBXSAVE("ID")  ; this value was also passed back by above function
     17 S SORT1="" F  S SORT1=$O(IBXSAVE("PROVINF",IBIFN,SORT1)) Q:SORT1=""  D
     18 . S SORT2=0 F  S SORT2=$O(IBXSAVE("PROVINF",IBIFN,SORT1,SORT2)) Q:SORT2=""  D
     19 .. S SORT3=0 F  S SORT3=$O(IBXSAVE("PROVINF",IBIFN,SORT1,SORT2,SORT3))  Q:SORT3=""  D
     20 ... S IBXSAVE("PROVINF",IBIFN,SORT1,SORT2,SORT3,0)="PRIMARY"_U_U_$$STRIP^IBCEF76($P(DAT("QUAL"),U,SORT3)_U_$P(DAT,U,SORT3),1,U,IBSTRIP)
     21 ... F I=1:1 Q:'$D(IBXSAVE("PROVINF",IBIFN,SORT1,SORT2,SORT3,I))  D
     22 .... S $P(IBXSAVE("PROVINF",IBIFN,SORT1,SORT2,SORT3,I),U,3,4)=$$STRIP^IBCEF76($P(IBXSAVE("PROVINF",IBIFN,SORT1,SORT2,SORT3,I),U,3,4),1,U,IBSTRIP)
     23 ;
     24 D LFIDS^IBCEF76(IBIFN,.IBXSAVE,IBSTRIP,SEG)   ; Get the Lab/Facility IDs
     25 ;
     26 S IBFRMTYP=$$FT^IBCEF(IBIFN)
     27 S ARIEN=$S(IBFRMTYP=2:3,1:4)
     28 S IBCCOB=$$COBN^IBCEF(IBIFN)  ; Current Insurance
     29 F COB=1:1:3 D
     30 . S SORT1=$S(COB=IBCCOB:"C",1:"O")
     31 . S SORT2=$S(SORT1="C":1,COB=1:1,COB=2&(IBCCOB=1):1,1:2)
     32 . S ARINFO=$G(IBXSAVE("PROVINF",IBIFN,SORT1,SORT2,ARIEN,1))
     33 . ;
     34 . D BPIDS(IBIFN,.IBXSAVE,SORT1,SORT2,COB,IBSTRIP,SEG)
     35 Q
     36 ;
     37BPIDS(IBIFN,IDS,SORT1,SORT2,COB,IBSTRIP,SEG) ; Get all the billing provider IDs and qualifiers from the claim and file 355.92
     38 N DAT,IBFRMTYP,IBCARE,IBDIV,IBINS,MAIN,IBCCOB,USED,PLANTYPE,I,CNT,QUAL,ARF,M1,DEF,IDDIV,IBLIMIT,IEN,ID,IB2
     39 ;
     40 S DAT=$G(^DGCR(399,IBIFN,0))
     41 S IBFRMTYP=$$FT^IBCEF(IBIFN),IBFRMTYP=$S(IBFRMTYP=2:2,IBFRMTYP=3:1,1:0)
     42 S IBCARE=$S($$ISRX^IBCEF1(IBIFN):3,1:0) ;if an Rx refill bill
     43 S:IBCARE=0 IBCARE=$$INPAT^IBCEF(IBIFN,1) S:'IBCARE IBCARE=2 ;1-inp,2-out
     44 S IBDIV=+$P(DAT,U,22)
     45 S MAIN=$$MAIN^IBCEP2B()  ; get the IEN for main Division
     46 S IBCCOB=$$COBN^IBCEF(IBIFN)  ; Current Insurance
     47 S IBINS=$P($G(^DGCR(399,IBIFN,"I"_COB)),U)
     48 Q:IBINS=""
     49 ;
     50 S IDS("BILLING PRV",IBIFN,SORT1,SORT2)=$E("PST",COB)
     51 ;
     52 ; Primary ID
     53 S IDS("BILLING PRV",IBIFN,SORT1,SORT2,0)=$$STRIP^IBCEF76($$TAXID(),1,U,IBSTRIP)
     54 S USED($P(IDS("BILLING PRV",IBIFN,SORT1,SORT2,0),U))=""
     55 ;
     56 ; Secondary #1 - This is the ID Emdeon uses for sorting
     57 S IDS("BILLING PRV",IBIFN,SORT1,SORT2,1)=$$STRIP^IBCEF76($$BPSID1(IBDIV),1,U,IBSTRIP)
     58 S USED($P(IDS("BILLING PRV",IBIFN,SORT1,SORT2,1),U))=""
     59 ;
     60 ; Check if this is a plan type which gets no secondary IDs
     61 S M1=$G(^DGCR(399,IBIFN,"M1"))
     62 ; the following check is the current value of the flag, not when the claim was created.
     63 S PLANTYPE=$$POLTYP^IBCEF3(IBIFN,COB)
     64 I PLANTYPE]"",$D(^DIC(36,IBINS,13,"B",PLANTYPE)) Q
     65 ;
     66 ; Secondary #2
     67 ; If there is a ID  send with quailifer (stored or computed)
     68 I $P(M1,U,COB+1)]"" D
     69 . S QUAL=""
     70 . S DAT=$P(M1,U,COB+9)
     71 . I DAT S QUAL=$$STRIP^IBCEF76($P($G(^IBE(355.97,DAT,0)),U,3),1,,IBSTRIP)
     72 . ; the null check is needed to be backwards compatible
     73 . I QUAL=""!(QUAL="1J") S QUAL=$$STRIP^IBCEF76($$OLDWAY(IBIFN,COB),1,,IBSTRIP)
     74 . S IB2=QUAL_U_$$STRIP^IBCEF76($P(M1,U,COB+1),1,,IBSTRIP)
     75 ;
     76 I $P(M1,U,COB+1)="" S IB2=$$STRIP^IBCEF76($$OLDWAY(IBIFN,COB),1,,IBSTRIP)_U_$$STRIP^IBCEF76($$GET1^DIQ(350.9,1,1.05),1,,IBSTRIP)
     77 ;
     78 S IDS("BILLING PRV",IBIFN,SORT1,SORT2,2)=IB2
     79 S IDS("BILLING PRV",IBIFN,SORT1,SORT2,2,"PTQ")=$$OLDWAY(IBIFN,COB)
     80 S USED($P(IB2,U))=""
     81 ;
     82 S CNT=$S('$D(IDS("BILLING PRV",IBIFN,SORT1,SORT2,2)):2,1:3)
     83 S IBLIMIT=8
     84 S IEN=0 F  S IEN=$O(^IBA(355.92,"B",IBINS,IEN)) Q:IEN=""  D  Q:CNT>IBLIMIT
     85 . S DAT=$G(^IBA(355.92,IEN,0))
     86 . Q:$P(DAT,U,8)'="A"   ; only allow additional IDs
     87 . Q:$P(DAT,U,7)=""  ; No Provider ID
     88 . Q:$P(DAT,U,6)=""  ; No ID Qualifier
     89 . I IBFRMTYP=1 Q:$P(DAT,U,4)=2
     90 . I IBFRMTYP=2 Q:$P(DAT,U,4)=1
     91 . ;
     92 . ; Check if we already have one of these
     93 . S QUAL=$$STRIP^IBCEF76($P(DAT,U,6),1,,IBSTRIP)
     94 . S QUAL=$P($G(^IBE(355.97,QUAL,0)),U,3)
     95 . Q:QUAL=""
     96 . Q:$D(USED(QUAL))
     97 . ;
     98 . S IDS("BILLING PRV",IBIFN,SORT1,SORT2,CNT)=QUAL_U_$$STRIP^IBCEF76($P(DAT,U,7),1,,IBSTRIP)
     99 . S CNT=CNT+1,USED(QUAL)=""
     100 ;
     101 Q
     102 ;
     103OLDWAY(IBIFN,COB) ; Figure out the qualifier the old way if it's not stored with the claim.
     104 ; It's based on the plan type.  This is used for Billing Provider Secondary ID #2
     105 N PLANTYPE
     106 S PLANTYPE=$$POLTYP^IBCEF3(IBIFN,COB)
     107 Q $$SOP^IBCEP2B(IBIFN,PLANTYPE)
     108 ;
     109BPSID1(DIV) ; Return the Billing Provider Secondary ID #1 and qualifier which Emdeon uses to sort IBIFNs
     110 N DATA
     111 S DATA=$P($$SITE^VASITE(DT,$S(DIV:DIV,1:+$$SITE^VASITE())),U,3)
     112 S DATA=$E("0000",1,7-$L(DATA))_$E(DATA,4,7)
     113 Q "G5"_U_DATA
     114 ;
     115TAXID() ; Return the Billing Provider Primary ID and qualifier which is the TAXID for the site and also the qualifier
     116 N DATA
     117 S DATA=$P($G(^IBE(350.9,1,1)),U,5)
     118 S DATA=$$NOPUNCT^IBCEF(DATA,1)
     119 Q 24_U_DATA
     120 ;
     121VAMCFD(IBIFN,IBRET) ;
     122 ;
     123 ; This procedure returns data based on flag in insurance company file which is set in the insurance co editor
     124 ; Send VA Lab/Facility IDs or Facility Data for VAMC?
     125 ; The return value will be set to 1 (yes) if the division in the claim is not the main division (VAMC) or
     126 ; if the flag in the dictionary for that insurance company says to send the data.
     127 ;
     128 ; Input - IBFN - IEN 399
     129 ; Output - IBRET(IBSORT1,IBSORT2)=FLAG
     130 ;    IBSORT1 = "C"urrent or "O"ther insurance
     131 ;    IBSORT2 = order with IBSORT1
     132 ;    FLAG = 0 No or 1 Yes
     133 ;
     134 N IBDIV,MAIN,IBCCOB,IBSORT1,IBSORT2,DAT,IBINS,COB,OUTFAC
     135 S IBDIV=+$P($G(^DGCR(399,IBIFN,0)),U,22)
     136 S MAIN=$$MAIN^IBCEP2B()  ; get the IEN for main Division
     137 S IBCCOB=$$COBN^IBCEF(IBIFN)
     138 F COB=1:1:3 D
     139 . S IBSORT1=$S(COB=IBCCOB:"C",1:"O")
     140 . S IBSORT2=$S(IBSORT1="C":1,COB=1:1,COB=2&(IBCCOB=1):1,1:2)
     141 . S IBINS=+$G(^DGCR(399,IBIFN,"I"_COB))
     142 . Q:'IBINS
     143 . S IBRET(IBSORT1,IBSORT2)=1
     144 . S OUTFAC=$P($G(^DGCR(399,IBIFN,"U2")),U,10)
     145 . Q:OUTFAC]""
     146 . Q:IBDIV'=MAIN
     147 . ; [7] Send VA Lab/Facility IDs or Facility Data for VAMC?(0 - NO, 1 - YES)
     148 . S DAT(3647)=$P($G(^DIC(36,IBINS,4)),U,7)
     149 . I DAT(3647) Q
     150 . S IBRET(IBSORT1,IBSORT2)=0
     151 Q
     152 ;
     153CLEANUP(IBXSAVE) ; Clean up
     154 K IBXSAVE("PROVINF")
     155 K IBXSAVE("LAB/FAC")
     156 K IBXSAVE("BILLING PRV")
     157 K IBXSAVE("ID")
     158 Q

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEFG1.m

    r613 r623  
    1 IBCEFG1 ;ALB/TMP - OUTPUT FORMATTER DATA DEFINITION UTILITIES ;18-JAN-96
    2         ;;2.0;INTEGRATED BILLING;**52,51,137,181,197,232,288,349,371,377**;21-MAR-94;Build 23
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5 EDIBILL(IBXFORM,IBXDA,IBINS,IBTYP)      ; Find element associated with form fld
    6         ; IBXFORM = (REQUIRED) actual form being extracted (in file 353)
    7         ; IBXDA = (REQUIRED) form definition file (364.6) entry to use to find
    8         ;         extract data element definition entry (in file 364.7)
    9         ; IBINS = (REQUIRED) insurance co. ien for the current insurance on bill
    10         ; IBTYP = (REQUIRED) bill type (I/O)
    11         ;
    12         ; Returns ien of the entry in file 364.7 if a match on override criteria
    13         ;  was found.  Returns -1 if a screen form and the criteria fails for a
    14         ;  field without an override
    15         ;
    16         N IBX,IBPARFM,IBSCREEN,IBNMATCH,EDIQ,IB1
    17         I $G(IBXDA)=""!($G(IBXFORM)="") G EDIQ
    18         S EDIQ=0
    19         S IBPARFM=$P($G(^IBE(353,IBXFORM,2)),U,5) S:'IBPARFM IBPARFM=IBXFORM
    20         S IBSCREEN=($P($G(^IBE(353,+IBXFORM,2)),U,2)="S")
    21         S IB1=(IBPARFM=IBXFORM) ; Not a local field that is not a parent
    22         ;
    23         I $G(IBINS)'="",$G(IBTYP)'="" D:$O(^IBA(364.7,"AINTYP",IBXDA,""))'=""  G:EDIQ EDIQ
    24         . I '$D(^IBA(364.7,"AINTYP",IBXDA,IBINS,IBTYP)) S IBNMATCH=1 Q
    25         . S IBX=+$O(^IBA(364.7,"AINTYP",IBXDA,IBINS,IBTYP,"")),EDIQ=1 S:IBX IBNMATCH=0 ;by ins co and type of bill
    26         ;
    27         I $G(IBINS)'="" D:$O(^IBA(364.7,"AINS",IBXDA,""))'=""  G:EDIQ EDIQ
    28         . I '$D(^IBA(364.7,"AINS",IBXDA,IBINS)) S IBNMATCH=1 Q
    29         . S IBX=+$O(^IBA(364.7,"AINS",IBXDA,IBINS,"")),EDIQ=1 S:IBX IBNMATCH=0 ;ins co only
    30         ;
    31         I $G(IBTYP)'="" D:$O(^IBA(364.7,"ATYPE",IBXDA,""))'=""  G:EDIQ EDIQ
    32         . I '$D(^IBA(364.7,"ATYPE",IBXDA,IBTYP)) S IBNMATCH=1 Q
    33         . S IBX=+$O(^IBA(364.7,"ATYPE",IBXDA,IBTYP,"")),EDIQ=1 S:IBX IBNMATCH=0 ;type of bill only
    34         ;
    35         I IBXFORM,$S(IBXFORM'=IBPARFM:1,1:IBSCREEN) D  G EDIQ
    36         . S IBX=+$O(^IBA(364.7,"ALL",IBXDA,"")) ; Check for all ins co and types
    37         . I IBX,+$O(^IBA(364.7,"ALL",IBXDA,IBX)) D  ; Find override for 'ALL'
    38         .. N Z
    39         .. S Z=0 F  S Z=$O(^IBA(364.7,"ALL",IBXDA,Z)) Q:'Z  I $P($G(^IBA(364.7,Z,0)),U)'=IBXDA S IBX=Z Q
    40         . I 'IBX,+$O(^IBA(364.7,"B",IBXDA,"")) S IBX=$O(^(""))
    41         . S:IBX IBNMATCH=0
    42         ;
    43         I IBXFORM,$O(^IBA(364.6,"APAR",IBXFORM,IBXDA,"")) S IBX=+$O(^("")),IBX=+$O(^IBA(364.7,"B",IBX,0)) I IBX G EDIQ
    44         S IBX=+$O(^IBA(364.7,"B",IBXDA,""))
    45 EDIQ    I IBSCREEN,$G(IBNMATCH) S IBX=-1
    46         Q $G(IBX)
    47         ;
    48 DT(DATE1,DATE2,FORMAT)  ; Return date in DATE1 (and optionally DATE2)
    49         ;   (input in Fileman format) converted to X12 format
    50         ; FORMAT (required)
    51         ; DATE1,DATE2 in FILEMAN date format
    52         N DATE S DATE=""
    53         I DATE1=0 S DATE1=""
    54         I $E(FORMAT)="D" D  G DTQ
    55         .S DATE=$E(DATE1,2,7) Q:$P(FORMAT,"D",2)=6  ;YYMMDD
    56         .S:DATE1 DATE=($E(DATE1)+17)_DATE ;CCYYMMDD
    57         I $E(FORMAT)="R" D
    58         .S:DATE1 DATE=$E(DATE1,2,7)_"-"_$E($S($G(DATE2):DATE2,1:DATE1),2,7) ;YYMMDD-YYMMDD
    59         .Q:FORMAT["6"
    60         .S DATE=($E(DATE1)+17)_DATE,$P(DATE,"-",2)=($E($S($G(DATE2):DATE2,1:DATE1))+17)_$P(DATE,"-",2) ;CCYYMMDD-CCYYMMDD
    61 DTQ     Q DATE
    62         ;
    63 NAME(IBNM1,COMB)        ; Parse person's nm into 5 pieces LAST^FIRST^MIDDLE^CRED^SUFFIX
    64         ; IBNM1 = NAME in LAST,FIRST MIDDLE^vp file ien (200 or 355.93)^bill ien^prv type
    65         ;      OR         FIRST MIDDLE LAST^vp file ien (200 or 355.93)^bill ien^prv type
    66         ; COMB = if set to 1, then combine the first and middle name
    67         ;        if set to 2, combine the last and middle names
    68         N PC,IBIEN,IBCRED,IBNM,IBNMC,IBPIEN
    69         S IBIEN=$P(IBNM1,U,2),IBNMC=$P(IBNM1,U)
    70         S IBPIEN=+$O(^DGCR(399,+$P(IBNM1,U,3),"PRV","B",+$P(IBNM1,U,4),0))
    71         S IBCRED=$$CRED^IBCEU(IBIEN,+$P(IBNM1,U,3),IBPIEN) ;Degree
    72         I IBNMC="DEPT VETERANS AFFAIRS" S IBNMC="VETERANS AFFAIRS,DEPT"
    73         I IBNMC["," D  G NAMEQ
    74         . S IBNMC=$TR(IBNMC,".") D NAMECOMP^XLFNAME(.IBNMC)
    75         . S IBNM=$G(IBNMC("FAMILY"))_U_$G(IBNMC("GIVEN"))_U_$G(IBNMC("MIDDLE"))_U_IBCRED_U_$G(IBNMC("SUFFIX"))
    76         D STDNAME^XLFNAME(.IBNMC,"C")
    77         S IBNM=$G(IBNMC("FAMILY"))_U_$G(IBNMC("GIVEN"))_U_$G(IBNMC("MIDDLE"))_U_IBCRED_U_$G(IBNMC("SUFFIX"))
    78         I $P(IBNM1,U,2)["355.93",$P($G(^IBA(355.93,+$P(IBNM1,U,2),0)),U,2)=1 D  G NAMEQ  ; group performing provider
    79         . S IBNM=$P(IBNM1,U)_U_U_U_IBCRED_U
    80         I $G(COMB)=1,$G(IBNMC("MIDDLE"))'="" S IBNM=$P(IBNM,U)_U_$P(IBNM,U,2)_" "_$P(IBNM,U,3)_U_IBCRED_U_$P(IBNM,U,5)
    81         I $G(COMB)=2,$G(IBNMC("MIDDLE"))'="" S IBNM=$P(IBNM,U)_" "_$P(IBNM,U,3)_U_$P(IBNM,U,2)_U_IBCRED_U_$P(IBNM,U,5)
    82         ;
    83 NAMEQ   Q IBNM
    84         ;
    85 DOLLAR(AMT)     ; Format amount in AMT so it is numeric including cents, without
    86         ; the decimal and commas.
    87         N DOLR,CENT
    88         I AMT'="" S AMT=$TR(AMT,","),DOLR=$P(AMT,"."),CENT=$E($P(AMT,".",2)_"00",1,2),AMT=DOLR_CENT
    89         Q AMT
    90         ;
    91 STATE(CODE)     ;Return state code from state pointer
    92         Q $P($G(^DIC(5,+CODE,0)),U,2)
    93         ;
    94 SEX(CODE)       ;Return the X12 code for sex
    95         ; CODE = DHCP code for sex
    96         Q $S(CODE="":"U","MF"[$E(CODE):$E(CODE),1:"U")
    97         ;
    98 EMPLST(CODE)    ;Return the X12 code for employment status
    99         ; CODE = DHCP code for employment status
    100         N X12
    101         S X12=""
    102         S:CODE'="" X12=$P($P("1;FT^2;PT^3;NE^4;SE^5;RT^6;AU^9;UK",CODE_";",2),U)
    103         S:X12="" X12="UK"
    104         Q X12
    105         ;
    106 MARITAL(CODE)   ;Return the X12 code for marital status
    107         ; CODE = ien of code for marital status
    108         N X12
    109         S X12=$P($G(^DIC(11,+CODE,0)),U,3)
    110         I X12'="" S X12=$P($P("D;D^M;M^N;I^S;X^W;W^U;K",X12_";",2),U)
    111         Q X12
    112         ;
    113 TOS(CODE)       ;Return the X12 code for type of service
    114         ; CODE = DHCP code for type of service
    115         N X12
    116         S X12=$S(CODE>0&(CODE<10):CODE,1:$P($P("0;10^A;11^B;13^H;45^L;18^M;15^N;63^V;19^Y;20^Z;21^43;96^53;96",CODE_";",2),U)) S:X12="" X12=CODE
    117         Q X12
    118         ;
    119 FIXLEN(DATA,LEN)        ; Create a fixed length field from data DATA length LEN
    120         Q $E(DATA_$J("",LEN),1,LEN)
    121         ;
    122 RCDT(IBXSAVE,IBXDATA,IBDT)      ; Format date for multiple revenue code transmission)
    123         ;IBXSAVE = array containing the extracted service line data for the UB format bill
    124         ;IBXDATA = array returned with service line dates formatted in YYYYMMDD format
    125         ;IBDT = the default date for the revenue codes on the bill
    126         N Q,W
    127         S Q=0 F  S Q=$O(IBXSAVE("INPT",Q)) Q:'Q  S W=$$DT($P(IBXSAVE("INPT",1),U,10),,"D8"),IBXDATA(Q)=$S(W:W,1:IBDT)
    128         Q
     1IBCEFG1 ;ALB/TMP - OUTPUT FORMATTER DATA DEFINITION UTILITIES ;18-JAN-96
     2 ;;2.0;INTEGRATED BILLING;**52,51,137,181,197,232,288,349**;21-MAR-94;Build 46
     3 ;;Per VHA Directive 2004-038, this routine should not be modified.
     4 ;
     5EDIBILL(IBXFORM,IBXDA,IBINS,IBTYP) ; Find element associated with form fld
     6 ; IBXFORM = (REQUIRED) actual form being extracted (in file 353)
     7 ; IBXDA = (REQUIRED) form definition file (364.6) entry to use to find
     8 ;         extract data element definition entry (in file 364.7)
     9 ; IBINS = (REQUIRED) insurance co. ien for the current insurance on bill
     10 ; IBTYP = (REQUIRED) bill type (I/O)
     11 ;
     12 ; Returns ien of the entry in file 364.7 if a match on override criteria
     13 ;  was found.  Returns -1 if a screen form and the criteria fails for a
     14 ;  field without an override
     15 ;
     16 N IBX,IBPARFM,IBSCREEN,IBNMATCH,EDIQ,IB1
     17 I $G(IBXDA)=""!($G(IBXFORM)="") G EDIQ
     18 S EDIQ=0
     19 S IBPARFM=$P($G(^IBE(353,IBXFORM,2)),U,5) S:'IBPARFM IBPARFM=IBXFORM
     20 S IBSCREEN=($P($G(^IBE(353,+IBXFORM,2)),U,2)="S")
     21 S IB1=(IBPARFM=IBXFORM) ; Not a local field that is not a parent
     22 ;
     23 I $G(IBINS)'="",$G(IBTYP)'="" D:$O(^IBA(364.7,"AINTYP",IBXDA,""))'=""  G:EDIQ EDIQ
     24 . I '$D(^IBA(364.7,"AINTYP",IBXDA,IBINS,IBTYP)) S IBNMATCH=1 Q
     25 . S IBX=+$O(^IBA(364.7,"AINTYP",IBXDA,IBINS,IBTYP,"")),EDIQ=1 S:IBX IBNMATCH=0 ;by ins co and type of bill
     26 ;
     27 I $G(IBINS)'="" D:$O(^IBA(364.7,"AINS",IBXDA,""))'=""  G:EDIQ EDIQ
     28 . I '$D(^IBA(364.7,"AINS",IBXDA,IBINS)) S IBNMATCH=1 Q
     29 . S IBX=+$O(^IBA(364.7,"AINS",IBXDA,IBINS,"")),EDIQ=1 S:IBX IBNMATCH=0 ;ins co only
     30 ;
     31 I $G(IBTYP)'="" D:$O(^IBA(364.7,"ATYPE",IBXDA,""))'=""  G:EDIQ EDIQ
     32 . I '$D(^IBA(364.7,"ATYPE",IBXDA,IBTYP)) S IBNMATCH=1 Q
     33 . S IBX=+$O(^IBA(364.7,"ATYPE",IBXDA,IBTYP,"")),EDIQ=1 S:IBX IBNMATCH=0 ;type of bill only
     34 ;
     35 I IBXFORM,$S(IBXFORM'=IBPARFM:1,1:IBSCREEN) D  G EDIQ
     36 . S IBX=+$O(^IBA(364.7,"ALL",IBXDA,"")) ; Check for all ins co and types
     37 . I IBX,+$O(^IBA(364.7,"ALL",IBXDA,IBX)) D  ; Find override for 'ALL'
     38 .. N Z
     39 .. S Z=0 F  S Z=$O(^IBA(364.7,"ALL",IBXDA,Z)) Q:'Z  I $P($G(^IBA(364.7,Z,0)),U)'=IBXDA S IBX=Z Q
     40 . I 'IBX,+$O(^IBA(364.7,"B",IBXDA,"")) S IBX=$O(^(""))
     41 . S:IBX IBNMATCH=0
     42 ;
     43 I IBXFORM,$O(^IBA(364.6,"APAR",IBXFORM,IBXDA,"")) S IBX=+$O(^("")),IBX=+$O(^IBA(364.7,"B",IBX,0)) I IBX G EDIQ
     44 S IBX=+$O(^IBA(364.7,"B",IBXDA,""))
     45EDIQ I IBSCREEN,$G(IBNMATCH) S IBX=-1
     46 Q $G(IBX)
     47 ;
     48DT(DATE1,DATE2,FORMAT) ; Return date in DATE1 (and optionally DATE2)
     49 ;   (input in Fileman format) converted to X12 format
     50 ; FORMAT (required)
     51 ; DATE1,DATE2 in FILEMAN date format
     52 N DATE S DATE=""
     53 I DATE1=0 S DATE1=""
     54 I $E(FORMAT)="D" D  G DTQ
     55 .S DATE=$E(DATE1,2,7) Q:$P(FORMAT,"D",2)=6  ;YYMMDD
     56 .S:DATE1 DATE=($E(DATE1)+17)_DATE ;CCYYMMDD
     57 I $E(FORMAT)="R" D
     58 .S:DATE1 DATE=$E(DATE1,2,7)_"-"_$E($S($G(DATE2):DATE2,1:DATE1),2,7) ;YYMMDD-YYMMDD
     59 .Q:FORMAT["6"
     60 .S DATE=($E(DATE1)+17)_DATE,$P(DATE,"-",2)=($E($S($G(DATE2):DATE2,1:DATE1))+17)_$P(DATE,"-",2) ;CCYYMMDD-CCYYMMDD
     61DTQ Q DATE
     62 ;
     63NAME(IBNM1,COMB) ; Parse person's nm into 5 pieces LAST^FIRST^MIDDLE^CRED^SUFFIX
     64 ; IBNM1 = NAME in LAST,FIRST MIDDLE^vp file ien (200 or 355.93)^bill ien^prv type
     65 ;      OR         FIRST MIDDLE LAST^vp file ien (200 or 355.93)^bill ien^prv type
     66 ; COMB = if set to 1, then combine the first and middle name
     67 ;        if set to 2, combine the last and middle names
     68 N PC,IBIEN,IBCRED,IBNM,IBNMC,IBPIEN
     69 S IBIEN=$P(IBNM1,U,2),IBNMC=$P(IBNM1,U)
     70 S IBPIEN=+$O(^DGCR(399,+$P(IBNM1,U,3),"PRV","B",+$P(IBNM1,U,4),0))
     71 S IBCRED=$$CRED^IBCEU(IBIEN,+$P(IBNM1,U,3),IBPIEN) ;Degree
     72 I IBNMC="DEPT VETERANS AFFAIRS" S IBNMC="VETERANS AFFAIRS,DEPT"
     73 I IBNMC["," D  G NAMEQ
     74 . S IBNMC=$TR(IBNMC,".") D NAMECOMP^XLFNAME(.IBNMC)
     75 . S IBNM=$G(IBNMC("FAMILY"))_U_$G(IBNMC("GIVEN"))_U_$G(IBNMC("MIDDLE"))_U_IBCRED_U_$G(IBNMC("SUFFIX"))
     76 D STDNAME^XLFNAME(.IBNMC,"C")
     77 S IBNM=$G(IBNMC("FAMILY"))_U_$G(IBNMC("GIVEN"))_U_$G(IBNMC("MIDDLE"))_U_IBCRED_U_$G(IBNMC("SUFFIX"))
     78 I $P(IBNM1,U,2)["355.93",$P($G(^IBA(355.93,+$P(IBNM1,U,2),0)),U,2)=1 D  G NAMEQ  ; group performing provider
     79 . S IBNM=$P(IBNM1,U)_U_U_U_IBCRED_U
     80 I $G(COMB)=1,$G(IBNMC("MIDDLE"))'="" S IBNM=$P(IBNM,U)_U_$P(IBNM,U,2)_" "_$P(IBNM,U,3)_U_IBCRED_U_$P(IBNM,U,5)
     81 I $G(COMB)=2,$G(IBNMC("MIDDLE"))'="" S IBNM=$P(IBNM,U)_" "_$P(IBNM,U,3)_U_$P(IBNM,U,2)_U_IBCRED_U_$P(IBNM,U,5)
     82 ;
     83NAMEQ Q IBNM
     84 ;
     85DOLLAR(AMT) ; Format amount in AMT so it is numeric including cents, without
     86 ; the decimal and commas.
     87 N DOLR,CENT
     88 I AMT'="" S DOLR=$P(AMT,"."),CENT=$E($P(AMT,".",2)_"00",1,2),AMT=DOLR_CENT
     89 Q $TR(AMT,",")
     90 ;
     91STATE(CODE) ;Return state code from state pointer
     92 Q $P($G(^DIC(5,+CODE,0)),U,2)
     93 ;
     94SEX(CODE) ;Return the X12 code for sex
     95 ; CODE = DHCP code for sex
     96 Q $S(CODE="":"U","MF"[$E(CODE):$E(CODE),1:"U")
     97 ;
     98RELATION(CODE) ;Return the X12 code for relationship
     99 ; CODE = DHCP code for relationship
     100 N X12
     101 S X12=""
     102 S:CODE'="" X12=$P($S(CODE="01":"18^SELF",CODE="02":"01^SPOUSE",CODE="03":"19^NATURAL CHILD",CODE="08":"20^EMPLOYEE",CODE="32":"32^MOTHER",CODE="33":"33^FATHER",CODE="11":"39^ORGAN DONOR",CODE="15":"41^INJURED PLAINTIFF",1:""),U)
     103 Q X12
     104 ;
     105EMPLST(CODE) ;Return the X12 code for employment status
     106 ; CODE = DHCP code for employment status
     107 N X12
     108 S X12=""
     109 S:CODE'="" X12=$P($P("1;FT^2;PT^3;NE^4;SE^5;RT^6;AU^9;UK",CODE_";",2),U)
     110 S:X12="" X12="UK"
     111 Q X12
     112 ;
     113MARITAL(CODE) ;Return the X12 code for marital status
     114 ; CODE = ien of code for marital status
     115 N X12
     116 S X12=$P($G(^DIC(11,+CODE,0)),U,3)
     117 I X12'="" S X12=$P($P("D;D^M;M^N;I^S;X^W;W^U;K",X12_";",2),U)
     118 Q X12
     119 ;
     120TOS(CODE) ;Return the X12 code for type of service
     121 ; CODE = DHCP code for type of service
     122 N X12
     123 S X12=$S(CODE>0&(CODE<10):CODE,1:$P($P("0;10^A;11^B;13^H;45^L;18^M;15^N;63^V;19^Y;20^Z;21^43;96^53;96",CODE_";",2),U)) S:X12="" X12=CODE
     124 Q X12
     125 ;
     126FIXLEN(DATA,LEN) ; Create a fixed length field from data DATA length LEN
     127 Q $E(DATA_$J("",LEN),1,LEN)
     128 ;
     129RCDT(IBXSAVE,IBXDATA,IBDT) ; Format date for multiple revenue code transmission)
     130 ;IBXSAVE = array containing the extracted service line data for the UB format bill
     131 ;IBXDATA = array returned with service line dates formatted in YYYYMMDD format
     132 ;IBDT = the default date for the revenue codes on the bill
     133 N Q,W
     134 S Q=0 F  S Q=$O(IBXSAVE("INPT",Q)) Q:'Q  S W=$$DT($P(IBXSAVE("INPT",1),U,10),,"D8"),IBXDATA(Q)=$S(W:W,1:IBDT)
     135 Q

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEM.m

    r613 r623  
    1 IBCEM   ;ALB/TMP - 837 EDI RETURN MESSAGE PROCESSING ;17-APR-96
    2         ;;2.0;INTEGRATED BILLING;**137,191,155,371**;21-MAR-94;Build 57
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         Q
    5         ;
    6 UPD     ; Update messages manually from messages list
    7         N IBDA,IBOK,IBTDA,ZTSK,IBTSK,IBTYP,IBU,IBU1,IB0
    8         D FULL^VALM1
    9         D SEL(.IBDA,1)
    10         S IBDA=$O(IBDA(""))
    11         I IBDA="" G UPDQ
    12         S IBTDA=+IBDA(IBDA)
    13         I '$$LOCK(IBTDA) G UPDQ
    14         S IB0=$G(^IBA(364.2,IBTDA,0))
    15         ;
    16         I IB0="" D  G UPDQ
    17         . W !,*7,"Message ",IBDA," is no longer in return message file" S IBOK=""
    18         . D PAUSE^VALM1
    19         I $P(IB0,U,11) S IBOK=1 D  G:'IBOK UPDQ
    20         . N ZTSK
    21         . S ZTSK=$P(IB0,U,11) D STAT^%ZTLOAD Q:ZTSK(0)=0  ;Task not scheduled
    22         . I "12"[ZTSK(1) W *7,!,"This message has already been scheduled for update.  Task # is: ",$P(IB0,U,11) S IBOK="" D PAUSE^VALM1
    23         ;
    24         I $P(IB0,U,6)=""!("UP"'[$P(IB0,U,6)) D  G UPDQ
    25         . W !,*7,"Message status ("_$$EXPAND^IBTRE(364.2,.06,$P(IB0,U,6))_") is not appropriate for this action"
    26         . D PAUSE^VALM1
    27         ;
    28         S IBTYP=$P($G(^IBE(364.3,+$P(IB0,U,2),0)),U)
    29         S IBU=$S(IBTYP="REPORT":"MAILIT^IBCESRV2",IBTYP["837REC":"CON837^IBCESRV2",IBTYP["837REJ":"REJ837^IBCESRV2",IBTYP["835EOB":"EOB835^IBCESRV3",1:""),IBU1=$S(IBTYP["837":$E(IBTYP,$L(IBTYP)),1:2)
    30         I IBU="" W !,*7,"This message has an invalid message type - can't update" D PAUSE^VALM1 G UPDQ
    31         S IBTSK=$$TASK(IBU,$P(IB0,U,4),IBTDA,IBU1)
    32         I IBTSK W !,"Update has been tasked (#",IBTSK,")"
    33         I 'IBTSK W !,*7,"Update could not be tasked.  Please try again later!!!"
    34         D PAUSE^VALM1
    35         ;
    36         D BLD^IBCEM1
    37 UPDQ    I $G(IBTDA) L -^IBA(364.2,IBTDA,0)
    38         S VALMBCK="R"
    39         Q
    40         ;
    41 VP      ; View/Print Return Messages
    42         N DHD,DIC,FLDS,BY,FR,TO,DIR,Y,L,IBDA,IBTDA,IBBILLS
    43         D FULL^VALM1,SEL(.IBDA,1)
    44         S IBDA=$O(IBDA(""))
    45         G:'IBDA VPQ
    46         S IBTDA=$G(IBDA(IBDA)),IBBILLS=""
    47         I $P($G(^IBA(364.2,IBTDA,0)),U,4),'$P(^(0),U,5) D
    48         .S DIR(0)="YA",DIR("B")="NO",DIR("A")="Do you want to list all bills for this batch?: " D ^DIR K DIR
    49         .I Y S IBBILLS=1
    50         S DHD=$S(IBBILLS:"[IBCEM MESSAGE LIST HDR]",1:""),DIC="^IBA(364.2,",FLDS=$S(IBBILLS:"[IBCEM MESSAGE LIST]",1:"[CAPTIONED]"),BY="@NUMBER",(FR,TO)=$G(IBDA(IBDA)),L=0 D EN1^DIP
    51         D PAUSE^VALM1
    52 VPQ     S VALMBCK="R"
    53         Q
    54         ;
    55 SEL(IBDA,ONE)   ; Select entry(s) from list
    56         ; IBDA = array returned if selections made
    57         ;    IBDA(n)=ien of bill selected in file 399
    58         ; ONE = if set to 1, only one selection can be made at a time
    59         N IB
    60         K IBDA
    61         D EN^VALM2($G(XQORNOD(0)),$S('$G(ONE):"",1:"S"))
    62         S IBDA=0 F  S IBDA=$O(VALMY(IBDA)) Q:'IBDA  S IB=$G(^TMP("IBCEM-837DX",$J,IBDA)),IBDA(IBDA)=+$P(IB,U,2)
    63         Q
    64         ;
    65 UPDEDI(IBDA,FUNC,NOCT)  ; Update EDI files - cancel/resubmit/print as
    66         ;   resolution to message
    67         ; IBDA = transmit bill ien # for bill
    68         ; FUNC = "E" for edit/resubmit, "C" for cancel, "R" for resubmit not
    69         ;       from edit, "P" for print, "Z" for COB processed , "N" for no
    70         ;       further action needed-close record
    71         ; NOCT = 1 if not necessary to update batch count, 0 if update needed
    72         ;
    73         N IB0,IBBA,IBBDA,IBCT,IBM,IBTDA,IBNEW,DA,DIE,DR,Z,IBTEXT,IBZ,IBIFN,IBSTAT
    74         S IB0=$G(^IBA(364,+IBDA,0)),IBBA=$P(IB0,U,2)
    75         Q:IB0=""  S IBIFN=+IB0
    76         ;
    77         S IBNEW=$S(FUNC="E"!(FUNC="R"):+$P($G(^IBA(364,+$$LAST364^IBCEF4(+IB0),0)),U,2),1:"") S:IBNEW=IBBA IBNEW=""
    78         ;
    79         S IBSTAT=$P(IB0,U,3)                ; current status in file 364
    80         I '$F(".C.R.E.Z.","."_IBSTAT_".") D   ; don't update if in final status
    81         . S DR=".03////"_$S(FUNC="E":"R","NP"'[FUNC:FUNC,1:"Z")_";.04///NOW" S:FUNC="E"!(FUNC="R") DR=DR_$S(IBNEW:";.06////"_IBNEW,1:"")
    82         . S DA=+IBDA,DIE="^IBA(364," D ^DIE ;Update the transmit bill record
    83         . Q
    84         ;
    85         I IBBA D CKRES^IBCESRV2(IBBA) ;Update completely resubmitted flags
    86         ;
    87         I IBBA,(FUNC="P"!(IBNEW&'$G(NOCT))) D CTDOWN^IBCEM02(IBBA,1) ;If resubmitted in a new batch or printed, update old batch
    88         ;
    89         S IBTEXT(1)=" UPDATED BY: "_$$EXTERNAL^DILFD(361.02,.02,,+$G(DUZ))
    90         S IBTEXT(2)="ACTION USED: "_$S(FUNC="E":"BILL EDITED/RESUBMITTED",FUNC="C":"BILL CANCELED",FUNC="R":"BILL RESUBMITTED WITHOUT EDIT",FUNC="P":"PRINT BILL",FUNC="Z":"PROCESS COB",1:"")
    91         S IBTEXT(2)=$S(IBTEXT(2)="":"UNSPECIFIED",1:IBTEXT(2)_" - REVIEW MARKED AS COMPLETE")
    92         S IBTEXT=2
    93         ;
    94         ; Update file 361
    95         S IBZ=0 F  S IBZ=$O(^IBM(361,"AERR",+IBDA,IBZ)) Q:'IBZ  I $D(^IBM(361,IBZ,0)),$P(^(0),U,10)="",$P(^(0),U,9)<2 D
    96         . S DIE="^IBM(361,",DR=".09////2;.1////"_$TR(FUNC,"RCEIBZPN","RCROOFOO"),DA=IBZ D ^DIE
    97         . I FUNC'="","ECRPIBZ"[FUNC D  ; Update review status, notes for message
    98         .. D NOTECHG^IBCECSA2(IBZ,1,.IBTEXT)
    99         ;
    100         ; Update file 361.1 with the Cancel Status, to cancel All EOB's on file
    101         I FUNC="C" D STAT^IBCEMU2(IBIFN,9,0)
    102         ;
    103         Q
    104         ;
    105 DEL     ; Delete messages from messages list - locked with IB SUPERVISOR key
    106         N IBDA,IBOK,IBTDA,IBTYP,IBU,IBU1,IB0,DIR,IBT,IBE,Z,X,Y,XMSUBJ,XMTO,XMBODY,XMDUZ
    107         D FULL^VALM1
    108         S IBTDA=0
    109         I '$D(^XUSEC("IB SUPERVISOR",DUZ)) D  G DELQ
    110         . W !,"You don't have authority to use this action. See your supervisr for assistance"
    111         . D PAUSE^VALM1
    112         D SEL(.IBDA,1)
    113         S IBDA=$O(IBDA(""))
    114         I IBDA="" G DELQ
    115         W !
    116         S DIR(0)="YA",DIR("A",1)="This action will PERMANENTLY delete a return message from your system",DIR("A",2)="A bulletin will be sent to report the deletion",DIR("A",3)=" "
    117         S DIR("A")="ARE YOU SURE YOU WANT TO CONTINUE? ",DIR("B")="NO"
    118         D ^DIR K DIR
    119         G:Y'=1 DELQ
    120         S IBTDA=+IBDA(IBDA)
    121         I '$$LOCK(IBTDA) G DELQ
    122         S IB0=$G(^IBA(364.2,IBTDA,0))
    123         ;
    124         I $P(IB0,U,11) S IBOK=1 D  G:'IBOK DELQ
    125         . N ZTSK
    126         . S ZTSK=$P(IB0,U,11) D STAT^%ZTLOAD Q:ZTSK(0)=0  ;Task not scheduled
    127         . I "12"[ZTSK(1) W *7,!,"This message is currently scheduled for update.  Task # is: ",$P(IB0,U,11) S IBOK="" D PAUSE^VALM1
    128         ;
    129         I $P(IB0,U,6)=""!("UP"'[$P(IB0,U,6)) D  G DELQ
    130         . W !,*7,"Message status ("_$$EXPAND^IBTRE(364.2,.06,$P(IB0,U,6))_") is not appropriate for this action"
    131         . D PAUSE^VALM1
    132         ;
    133         S DIR(0)="YA",DIR("A",1)=" ",DIR("A",2)="",$P(DIR("A",2),"*",54)="",DIR("A",3)="* This message is about to be PERMANENTLY deleted!! *",DIR("A",4)=DIR("A",2),DIR("A",5)=" "
    134         S DIR("A")="ARE YOU STILL SURE YOU WANT TO CONTINUE? ",DIR("B")="NO"
    135         W ! D ^DIR W ! K DIR
    136         I Y'=1 W !!,"Nothing deleted" D PAUSE^VALM1 G DELQ
    137         ;
    138         K ^TMP("IBMSG",$J)
    139         M ^TMP("IBMSG",$J)=^IBA(364.2,IBTDA)
    140         D DELMSG^IBCESRV2(IBTDA)
    141         I $D(^IBA(364.2,IBTDA)) D  G DELQ
    142         . W !,"Message not deleted - problem with delete" D PAUSE^VALM1
    143         ;
    144         S IBT(1)="EDI return message #"_$P(IB0,U)_" has been deleted"
    145         S IBT(2)=" "
    146         S IBT(3)="DELETED BY: "_$P($G(^VA(200,+$G(DUZ),0)),U)_"   "_$$FMTE^XLFDT($$NOW^XLFDT,2)
    147         S Z=$$EXPAND^IBTRE(364.2,.06,$P(IB0,U,6)) S:Z="" Z="??"
    148         S IBT(4)="    STATUS: "_$E(Z_$J("",11),1,11)_"  MESSAGE TYPE: "_$P($G(^IBE(364.3,+$P(IB0,U,2),0)),U,5)
    149         S IBT(5)=" MESSAGE #: "_$E($P(IB0,U)_$J("",11),1,11)_"   STATUS DATE: "_$$FMTE^XLFDT($P($G(^TMP("IBMSG",$J,1)),U,3))
    150         S IBT(6)="   BATCH #: "_$E($P($G(^IBA(364.1,+$P(IB0,U,4),0)),U)_$J("",11),1,11)_"        BILL #: "_$$EXPAND^IBTRE(364.2,.05,$P(IB0,U,5))
    151         S IBT(7)=" "
    152         S IBT(8)="MESSAGE TEXT:",IBE=8
    153         S Z=0 F  S Z=$O(^TMP("IBMSG",$J,2,Z)) Q:'Z  S IBE=IBE+1,IBT(IBE)=$G(^(Z,0))
    154         S XMSUBJ="EDI MESSAGE DELETED",XMBODY="IBT",XMDUZ="",XMTO("I:G.IB EDI")=""
    155         D SENDMSG^XMXAPI(XMDUZ,XMSUBJ,XMBODY,.XMTO,,.XMZ)
    156         ;
    157         K ^TMP("IBMSG",$J)
    158         ;
    159         W !,"A bulletin has been sent to report this deletion",!
    160         D PAUSE^VALM1
    161         ;
    162         D BLD^IBCEM1
    163 DELQ    L -^IBA(364.2,IBTDA,0)
    164         S VALMBCK="R"
    165         Q
    166         ;
    167 TASK(IBRTN,IBBDA,IBTDA,IBTYP)   ; Schedule the task to update data base from message
    168         ; IBRTN = routine to task
    169         ; IBBDA = batch # associated with the message (OPTIONAL)
    170         ; IBTDA = internal entry of message
    171         ; IBTYP = the number that is the last digit in the message type
    172         ;
    173         N ZTSK,ZTDESC,ZTIO,ZTDTH,ZTSAVE,DA,DR,DIE
    174         S ZTIO="",ZTDTH=$H,ZTDESC="UPDATE DATA BASE FROM EDI RETURN MESSAGE",ZTSAVE("IB*")="",ZTRTN=IBRTN
    175         D ^%ZTLOAD
    176         I $G(ZTSK),$G(^IBA(364.2,IBTDA,0)) S DIE="^IBA(364.2,",DR=".11////"_ZTSK_";.06////U",DA=IBTDA D ^DIE
    177         Q $G(ZTSK)
    178         ;
    179 LOCK(IBTDA)     ; Attempt to lock message file entry IBTDA
    180         ; Return 1 if successful, 0 if not able to lock
    181         ;
    182         N OK
    183         S OK=1
    184         L +^IBA(364.2,IBTDA,0):5
    185         I '$T D
    186         . I '$D(DIQUIET) W !,*7,"Another user is editing this entry ... try again later" D PAUSE^VALM1
    187         . S IBDA="",OK=0
    188         Q OK
    189         ;
     1IBCEM ;ALB/TMP - 837 EDI RETURN MESSAGE PROCESSING ;17-APR-96
     2 ;;2.0;INTEGRATED BILLING;**137,191,155**;21-MAR-94
     3 Q
     4 ;
     5UPD ; Update messages manually from messages list
     6 N IBDA,IBOK,IBTDA,ZTSK,IBTSK,IBTYP,IBU,IBU1,IB0
     7 D FULL^VALM1
     8 D SEL(.IBDA,1)
     9 S IBDA=$O(IBDA(""))
     10 I IBDA="" G UPDQ
     11 S IBTDA=+IBDA(IBDA)
     12 I '$$LOCK(IBTDA) G UPDQ
     13 S IB0=$G(^IBA(364.2,IBTDA,0))
     14 ;
     15 I IB0="" D  G UPDQ
     16 . W !,*7,"Message ",IBDA," is no longer in return message file" S IBOK=""
     17 . D PAUSE^VALM1
     18 I $P(IB0,U,11) S IBOK=1 D  G:'IBOK UPDQ
     19 . N ZTSK
     20 . S ZTSK=$P(IB0,U,11) D STAT^%ZTLOAD Q:ZTSK(0)=0  ;Task not scheduled
     21 . I "12"[ZTSK(1) W *7,!,"This message has already been scheduled for update.  Task # is: ",$P(IB0,U,11) S IBOK="" D PAUSE^VALM1
     22 ;
     23 I $P(IB0,U,6)=""!("UP"'[$P(IB0,U,6)) D  G UPDQ
     24 . W !,*7,"Message status ("_$$EXPAND^IBTRE(364.2,.06,$P(IB0,U,6))_") is not appropriate for this action"
     25 . D PAUSE^VALM1
     26 ;
     27 S IBTYP=$P($G(^IBE(364.3,+$P(IB0,U,2),0)),U)
     28 S IBU=$S(IBTYP="REPORT":"MAILIT^IBCESRV2",IBTYP["837REC":"CON837^IBCESRV2",IBTYP["837REJ":"REJ837^IBCESRV2",IBTYP["835EOB":"EOB835^IBCESRV3",1:""),IBU1=$S(IBTYP["837":$E(IBTYP,$L(IBTYP)),1:2)
     29 I IBU="" W !,*7,"This message has an invalid message type - can't update" D PAUSE^VALM1 G UPDQ
     30 S IBTSK=$$TASK(IBU,$P(IB0,U,4),IBTDA,IBU1)
     31 I IBTSK W !,"Update has been tasked (#",IBTSK,")"
     32 I 'IBTSK W !,*7,"Update could not be tasked.  Please try again later!!!"
     33 D PAUSE^VALM1
     34 ;
     35 D BLD^IBCEM1
     36UPDQ I $G(IBTDA) L -^IBA(364.2,IBTDA,0)
     37 S VALMBCK="R"
     38 Q
     39 ;
     40VP ; View/Print Return Messages
     41 N DHD,DIC,FLDS,BY,FR,TO,DIR,Y,L,IBDA,IBTDA,IBBILLS
     42 D FULL^VALM1,SEL(.IBDA,1)
     43 S IBDA=$O(IBDA(""))
     44 G:'IBDA VPQ
     45 S IBTDA=$G(IBDA(IBDA)),IBBILLS=""
     46 I $P($G(^IBA(364.2,IBTDA,0)),U,4),'$P(^(0),U,5) D
     47 .S DIR(0)="YA",DIR("B")="NO",DIR("A")="Do you want to list all bills for this batch?: " D ^DIR K DIR
     48 .I Y S IBBILLS=1
     49 S DHD=$S(IBBILLS:"[IBCEM MESSAGE LIST HDR]",1:""),DIC="^IBA(364.2,",FLDS=$S(IBBILLS:"[IBCEM MESSAGE LIST]",1:"[CAPTIONED]"),BY="@NUMBER",(FR,TO)=$G(IBDA(IBDA)),L=0 D EN1^DIP
     50 D PAUSE^VALM1
     51VPQ S VALMBCK="R"
     52 Q
     53 ;
     54SEL(IBDA,ONE) ; Select entry(s) from list
     55 ; IBDA = array returned if selections made
     56 ;    IBDA(n)=ien of bill selected in file 399
     57 ; ONE = if set to 1, only one selection can be made at a time
     58 N IB
     59 K IBDA
     60 D EN^VALM2($G(XQORNOD(0)),$S('$G(ONE):"",1:"S"))
     61 S IBDA=0 F  S IBDA=$O(VALMY(IBDA)) Q:'IBDA  S IB=$G(^TMP("IBCEM-837DX",$J,IBDA)),IBDA(IBDA)=+$P(IB,U,2)
     62 Q
     63 ;
     64UPDEDI(IBDA,FUNC,NOCT) ; Update EDI files - cancel/resubmit/print as
     65 ;   resolution to message
     66 ; IBDA = transmit bill ien # for bill
     67 ; FUNC = "E" for edit/resubmit, "C" for cancel, "R" for resubmit not
     68 ;       from edit, "P" for print, "Z" for COB processed , "N" for no
     69 ;       further action needed-close record
     70 ; NOCT = 1 if not necessary to update batch count, 0 if update needed
     71 ;
     72 N IB0,IBBA,IBBDA,IBCT,IBM,IBTDA,IBNEW,DA,DIE,DR,Z,IBTEXT,IBZ,IBIFN,IBSTAT
     73 S IB0=$G(^IBA(364,+IBDA,0)),IBBA=$P(IB0,U,2)
     74 Q:IB0=""  S IBIFN=+IB0
     75 ;
     76 S IBNEW=$S(FUNC="E"!(FUNC="R"):+$P($G(^IBA(364,+$$LAST364^IBCEF4(+IB0),0)),U,2),1:"") S:IBNEW=IBBA IBNEW=""
     77 ;
     78 S IBSTAT=$P(IB0,U,3)                ; current status in file 364
     79 I '$F(".C.R.E.Z.","."_IBSTAT_".") D   ; don't update if in final status
     80 . S DR=".03////"_$S(FUNC="E":"R","NP"'[FUNC:FUNC,1:"Z")_";.04///NOW" S:FUNC="E"!(FUNC="R") DR=DR_$S(IBNEW:";.06////"_IBNEW,1:"")
     81 . S DA=+IBDA,DIE="^IBA(364," D ^DIE ;Update the transmit bill record
     82 . Q
     83 ;
     84 I IBBA D CKRES^IBCESRV2(IBBA) ;Update completely resubmitted flags
     85 ;
     86 I IBBA,(FUNC="P"!(IBNEW&'$G(NOCT))) D CTDOWN^IBCEM02(IBBA,1) ;If resubmitted in a new batch or printed, update old batch
     87 ;
     88 S IBTEXT(1)=" UPDATED BY: "_$$EXTERNAL^DILFD(361.02,.02,,+$G(DUZ))
     89 S IBTEXT(2)="ACTION USED: "_$S(FUNC="E":"BILL EDITED/RESUBMITTED",FUNC="C":"BILL CANCELED",FUNC="R":"BILL RESUBMITTED WITHOUT EDIT)",FUNC="P":"PRINT BILL",FUNC="Z":"PROCESS COB",1:"")
     90 S IBTEXT(2)=$S(IBTEXT(2)="":"UNSPECIFIED",1:IBTEXT(2)_" - REVIEW MARKED AS COMPLETE")
     91 S IBTEXT=2
     92 ;
     93 ; Update file 361
     94 S IBZ=0 F  S IBZ=$O(^IBM(361,"AERR",+IBDA,IBZ)) Q:'IBZ  I $D(^IBM(361,IBZ,0)),$P(^(0),U,10)="",$P(^(0),U,9)<2 D
     95 . S DIE="^IBM(361,",DR=".09////2;.1////"_$TR(FUNC,"RCEIBZPN","RCROOFOO"),DA=IBZ D ^DIE
     96 . I FUNC'="","ECRPIBZ"[FUNC D  ; Update review status, notes for message
     97 .. D NOTECHG^IBCECSA2(IBZ,1,.IBTEXT)
     98 ;
     99 ; Update file 361.1 with the Cancel Status, to cancel All EOB's on file
     100 I FUNC="C" D STAT^IBCEMU2(IBIFN,9,0)
     101 ;
     102 Q
     103 ;
     104DEL ; Delete messages from messages list - locked with IB SUPERVISOR key
     105 N IBDA,IBOK,IBTDA,IBTYP,IBU,IBU1,IB0,DIR,IBT,IBE,Z,X,Y,XMSUBJ,XMTO,XMBODY,XMDUZ
     106 D FULL^VALM1
     107 S IBTDA=0
     108 I '$D(^XUSEC("IB SUPERVISOR",DUZ)) D  G DELQ
     109 . W !,"You don't have authority to use this action. See your supervisr for assistance"
     110 . D PAUSE^VALM1
     111 D SEL(.IBDA,1)
     112 S IBDA=$O(IBDA(""))
     113 I IBDA="" G DELQ
     114 W !
     115 S DIR(0)="YA",DIR("A",1)="This action will PERMANENTLY delete a return message from your system",DIR("A",2)="A bulletin will be sent to report the deletion",DIR("A",3)=" "
     116 S DIR("A")="ARE YOU SURE YOU WANT TO CONTINUE? ",DIR("B")="NO"
     117 D ^DIR K DIR
     118 G:Y'=1 DELQ
     119 S IBTDA=+IBDA(IBDA)
     120 I '$$LOCK(IBTDA) G DELQ
     121 S IB0=$G(^IBA(364.2,IBTDA,0))
     122 ;
     123 I $P(IB0,U,11) S IBOK=1 D  G:'IBOK DELQ
     124 . N ZTSK
     125 . S ZTSK=$P(IB0,U,11) D STAT^%ZTLOAD Q:ZTSK(0)=0  ;Task not scheduled
     126 . I "12"[ZTSK(1) W *7,!,"This message is currently scheduled for update.  Task # is: ",$P(IB0,U,11) S IBOK="" D PAUSE^VALM1
     127 ;
     128 I $P(IB0,U,6)=""!("UP"'[$P(IB0,U,6)) D  G DELQ
     129 . W !,*7,"Message status ("_$$EXPAND^IBTRE(364.2,.06,$P(IB0,U,6))_") is not appropriate for this action"
     130 . D PAUSE^VALM1
     131 ;
     132 S DIR(0)="YA",DIR("A",1)=" ",DIR("A",2)="",$P(DIR("A",2),"*",54)="",DIR("A",3)="* This message is about to be PERMANENTLY deleted!! *",DIR("A",4)=DIR("A",2),DIR("A",5)=" "
     133 S DIR("A")="ARE YOU STILL SURE YOU WANT TO CONTINUE? ",DIR("B")="NO"
     134 W ! D ^DIR W ! K DIR
     135 I Y'=1 W !!,"Nothing deleted" D PAUSE^VALM1 G DELQ
     136 ;
     137 K ^TMP("IBMSG",$J)
     138 M ^TMP("IBMSG",$J)=^IBA(364.2,IBTDA)
     139 D DELMSG^IBCESRV2(IBTDA)
     140 I $D(^IBA(364.2,IBTDA)) D  G DELQ
     141 . W !,"Message not deleted - problem with delete" D PAUSE^VALM1
     142 ;
     143 S IBT(1)="EDI return message #"_$P(IB0,U)_" has been deleted"
     144 S IBT(2)=" "
     145 S IBT(3)="DELETED BY: "_$P($G(^VA(200,+$G(DUZ),0)),U)_"   "_$$FMTE^XLFDT($$NOW^XLFDT,2)
     146 S Z=$$EXPAND^IBTRE(364.2,.06,$P(IB0,U,6)) S:Z="" Z="??"
     147 S IBT(4)="    STATUS: "_$E(Z_$J("",11),1,11)_"  MESSAGE TYPE: "_$P($G(^IBE(364.3,+$P(IB0,U,2),0)),U,5)
     148 S IBT(5)=" MESSAGE #: "_$E($P(IB0,U)_$J("",11),1,11)_"   STATUS DATE: "_$$FMTE^XLFDT($P($G(^TMP("IBMSG",$J,1)),U,3))
     149 S IBT(6)="   BATCH #: "_$E($P($G(^IBA(364.1,+$P(IB0,U,4),0)),U)_$J("",11),1,11)_"        BILL #: "_$$EXPAND^IBTRE(364.2,.05,$P(IB0,U,5))
     150 S IBT(7)=" "
     151 S IBT(8)="MESSAGE TEXT:",IBE=8
     152 S Z=0 F  S Z=$O(^TMP("IBMSG",$J,2,Z)) Q:'Z  S IBE=IBE+1,IBT(IBE)=$G(^(Z,0))
     153 S XMSUBJ="EDI MESSAGE DELETED",XMBODY="IBT",XMDUZ="",XMTO("I:G.IB EDI")=""
     154 D SENDMSG^XMXAPI(XMDUZ,XMSUBJ,XMBODY,.XMTO,,.XMZ)
     155 ;
     156 K ^TMP("IBMSG",$J)
     157 ;
     158 W !,"A bulletin has been sent to report this deletion",!
     159 D PAUSE^VALM1
     160 ;
     161 D BLD^IBCEM1
     162DELQ L -^IBA(364.2,IBTDA,0)
     163 S VALMBCK="R"
     164 Q
     165 ;
     166TASK(IBRTN,IBBDA,IBTDA,IBTYP) ; Schedule the task to update data base from message
     167 ; IBRTN = routine to task
     168 ; IBBDA = batch # associated with the message (OPTIONAL)
     169 ; IBTDA = internal entry of message
     170 ; IBTYP = the number that is the last digit in the message type
     171 ;
     172 N ZTSK,ZTDESC,ZTIO,ZTDTH,ZTSAVE,DA,DR,DIE
     173 S ZTIO="",ZTDTH=$H,ZTDESC="UPDATE DATA BASE FROM EDI RETURN MESSAGE",ZTSAVE("IB*")="",ZTRTN=IBRTN
     174 D ^%ZTLOAD
     175 I $G(ZTSK),$G(^IBA(364.2,IBTDA,0)) S DIE="^IBA(364.2,",DR=".11////"_ZTSK_";.06////U",DA=IBTDA D ^DIE
     176 Q $G(ZTSK)
     177 ;
     178LOCK(IBTDA) ; Attempt to lock message file entry IBTDA
     179 ; Return 1 if successful, 0 if not able to lock
     180 ;
     181 N OK
     182 S OK=1
     183 L +^IBA(364.2,IBTDA,0):5
     184 I '$T D
     185 . I '$D(DIQUIET) W !,*7,"Another user is editing this entry ... try again later" D PAUSE^VALM1
     186 . S IBDA="",OK=0
     187 Q OK
     188 ;

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEM4.m

    r613 r623  
    1 IBCEM4  ;ALB/TMP - IB ELECTRONIC MESSAGE SCREEN TEXT MAINT ;19-APR-2001
    2         ;;2.0;INTEGRATED BILLING;**137,368**;21-MAR-1994;Build 21
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5 EN      ; entry point for maintenance
    6         D EN^VALM("IBCE MESSAGE TEXT MAIN")
    7         Q
    8         ;
    9 HDR     ; Header code
    10         K VALMHDR
    11         Q
    12         ;
    13 INIT    ; Build list of text entries
    14         N Z,Z0
    15         S (IBCNT,VALMCNT)=0,VALMBG=1
    16         K ^TMP("IBCEMSGT",$J)
    17         S Z="" F  S Z=$O(^IBE(361.3,"AC",Z),-1) Q:Z=""  D SET(Z) S Z0="" F  S Z0=$O(^IBE(361.3,"AC",Z,Z0)) Q:Z0=""  D SET(Z,Z0)
    18         Q
    19         ;
    20 EXIT    ; -- Clean up list
    21         K ^TMP("IBCEMSGT",$J)
    22         D CLEAN^VALM10
    23         Q
    24         ;
    25 SET(Z,Z0)       ; Set data into display global
    26         N X,IB
    27         S IBCNT=IBCNT+1,X="",IB=""
    28         S:$G(Z0)'="" Z0="    "_Z0
    29         I $G(Z0)="" D
    30         . S Z0=$S('Z:"*** DO NOT REQUIRE REVIEW ***",1:"*** REQUIRE REVIEW ***"),IB=$J("",(80-$L(Z0))\2),Z0=IB_Z0
    31         . I 'Z D SET(Z," ")
    32         I Z0'="" S X=$$SETFLD^VALM1(Z0,X,"TEXT")
    33         S VALMCNT=VALMCNT+1,^TMP("IBCEMSGT",$J,VALMCNT,0)=X
    34         S ^TMP("IBCEMSGT",$J,"IDX",VALMCNT,IBCNT)=""
    35         I IB'="" D CNTRL^VALM10(VALMCNT,2+$L(IB),$L(Z0)-$L(IB),IORVON,IORVOFF)
    36         Q
    37 EDIT    ; Add/edit message text
    38         N DA,DIC,DLAYGO,DIE,DR,DIR,X,Y,IBUPD,IBSTOP,IBY
    39         D FULL^VALM1
    40         S (IBSTOP,IBUPD)=0
    41         F  D  Q:IBSTOP
    42         . S DIC(0)="AELMQ",DLAYGO=361.3,DIC="^IBE(361.3,",DIC("DR")="@1;.02;I X="""" W !,""MUST HAVE A VALUE FOR THIS FIELD"" S Y=""@1""" W ! D ^DIC
    43         . S IBY=Y
    44         . I IBY'>0 S IBSTOP=1 Q
    45         . I $P(IBY,U,3) S IBUPD=1 Q
    46         . S DIC="^IBE(361.3,",DA=+IBY W ! D EN^DIQ W !
    47         . S DIE="^IBE(361.3,",DA=+IBY,DR=".01" D ^DIE ; edit
    48         . I '$D(^IBE(361.3,+IBY,0)) S IBUPD=1 Q
    49         . I $P(IBY,U,2)'=$P(^IBE(361.3,+IBY,0),U) S IBUPD=1,DIE="^IBE(361.3,",DR=".05////"_$G(DUZ)_";.06///^S X=""NOW""" D ^DIE
    50         D:IBUPD INIT
    51         S VALMBCK="R"
    52         Q
    53         ;
    54 CKREVU(IBTEXT,IBNR,IBSKIP,IBREV)        ; Check IBTEXT contains 'no review
    55         ;        needed' text
    56         ; IBNR = returned if passed by reference - 'no review needed' text found
    57         ; IBSKIP = 1 if no check needed for 'always review'
    58         ; IBREV = returned if passed by reference and 'review always needed'
    59         ;         text found
    60         ;
    61         N T,Y,Z,Z0
    62         S (IBREV,Y)=0,Z="",IBTEXT=$$UP^XLFSTR($G(IBTEXT))
    63         I '$G(IBSKIP) F  S Z=$O(^IBE(361.3,"AC",1,Z)) Q:Z=""  I IBTEXT[$$UP^XLFSTR(Z) S IBREV=1 Q  ; Always review messages with this text
    64         I 'IBREV S Z="" F  S Z=$O(^IBE(361.3,"AC",0,Z)) Q:Z=""  I IBTEXT[$$UP^XLFSTR(Z) S Y=1,IBNR=Z Q  ; Message contains text to make review unnecessary
    65         Q Y
    66         ;
    67 REPORT  ; Produce a report of messages filed without review by user-selected
    68         ; date range for date received and sort by either bill# or message text
    69         N IBFR,IBTO,IBSORT,DIR,DA,DR,X,Y,ZTSAVE,ZTRTN,ZTDESC,ZTREQ
    70 R1      S DIR("A")="FROM DATE RECEIVED: ",DIR(0)="DA^:"_DT_"::PAXE" D ^DIR K DIR
    71         Q:$D(DTOUT)!$D(DUOUT)
    72         S IBFR=Y W "   ",$G(Y(0))
    73 R2      S DIR("A")="TO DATE RECEIVED: ",DIR(0)="DAO^"_IBFR_":"_DT_"::PAE" D ^DIR K DIR
    74         Q:$D(DTOUT)!$D(DUOUT)
    75         I Y'>0 W ! G R1
    76         S IBTO=Y W "   ",$G(Y(0))
    77         S DIR("A")="SORT BY",DIR(0)="SXBO^B:Bill #;M:Message Screen Text",DIR("B")="B" D ^DIR K DIR
    78         Q:$D(DTOUT)!$D(DUOUT)
    79         I (Y="")!("BM"'[Y) W ! G R2
    80         S IBSORT=Y
    81         S %ZIS="QM" D ^%ZIS Q:POP
    82         I $D(IO("Q")) K IO("Q") S ZTRTN="ENRPT^IBCEM4",ZTSAVE("IB*")="",ZTDESC="IB - MESSAGES FILED WITHOUT REVIEW REPORT" D ^%ZTLOAD K ZTSK D HOME^%ZIS Q
    83         U IO
    84 ENRPT   ; Queued job entrypoint
    85         N IB,IB0,IBDA,IB00,IB1,IBS1,IBPAGE,IBLINES,IBHDRDT,IBSB,IBSTOP,DIR,Y,X,Z
    86         W:$E(IOST,1,2)["C-" @IOF ;Only initial form feed for print to screen
    87         K ^TMP($J,"IBSORT")
    88         S IB=IBFR-.000001
    89         F  S IB=$O(^IBM(361,"ARD",IB)) Q:'IB!$G(ZTSTOP)  S IBDA=0 F  S IBDA=$O(^IBM(361,"ARD",IB,IBDA)) Q:'IBDA!$G(ZTSTOP)  S IB0=$G(^IBM(361,IBDA,0)) Q:IB0=""!'$P(IB0,U,14)  D
    90         . I $D(ZTQUEUED) Q:$$STOP(.ZTREQ,.ZTSTOP)
    91         . S IBS1=""
    92         . I IBSORT="M" D  ; Find text that caused auto-file
    93         .. S Z=0 F  S Z=$O(^IBM(361,IBDA,1,Z)) Q:'Z  I $$CKREVU($G(^IBM(361,IBDA,1,Z,0)),.IBS1,1) Q
    94         .. I IBS1="" S IBS1="??"
    95         . I IBSORT="B" S IBS1=$P($G(^DGCR(399,+IB0,0)),U)
    96         . I IBS1'="" S ^TMP($J,"IBSORT",IBS1,IBDA)=IB0
    97         S IBHDRDT=$$FMTE^XLFDT($$NOW^XLFDT(),"2P")
    98         S (IBSTOP,IBLINES,IBPAGE)=0
    99         S IB1=1,IB="" F  S IB=$O(^TMP($J,"IBSORT",IB)) Q:IB=""!$G(ZTSTOP)  D  Q:IBSTOP
    100         . S IBSB=$S(IBSORT="M":"MESSAGE SCREEN TEXT: "_IB,1:"")
    101         . I IBSB'="" S IBSB=$J("",(80-$L(IBSB)\2))_IBSB
    102         . D:IB1 RHDR(IBSB,.IBSTOP) Q:IBSTOP
    103         . I 'IB1,IBSORT="M" D  Q:IBSTOP
    104         .. I IBLINES>(IOSL-5) D RHDR(IBSB,.IBSTOP) Q
    105         .. W !!,IBSB,! S IBLINES=IBLINES+3
    106         . S (IB1,IBDA)=0 F  S IBDA=$O(^TMP($J,"IBSORT",IB,IBDA)) Q:'IBDA!$G(ZTSTOP)  D  Q:IBSTOP
    107         .. I $D(ZTQUEUED),$$STOP(.ZTREQ,.ZTSTOP) W !,"*********** REPORT STOPPED BEFORE IT COMPLETED!!! ***********" Q
    108         .. S IB0=$G(^TMP($J,"IBSORT",IB,IBDA)),IB00=$G(^DGCR(399,+IB0,0))
    109         .. I $G(IBLINES)>(IOSL-5) D RHDR("",.IBSTOP) Q:IBSTOP
    110         .. W !,$E($$BN1^PRCAFN(+IB0)_$J("",10),1,10),"  ",$E($P($G(^DPT(+$P(IB00,U,2),0)),U)_$J("",25),1,25)_"  "_$E($$FMTE^XLFDT($P(IB00,U,3),"2D")_$J("",8),1,8)_"  "_$E($$FMTE^XLFDT($P(IB0,U,2),"2D")_$J("",8),1,8)_"  "
    111         .. W $E($P($G(^DIC(36,+$$POLICY^IBCEF(+IB0,1,$P(IB0,U,7)),0)),U),1,20)
    112         .. S IBLINES=IBLINES+1
    113         .. I $G(IBLINES)>(IOSL-5) D RHDR("",.IBSTOP) Q:IBSTOP
    114         .. S Z=0 F  S Z=$O(^IBM(361,IBDA,1,Z)) Q:'Z  D  Q:IBSTOP
    115         ... N Z0,Z1
    116         ... S Z0=$G(^IBM(361,IBDA,1,Z,0))
    117         ... F Z1=1:75:$L(Z0) D:$G(IBLINES)>(IOSL-5) RHDR("",.IBSTOP) Q:IBSTOP  W !,?5,$E(Z0,Z1,Z1+74) S IBLINES=IBLINES+1
    118         G:IBSTOP!$G(ZTSTOP) ENSTOP
    119         I $G(IB1) D RHDR("") W !,"NO RECORDS MATCHING SEARCH CRITERIA WERE FOUND",!
    120         ;
    121         I $E(IOST,1,2)["C-"  K DIR S DIR(0)="E" D ^DIR K DIR
    122 ENSTOP  I '$D(ZTQUEUED) D ^%ZISC
    123         I $D(ZTQUEUED),'$G(ZTSTOP) S ZTREQ="@"
    124         K ^TMP($J,"IBSORT")
    125         Q
    126         ;
    127 RHDR(IBSB,IBSTOP)       ; Report header
    128         ; IBSB'="" if sub header should print
    129         N Z,DIR,X,Y
    130         S IBPAGE=IBPAGE+1
    131         I IBPAGE>1,$E(IOST,1,2)["C-" S DIR(0)="E" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S IBSTOP=1 G RHDRQ
    132         W !,@IOF
    133         W !,?22,"MESSAGES FILED WITHOUT REVIEW REPORT",?65,"PAGE: ",IBPAGE
    134         S Z="RUN DATE: "_IBHDRDT W !,?(80-$L(Z)\2),Z
    135         S Z="DATE RECEIVED RANGE: "_$$FMTE^XLFDT(IBFR,"2D")_"-"_$$FMTE^XLFDT(IBTO,"2D") W !,?(80-$L(Z)\2),Z,!
    136         W !,$J("",40),"EVENT      DATE"
    137         W !,"BILL #      PATIENT NAME"_$J("",15)_" DATE     RECEIVED  INSURANCE CO",!
    138         S Z="",$P(Z,"-",81)="" W Z
    139         S IBLINES=7
    140         I $G(IBSB)'="" W !,IBSB,! S IBLINES=IBLINES+2
    141 RHDRQ   Q
    142         ;
    143 STOP(IBSTOP,IBREQ)      ; Check for job being stopped
    144         I $$S^%ZTLOAD S IBSTOP=1 K IBREQ
    145         Q $G(IBSTOP)
    146         ;
     1IBCEM4 ;ALB/TMP - IB ELECTRONIC MESSAGE SCREEN TEXT MAINT ;19-APR-2001
     2 ;;2.0;INTEGRATED BILLING;**137**;21-MAR-1994
     3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
     4 ;
     5EN ; entry point for maintenance
     6 D EN^VALM("IBCE MESSAGE TEXT MAIN")
     7 Q
     8 ;
     9HDR ; Header code
     10 K VALMHDR
     11 Q
     12 ;
     13INIT ; Build list of text entries
     14 N Z,Z0
     15 S (IBCNT,VALMCNT)=0,VALMBG=1
     16 K ^TMP("IBCEMSGT",$J)
     17 S Z="" F  S Z=$O(^IBE(361.3,"AC",Z),-1) Q:Z=""  D SET(Z) S Z0="" F  S Z0=$O(^IBE(361.3,"AC",Z,Z0)) Q:Z0=""  D SET(Z,Z0)
     18 Q
     19 ;
     20EXIT ; -- Clean up list
     21 K ^TMP("IBCEMSGT",$J)
     22 D CLEAN^VALM10
     23 Q
     24 ;
     25SET(Z,Z0) ; Set data into display global
     26 N X,IB
     27 S IBCNT=IBCNT+1,X="",IB=""
     28 S:$G(Z0)'="" Z0="    "_Z0
     29 I $G(Z0)="" D
     30 . S Z0=$S('Z:"*** DO NOT REQUIRE REVIEW ***",1:"*** REQUIRE REVIEW ***"),IB=$J("",(80-$L(Z0))\2),Z0=IB_Z0
     31 . I 'Z D SET(Z," ")
     32 I Z0'="" S X=$$SETFLD^VALM1(Z0,X,"TEXT")
     33 S VALMCNT=VALMCNT+1,^TMP("IBCEMSGT",$J,VALMCNT,0)=X
     34 S ^TMP("IBCEMSGT",$J,"IDX",VALMCNT,IBCNT)=""
     35 I IB'="" D CNTRL^VALM10(VALMCNT,2+$L(IB),$L(Z0)-$L(IB),IORVON,IORVOFF)
     36 Q
     37EDIT ; Add/edit message text
     38 N DA,DIC,DLAYGO,DIE,DR,DIR,X,Y,IBUPD,IBSTOP,IBY
     39 D FULL^VALM1
     40 S (IBSTOP,IBUPD)=0
     41 F  D  Q:IBSTOP
     42 . S DIC(0)="AELMQ",DLAYGO=361.3,DIC="^IBE(361.3,",DIC("DR")="@1;.02;I X="""" W !,""MUST HAVE A VALUE FOR THIS FIELD"" S Y=""@1""" W ! D ^DIC
     43 . S IBY=Y
     44 . I IBY'>0 S IBSTOP=1 Q
     45 . I $P(IBY,U,3) S IBUPD=1 Q
     46 . S DIC="^IBE(361.3,",DA=+IBY W ! D EN^DIQ W !
     47 . S DIE="^IBE(361.3,",DA=+IBY,DR=".01" D ^DIE ; edit
     48 . I '$D(^IBE(361.3,+IBY,0)) S IBUPD=1 Q
     49 . I $P(IBY,U,2)'=$P(^IBE(361.3,+IBY,0),U) S IBUPD=1,DIE="^IBE(361.3,",DR=".05////"_$G(DUZ)_";.06///^S X=""NOW""" D ^DIE
     50 D:IBUPD INIT
     51 S VALMBCK="R"
     52 Q
     53 ;
     54CKREVU(IBTEXT,IBNR,IBSKIP,IBREV) ; Check IBTEXT contains 'no review
     55 ;        needed' text
     56 ; IBNR = returned if passed by reference - 'no review needed' text found
     57 ; IBSKIP = 1 if no check needed for 'always review'
     58 ; IBREV = returned if passed by reference and 'review always needed'
     59 ;         text found
     60 ;
     61 N T,Y,Z,Z0
     62 S (IBREV,Y)=0,Z=""
     63 I '$G(IBSKIP) F  S Z=$O(^IBE(361.3,"AC",1,Z)) Q:Z=""  I IBTEXT[Z S IBREV=1 Q  ; Always review messages with this text
     64 I 'IBREV S Z="" F  S Z=$O(^IBE(361.3,"AC",0,Z)) Q:Z=""  I IBTEXT[Z S Y=1,IBNR=Z Q  ; Message contains text to make review unnecessary
     65 Q Y
     66 ;
     67REPORT ; Produce a report of messages filed without review by user-selected
     68 ; date range for date received and sort by either bill# or message text
     69 N IBFR,IBTO,IBSORT,DIR,DA,DR,X,Y,ZTSAVE,ZTRTN,ZTDESC,ZTREQ
     70R1 S DIR("A")="FROM DATE RECEIVED: ",DIR(0)="DA^:"_DT_"::PAXE" D ^DIR K DIR
     71 Q:$D(DTOUT)!$D(DUOUT)
     72 S IBFR=Y W "   ",$G(Y(0))
     73R2 S DIR("A")="TO DATE RECEIVED: ",DIR(0)="DAO^"_IBFR_":"_DT_"::PAE" D ^DIR K DIR
     74 Q:$D(DTOUT)!$D(DUOUT)
     75 I Y'>0 W ! G R1
     76 S IBTO=Y W "   ",$G(Y(0))
     77 S DIR("A")="SORT BY",DIR(0)="SXBO^B:Bill #;M:Message Screen Text",DIR("B")="B" D ^DIR K DIR
     78 Q:$D(DTOUT)!$D(DUOUT)
     79 I (Y="")!("BM"'[Y) W ! G R2
     80 S IBSORT=Y
     81 S %ZIS="QM" D ^%ZIS Q:POP
     82 I $D(IO("Q")) K IO("Q") S ZTRTN="ENRPT^IBCEM4",ZTSAVE("IB*")="",ZTDESC="IB - MESSAGES FILED WITHOUT REVIEW REPORT" D ^%ZTLOAD K ZTSK D HOME^%ZIS Q
     83 U IO
     84ENRPT ; Queued job entrypoint
     85 N IB,IB0,IBDA,IB00,IB1,IBS1,IBPAGE,IBLINES,IBHDRDT,IBSB,IBSTOP,DIR,Y,X,Z
     86 W:$E(IOST,1,2)["C-" @IOF ;Only initial form feed for print to screen
     87 K ^TMP($J,"IBSORT")
     88 S IB=IBFR-.000001
     89 F  S IB=$O(^IBM(361,"ARD",IB)) Q:'IB!$G(ZTSTOP)  S IBDA=0 F  S IBDA=$O(^IBM(361,"ARD",IB,IBDA)) Q:'IBDA!$G(ZTSTOP)  S IB0=$G(^IBM(361,IBDA,0)) Q:IB0=""!'$P(IB0,U,14)  D
     90 . I $D(ZTQUEUED) Q:$$STOP(.ZTREQ,.ZTSTOP)
     91 . S IBS1=""
     92 . I IBSORT="M" D  ; Find text that caused auto-file
     93 .. S Z=0 F  S Z=$O(^IBM(361,IBDA,1,Z)) Q:'Z  I $$CKREVU($G(^IBM(361,IBDA,1,Z,0)),.IBS1,1) Q
     94 .. I IBS1="" S IBS1="??"
     95 . I IBSORT="B" S IBS1=$P($G(^DGCR(399,+IB0,0)),U)
     96 . I IBS1'="" S ^TMP($J,"IBSORT",IBS1,IBDA)=IB0
     97 S IBHDRDT=$$FMTE^XLFDT($$NOW^XLFDT(),"2P")
     98 S (IBSTOP,IBLINES,IBPAGE)=0
     99 S IB1=1,IB="" F  S IB=$O(^TMP($J,"IBSORT",IB)) Q:IB=""!$G(ZTSTOP)  D  Q:IBSTOP
     100 . S IBSB=$S(IBSORT="M":"MESSAGE SCREEN TEXT: "_IB,1:"")
     101 . I IBSB'="" S IBSB=$J("",(80-$L(IBSB)\2))_IBSB
     102 . D:IB1 RHDR(IBSB,.IBSTOP) Q:IBSTOP
     103 . I 'IB1,IBSORT="M" D  Q:IBSTOP
     104 .. I IBLINES>(IOSL-5) D RHDR(IBSB,.IBSTOP) Q
     105 .. W !!,IBSB,! S IBLINES=IBLINES+3
     106 . S (IB1,IBDA)=0 F  S IBDA=$O(^TMP($J,"IBSORT",IB,IBDA)) Q:'IBDA!$G(ZTSTOP)  D  Q:IBSTOP
     107 .. I $D(ZTQUEUED),$$STOP(.ZTREQ,.ZTSTOP) W !,"*********** REPORT STOPPED BEFORE IT COMPLETED!!! ***********" Q
     108 .. S IB0=$G(^TMP($J,"IBSORT",IB,IBDA)),IB00=$G(^DGCR(399,+IB0,0))
     109 .. I $G(IBLINES)>(IOSL-5) D RHDR("",.IBSTOP) Q:IBSTOP
     110 .. W !,$E($$BN1^PRCAFN(+IB0)_$J("",10),1,10),"  ",$E($P($G(^DPT(+$P(IB00,U,2),0)),U)_$J("",25),1,25)_"  "_$E($$FMTE^XLFDT($P(IB00,U,3),"2D")_$J("",8),1,8)_"  "_$E($$FMTE^XLFDT($P(IB0,U,2),"2D")_$J("",8),1,8)_"  "
     111 .. W $E($P($G(^DIC(36,+$$POLICY^IBCEF(+IB0,1,$P(IB0,U,7)),0)),U),1,20)
     112 .. S IBLINES=IBLINES+1
     113 .. I $G(IBLINES)>(IOSL-5) D RHDR("",.IBSTOP) Q:IBSTOP
     114 .. S Z=0 F  S Z=$O(^IBM(361,IBDA,1,Z)) Q:'Z  D  Q:IBSTOP
     115 ... N Z0,Z1
     116 ... S Z0=$G(^IBM(361,IBDA,1,Z,0))
     117 ... F Z1=1:75:$L(Z0) D:$G(IBLINES)>(IOSL-5) RHDR("",.IBSTOP) Q:IBSTOP  W !,?5,$E(Z0,Z1,Z1+74) S IBLINES=IBLINES+1
     118 G:IBSTOP!$G(ZTSTOP) ENSTOP
     119 I $G(IB1) D RHDR("") W !,"NO RECORDS MATCHING SEARCH CRITERIA WERE FOUND",!
     120 ;
     121 I $E(IOST,1,2)["C-"  K DIR S DIR(0)="E" D ^DIR K DIR
     122ENSTOP I '$D(ZTQUEUED) D ^%ZISC
     123 I $D(ZTQUEUED),'$G(ZTSTOP) S ZTREQ="@"
     124 K ^TMP($J,"IBSORT")
     125 Q
     126 ;
     127RHDR(IBSB,IBSTOP) ; Report header
     128 ; IBSB'="" if sub header should print
     129 N Z,DIR,X,Y
     130 S IBPAGE=IBPAGE+1
     131 I IBPAGE>1,$E(IOST,1,2)["C-" S DIR(0)="E" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S IBSTOP=1 G RHDRQ
     132 W !,@IOF
     133 W !,?22,"MESSAGES FILED WITHOUT REVIEW REPORT",?65,"PAGE: ",IBPAGE
     134 S Z="RUN DATE: "_IBHDRDT W !,?(80-$L(Z)\2),Z
     135 S Z="DATE RECEIVED RANGE: "_$$FMTE^XLFDT(IBFR,"2D")_"-"_$$FMTE^XLFDT(IBTO,"2D") W !,?(80-$L(Z)\2),Z,!
     136 W !,$J("",40),"EVENT      DATE"
     137 W !,"BILL #      PATIENT NAME"_$J("",15)_" DATE     RECEIVED  INSURANCE CO",!
     138 S Z="",$P(Z,"-",81)="" W Z
     139 S IBLINES=7
     140 I $G(IBSB)'="" W !,IBSB,! S IBLINES=IBLINES+2
     141RHDRQ Q
     142 ;
     143STOP(IBSTOP,IBREQ) ; Check for job being stopped
     144 I $$S^%ZTLOAD S IBSTOP=1 K IBREQ
     145 Q $G(IBSTOP)
     146 ;

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEMCA2.m

    r613 r623  
    1 IBCEMCA2        ;ALB/ESG - Multiple CSA Message Management - Actions ;20-SEP-2005
    2         ;;2.0;INTEGRATED BILLING;**320,377**;21-MAR-1994;Build 23
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5         Q
    6         ;
    7 CANCEL  ; mass claim cancel
    8         NEW NS,IBIFN,NSC,DIR,X,Y,DUOUT,DTOUT,DIRUT,DIROUT,IBDA,IB364,DISP,IBCE
    9         NEW IBMCSRSC,IBMCSRNB,IBMCSCNT,IBMCSTOT,IBMCSTOP,IBMCSCAN,MRACHK,IBCAN,IBMCSCAC
    10         D FULL^VALM1
    11         ;
    12         I '$$KCHK^XUSRB("IB AUTHORIZE") D  G CANCELX
    13         . W !!?5,"You don't hold the proper security key to access this option."
    14         . W !?5,"The necessary key is IB AUTHORIZE.  Please see your manager."
    15         . D PAUSE^VALM1
    16         . Q
    17         ;
    18         S NS=+$G(^TMP($J,"IBCEMCL",4))
    19         I 'NS D  G CANCELX
    20         . W !!?5,"There are no selected messages." D PAUSE^VALM1
    21         . Q
    22         ;
    23         ; count number of claims too
    24         S IBIFN=0 F NSC=0:1 S IBIFN=$O(^TMP($J,"IBCEMCL",4,2,IBIFN)) Q:'IBIFN
    25         ;
    26         W !!?5,"Number of messages selected:  ",NS
    27         W !?7,"Number of claims selected:  ",NSC
    28         W !!,"In order to cancel "
    29         W $S(NSC=1:"this claim",1:"these claims")
    30         W ", a Reason Cancelled and a Reason Not Billable"
    31         W !,"are required.  You may also provide an optional CT Additional Comment."
    32         W !,"These will be used as the default responses for "
    33         W $S(NSC=1:"this claim",1:"all claims")
    34         W "."
    35         ;
    36 CANQ1   ; reader call for the Reason Cancelled field
    37         W !
    38         S DIR(0)="399,19"
    39         S DIR("A")="Reason Cancelled"
    40         D ^DIR K DIR
    41         I X="",Y="" W *7,!,"This is a required response. Enter '^' to exit." G CANQ1
    42         I $D(DIRUT) G CANCELX
    43         M IBMCSRSC=Y           ; save the entered text for reason cancelled
    44         ;
    45 CANQ2   ; reader call for the reason not billable field
    46         W !
    47         S DIR(0)="356,.19"
    48         S DIR("A")="Reason Not Billable"
    49         D ^DIR K DIR
    50         I X="",Y="" W *7,!,"This is a required response. Enter '^' to exit." G CANQ2
    51         I $D(DIRUT) G CANCELX
    52         M IBMCSRNB=Y           ; save the reason not billable code/desc
    53         ;
    54 CANQ3   ; reader call for the Claims Tracking Additional Comment field
    55         W !
    56         S DIR(0)="356,1.08O"
    57         S DIR("A")="CT Additional Comment"
    58         D ^DIR K DIR
    59         I $D(DIRUT) G CANCELX
    60         M IBMCSCAC=Y
    61         ;
    62         W !
    63         S DIR(0)="YO"
    64         S DIR("A")="OK to proceed into the cancel claim loop",DIR("B")="No"
    65         D ^DIR K DIR
    66         I Y'=1 G CANCELX
    67         ;
    68         S IBIFN=0,IBMCSCNT=0,IBMCSTOT=NSC,IBMCSTOP=0
    69         F  S IBIFN=$O(^TMP($J,"IBCEMCL",4,2,IBIFN)) Q:'IBIFN  D  Q:IBMCSTOP
    70         . S IBMCSCNT=IBMCSCNT+1
    71         . S IBDA=+$O(^TMP($J,"IBCEMCL",4,2,IBIFN,""),-1)  ; most recent 361 ien
    72         . S IB364=+$P($G(^IBM(361,IBDA,0)),U,11)          ; transmit bill 364 ien
    73         . W !!," *** Processing MCS claim# ",IBMCSCNT," of ",IBMCSTOT," ***"
    74         . S DISP=$$DISP^IBCEM3(IBIFN,"cancel","",1,.DIRUT)
    75         . ;
    76         . I $D(DIRUT) D  Q       ; up arrow or time-out
    77         .. N DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
    78         .. S DIR(0)="YO"
    79         .. S DIR("A")="Do you want to Exit this MCS cancel claim loop"
    80         .. S DIR("B")="Yes"
    81         .. W ! D ^DIR K DIR
    82         .. I Y=1 S IBMCSTOP=1    ; Yes, exit out altogether
    83         .. Q
    84         . ;
    85         . I 'DISP Q              ; user said No to cancel
    86         . ;
    87         . I 'IBDA!'IB364 D  Q
    88         .. W !?4,"Cannot determine the EDI transmission record."
    89         .. W !?4,"This claim can't be cancelled here."
    90         .. D PAUSE^VALM1
    91         .. Q
    92         . ;
    93         . D MRACHK^IBCECSA4 I MRACHK Q
    94         . ;
    95         . ; set-up required variables for main call to cancel this claim
    96         . S IBCAN=1,IBMCSCAN=1
    97         . S IBCE("EDI")=1
    98         . S Y=IBIFN
    99         . D
    100         .. ; protect variables to be restored after call to IBCC and
    101         .. ; leftover junk variables from IBCC
    102         .. NEW IBIFN,IBMCSTOP,IBMCSCNT,IBMCSTOT,IBCSAMCS
    103         .. NEW IBCCCC,IBCCR,IBQUIT,NAME,POP,RDATES,COL,CTRLCOL,FINISH
    104         .. D NOPTF^IBCC
    105         .. Q
    106         . Q
    107         ;
    108         I IBMCSTOP W !!?5,"MCS cancel loop aborted."
    109         I 'IBMCSTOP W !!?5,"Done with MCS cancel loop!"
    110         D PAUSE^VALM1
    111         ;
    112         ; rebuild the list
    113         KILL ^TMP($J,"IBCEMCA"),VALMHDR
    114         S VALMBG=1
    115         D UNLOCK^IBCEMCL
    116         D INIT^IBCEMCL
    117         I $G(IBCSAMCS)=1 S IBCSAMCS=2   ; flag to rebuild CSA
    118         ;
    119 CANCELX ;
    120         S VALMBCK="R"
    121         Q
    122         ;
     1IBCEMCA2 ;ALB/ESG - Multiple CSA Message Management - Actions ;20-SEP-2005
     2 ;;2.0;INTEGRATED BILLING;**320**;21-MAR-1994
     3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
     4 ;
     5 Q
     6 ;
     7CANCEL ; mass claim cancel
     8 NEW NS,IBIFN,NSC,DIR,X,Y,DUOUT,DTOUT,DIRUT,DIROUT,IBDA,IB364,DISP,IBCE
     9 NEW IBMCSRSC,IBMCSRNB,IBMCSCNT,IBMCSTOT,IBMCSTOP,IBMCSCAN,MRACHK,IBCAN
     10 D FULL^VALM1
     11 ;
     12 I '$$KCHK^XUSRB("IB AUTHORIZE") D  G CANCELX
     13 . W !!?5,"You don't hold the proper security key to access this option."
     14 . W !?5,"The necessary key is IB AUTHORIZE.  Please see your manager."
     15 . D PAUSE^VALM1
     16 . Q
     17 ;
     18 S NS=+$G(^TMP($J,"IBCEMCL",4))
     19 I 'NS D  G CANCELX
     20 . W !!?5,"There are no selected messages." D PAUSE^VALM1
     21 . Q
     22 ;
     23 ; count number of claims too
     24 S IBIFN=0 F NSC=0:1 S IBIFN=$O(^TMP($J,"IBCEMCL",4,2,IBIFN)) Q:'IBIFN
     25 ;
     26 W !!?5,"Number of messages selected:  ",NS
     27 W !?7,"Number of claims selected:  ",NSC
     28 W !!,"In order to cancel "
     29 W $S(NSC=1:"this claim",1:"these claims")
     30 W ", you must supply the Reason Cancelled and"
     31 W !,"the Reason Not Billable.  These will be the default responses for "
     32 W $S(NSC=1:"this claim",1:"all claims")
     33 W "."
     34 ;
     35CANQ1 ; reader call for the Reason Cancelled field
     36 W !
     37 S DIR(0)="399,19"
     38 S DIR("A")="Reason Cancelled"
     39 D ^DIR K DIR
     40 I X="",Y="" W *7,!,"This is a required response. Enter '^' to exit." G CANQ1
     41 I $D(DIRUT) G CANCELX
     42 M IBMCSRSC=Y           ; save the entered text for reason cancelled
     43 ;
     44CANQ2 ; reader call for the reason not billable field
     45 W !
     46 S DIR(0)="356,.19"
     47 S DIR("A")="Reason Not Billable"
     48 D ^DIR K DIR
     49 I X="",Y="" W *7,!,"This is a required response. Enter '^' to exit." G CANQ2
     50 I $D(DIRUT) G CANCELX
     51 M IBMCSRNB=Y           ; save the reason not billable code/desc
     52 ;
     53 W !
     54 S DIR(0)="YO"
     55 S DIR("A")="OK to proceed into the cancel claim loop",DIR("B")="No"
     56 D ^DIR K DIR
     57 I Y'=1 G CANCELX
     58 ;
     59 S IBIFN=0,IBMCSCNT=0,IBMCSTOT=NSC,IBMCSTOP=0
     60 F  S IBIFN=$O(^TMP($J,"IBCEMCL",4,2,IBIFN)) Q:'IBIFN  D  Q:IBMCSTOP
     61 . S IBMCSCNT=IBMCSCNT+1
     62 . S IBDA=+$O(^TMP($J,"IBCEMCL",4,2,IBIFN,""),-1)  ; most recent 361 ien
     63 . S IB364=+$P($G(^IBM(361,IBDA,0)),U,11)          ; transmit bill 364 ien
     64 . W !!," *** Processing MCS claim# ",IBMCSCNT," of ",IBMCSTOT," ***"
     65 . S DISP=$$DISP^IBCEM3(IBIFN,"cancel","",1,.DIRUT)
     66 . ;
     67 . I $D(DIRUT) D  Q       ; up arrow or time-out
     68 .. N DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
     69 .. S DIR(0)="YO"
     70 .. S DIR("A")="Do you want to Exit this MCS cancel claim loop"
     71 .. S DIR("B")="Yes"
     72 .. W ! D ^DIR K DIR
     73 .. I Y=1 S IBMCSTOP=1    ; Yes, exit out altogether
     74 .. Q
     75 . ;
     76 . I 'DISP Q              ; user said No to cancel
     77 . ;
     78 . I 'IBDA!'IB364 D  Q
     79 .. W !?4,"Cannot determine the EDI transmission record."
     80 .. W !?4,"This claim can't be cancelled here."
     81 .. D PAUSE^VALM1
     82 .. Q
     83 . ;
     84 . D MRACHK^IBCECSA4 I MRACHK Q
     85 . ;
     86 . ; set-up required variables for main call to cancel this claim
     87 . S IBCAN=1,IBMCSCAN=1
     88 . S IBCE("EDI")=1
     89 . S Y=IBIFN
     90 . D
     91 .. ; protect variables to be restored after call to IBCC and
     92 .. ; leftover junk variables from IBCC
     93 .. NEW IBIFN,IBMCSTOP,IBMCSCNT,IBMCSTOT,IBCSAMCS
     94 .. NEW IBCCCC,IBCCR,IBQUIT,NAME,POP,RDATES,COL,CTRLCOL,FINISH
     95 .. D NOPTF^IBCC
     96 .. Q
     97 . Q
     98 ;
     99 I IBMCSTOP W !!?5,"MCS cancel loop aborted."
     100 I 'IBMCSTOP W !!?5,"Done with MCS cancel loop!"
     101 D PAUSE^VALM1
     102 ;
     103 ; rebuild the list
     104 KILL ^TMP($J,"IBCEMCA"),VALMHDR
     105 S VALMBG=1
     106 D UNLOCK^IBCEMCL
     107 D INIT^IBCEMCL
     108 I $G(IBCSAMCS)=1 S IBCSAMCS=2   ; flag to rebuild CSA
     109 ;
     110CANCELX ;
     111 S VALMBCK="R"
     112 Q
     113 ;

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEOB.m

    r613 r623  
    1 IBCEOB  ;ALB/TMP - 835 EDI EOB MESSAGE PROCESSING ;20-JAN-99
    2         ;;2.0;INTEGRATED BILLING;**137,135,265,155,377**;21-MAR-94;Build 23
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5         Q
    6         ;
    7 UPDEOB(IBTDA)   ; Update EXPLANATION OF BENEFITS file (#361.1) from return msg
    8         ; IBTDA = ien of return message
    9         ; Function returns ien of EOB file entry or "" if errors found
    10         ;          the data.  Any errors found are
    11         ;          stored in array ^TMP("IBCERR-EOB",$J,n) in text format
    12         ;          n = seq # and are stored with the EOB in a wp field
    13         ;
    14         N IB0,IB100,IBBTCH,IBE,IBMNUM,IBT,DLAYGO,DIC,DD,DO,X,Y,Z,Z0,Z1,IBEOB,IBBAD,IBOK,IB,IBA1,IBIFN,IBFILE
    15         K ^TMP($J),^TMP("IBCERR-EOB",$J)
    16         ;
    17         S (IBBAD,IBEOB)=""
    18         S IB0=$G(^IBA(364.2,IBTDA,0))
    19         S IBMNUM=+$P(IB0,U)
    20         S X=+$G(^IBA(364,+$P(IB0,U,5),0))
    21         ;
    22         G:$S(IBMNUM=""!(X=""):1,1:$D(^IBM(361.1,"AC",IBMNUM))) UPDQ
    23         ;
    24         ; Duplicate EOB Check
    25         S IBFILE="^IBA(364.2,"_IBTDA_",2)"
    26         I $$DUP(IBFILE,X) D DELMSG^IBCESRV2(IBTDA) G UPDQ
    27         ;
    28         I '$$LOCK^IBCEM(IBTDA) G UPDQ ;Lock msg file 364.2
    29         S IBEOB=+$$ADD3611(IBMNUM,$P(IB0,U,5),$P(IB0,U,4),X,0,IBFILE)
    30         L -^IBA(364.2,IBTDA,0)
    31         ;
    32         I IBEOB<0 S IBEOB="" G UPDQ
    33         D UPD3611(IBEOB,IBTDA,0)
    34         ;
    35 UPDQ    I IBEOB,$O(^TMP("IBCERR-EOB",$J,0)) D ERRUPD(IBEOB,"IBCERR-EOB")
    36         K ^TMP($J),^TMP("IBCERR-EOB",$J)
    37         D CLEAN^DILF
    38         Q +IBEOB
    39         ;
    40         ;
    41         ; NOTE: **** For all variables IB0,IBEGBL,IBEOB below:
    42         ; IB0 = raw data received for this record type on the 835 flat file
    43         ; IBEGBL = subscript to use in error global
    44         ; IBEOB = ien in file 361.1 for this EOB
    45         ;
    46 835(IB0,IBEGBL,IBEOB)   ; Store header
    47         ;
    48         Q $$HDR^IBCEOB1(IB0,IBEGBL,IBEOB)
    49         ;
    50 5(IB0,IBEGBL,IBEOB)     ; Record '05'
    51         ;
    52         N IBOK,DA,DR,DIE,X,Y
    53         K IBZDATA
    54         S DR=";",IBOK=1
    55         S DIE="^IBM(361.1,",DA=IBEOB
    56         ;
    57         I $P(IB0,U,9) S DR=DR_"1.1///"_$$DATE^IBCEU($P(IB0,U,9))_";"         ; statement start date
    58         I $P(IB0,U,10) S DR=DR_"1.11///"_$$DATE^IBCEU($P(IB0,U,10))_";"      ; statement end date
    59         S DR=$P(DR,";",2,$L(DR,";")-1)
    60         I DR'="" D ^DIE S IBOK=$D(Y)=0
    61         I 'IBOK S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Bad record 5 data"
    62         Q IBOK
    63         ;
    64 6(IB0,IBEGBL,IBEOB)     ; Record '06' - corrected patient name and/or ID#
    65         ; This data is not going to be filed into file 361.1 so the value of this function will always be a 1 so as to
    66         ; not interrupt the filing process of the EOB/MRA data into file 361.1.
    67         ;
    68         ; perform overall integrity checks on the incoming 06 record.  If anything is out of place, don't update anything
    69         ; and report the problem and get out.
    70         NEW CLM,SITE,IBM,IBIFN,IBIFN1,DFN,SEQ,DIE,DA,DR
    71         S DIE=361.1,DA=IBEOB,DR="61.01////^S X=IB0" D ^DIE    ; archive the raw 06 record data
    72         S CLM=$P(IB0,U,2),SITE=+CLM,CLM=$P(CLM,"-",2) I CLM="" D MSG(IBEOB,"The claim# in piece 2 is invalid.") G Q6
    73         S IBM=$G(^IBM(361.1,IBEOB,0))
    74         I $P(IBM,U,4)'=1 D MSG(IBEOB,"This is a non-Medicare EOB.") G Q6
    75         S IBIFN=+$P(IBM,U,1)                    ; claim# from MRA
    76         S IBIFN1=+$O(^DGCR(399,"B",CLM,""))     ; claim# from 06 record
    77         I IBIFN'=IBIFN1 D MSG(IBEOB,"Claim mismatch error."_IBIFN_","_IBIFN1_","_CLM_".") G Q6
    78         I $P($$SITE^VASITE,U,3)'=SITE D MSG(IBEOB,"Invalid station# mismatch."_$P($$SITE^VASITE,U,3)_","_SITE_".") G Q6
    79         S SEQ=$$COBN^IBCEF(IBIFN)               ; current payer sequence# on claim
    80         I '$$WNRBILL^IBEFUNC(IBIFN,SEQ) D MSG(IBEOB,"The current payer on this claim is not MEDICARE (WNR).") G Q6
    81         S DFN=+$P($G(^DGCR(399,IBIFN,0)),U,2)   ; patient ien
    82         I 'DFN D MSG(IBEOB,"The patient DFN cannot be determined.") G Q6
    83         ;
    84         D UPD^IBCEOB01(IB0,IBEOB,IBIFN,DFN,SEQ)     ; update patient insurance policy data
    85         ;
    86 Q6      ; exit point for $$6 function
    87         Q 1
    88         ;
    89 10(IB0,IBEGBL,IBEOB)    ; Record '10'
    90         ;
    91         N DA,DR,DIE,X,Y,VAL,IBOK
    92         S DIE="^IBM(361.1,",DA=IBEOB
    93         S DR=".13////"_$S($P(IB0,U,3)="Y":1,$P(IB0,U,4)="Y":2,$P(IB0,U,5)="Y":3,$P(IB0,U,6)="Y":4,1:5)_";.21////"_$P(IB0,U,7)
    94         S DR=DR_";2.04////"_$$DOLLAR($P(IB0,U,10))_";1.01////"_$$DOLLAR($P(IB0,U,11))_$S($P(IB0,U,12)'="":";.14///"_$P(IB0,U,12),1:"")
    95         S DR=DR_$S($P(IB0,U,13)'="":";.1///"_$P(IB0,U,13),1:"")_";.11///"_($P(IB0,U,14)/10000)_";.12///"_($P(IB0,U,15)/100)
    96         I $P(IB0,U,8)'="" S DR=DR_";.08////"_$P(IB0,U,8)_$S($P(IB0,U,9)'="":";.09///"_$P(IB0,U,9),1:"")
    97         ;
    98         D ^DIE
    99         S IBOK=($D(Y)=0)
    100         I 'IBOK S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Bad record 10 data" G Q10
    101         ;
    102         ; File ICN in Bill
    103         D ICN^IBCEOB00(IBEOB,$P(IB0,U,12),$P($G(^IBM(361.1,IBEOB,0)),U,15),.IBOK)
    104         ;
    105 Q10     Q IBOK
    106         ;
    107 15(IB0,IBEGBL,IBEOB)    ; Record '15'
    108         ; Moved due to space constraints
    109 Q15     Q $$15^IBCEOB00(IB0,IBEGBL,IBEOB)
    110         ;
    111 17(IB0,IBEGBL,IBEOB)    ; Record '17'
    112         N A,IBOK
    113         S A="3;25.01;0;1;0^4;25.02;0;1;0^5;25.03;0;1;0^6;25.04;0;1;0^7;25.05;0;1;0^8;25.06;0;1;0^9;25.07;0;1;0"
    114         S IBOK=$$STORE^IBCEOB1(A,IB0,IBEOB)
    115         I 'IBOK S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Bad record 17 data"
    116 Q17     Q IBOK
    117         ;
    118 20(IB0,IBEGBL,IBEOB)    ; Record '20'
    119         ; Moved due to space constraints
    120 Q20     Q $$20^IBCEOB00(IB0,IBEGBL,IBEOB)
    121         ;
    122 30(IB0,IBEGBL,IBEOB)    ; Record '30'
    123         ;
    124         N IBOK
    125         D 30^IBCEOB0(IB0,IBEOB,.IBOK)
    126 Q30     Q $G(IBOK)
    127         ;
    128 35(IB0,IBEGBL,IBEOB)    ; Record '35'
    129         ; Moved due to space constraints
    130 Q35     Q $$35^IBCEOB00(IB0,IBEGBL,IBEOB)
    131         ;
    132 37(IB0,IBEGBL,IBEOB)    ; Record '37'
    133         ; Moved due to space constraints
    134 Q37     Q $$37^IBCEOB00(IB0,IBEGBL,IBEOB)
    135         ;
    136 40(IB0,IBEGBL,IBEOB)    ; Record '40'
    137         ;
    138         N IBOK
    139         D 40^IBCEOB0(IB0,IBEOB,.IBOK)
    140 Q40     Q $G(IBOK)
    141         ;
    142 41(IB0,IBEGBL,IBEOB)    ; Record '41'
    143         ;
    144         N IBOK
    145         D 41^IBCEOB0(IB0,IBEOB,.IBOK)
    146 Q41     Q $G(IBOK)
    147         ;
    148 42(IB0,IBEGBL,IBEOB)    ; Record '42'
    149         ;
    150         N IBOK
    151         D 42^IBCEOB0(IB0,IBEOB,.IBOK)
    152 Q42     Q $G(IBOK)
    153         ;
    154 45(IB0,IBEGBL,IBEOB)    ; Record '45'
    155         ;
    156         N IBOK
    157         D 45^IBCEOB0(IB0,IBEOB,.IBOK)
    158         Q $G(IBOK)
    159         ;
    160 MSG(IBEOB,MSG)  ; procedure to file message into field 6.03
    161         ; Results of processing of the "06" record type
    162         N DIE,DA,DR,Z
    163         S DIE=361.1,DA=+$G(IBEOB)
    164         I $G(MSG)="" G MSGX
    165         S Z=$P($G(^IBM(361.1,DA,6)),U,3)    ; already existing message
    166         I Z'="" S MSG=Z_"  "_MSG            ; append new message to existing message
    167         S MSG=$E(MSG,1,190)
    168         S DR="6.03///^S X=MSG"
    169         D ^DIE
    170 MSGX    ;
    171         Q
    172         ;
    173 DOLLAR(X)       ; Convert value in X to dollar format XXX.XX
    174         Q $S(+X:$J(X/100,$L(+X),2),1:0)
    175         ;
    176 ADD3611(IBMNUM,IBTBILL,IBBATCH,X,IBAR,IBFILE)   ; Add stub record to file 361.1
    177         ; X = the ien of the referenced bill in file 399
    178         ; IBTBILL = ien of transmitted bill (optional)
    179         ; IBBATCH = ien of batch # the transmitted bill was in (optional)
    180         ; IBMNUM = the message # from which this record originally came
    181         ; IBAR = 1 only if called from AR
    182         ; IBFILE = array reference of raw EOB data
    183         ;
    184         N DIC,DA,DR,DO,DD,DLAYGO,Y,REVSTAT,BS,MMI
    185         F  L +^IBM(361.1,0):10 Q:$T
    186         ;
    187         ; default proper review status
    188         S BS=$P($G(^DGCR(399,X,0)),U,13)   ; bill status
    189         S REVSTAT=$S(BS=7:9,BS=3:3,BS=4:3,1:0)
    190         S MMI=$$NET^XMRENT(IBMNUM)         ; MailMan header info
    191         S DIC(0)="L",DIC="^IBM(361.1,",DLAYGO=361.1
    192         S DIC("DR")=".16////"_REVSTAT_";.17////0"_";100.02////"_IBMNUM_$S('$G(IBAR):";.19////"_+IBTBILL_";100.01////"_IBBATCH,1:"")
    193         S DIC("DR")=DIC("DR")_";100.05////"_$$CHKSUM^IBCEMU1(IBFILE)_";62.01////^S X=MMI"
    194         D FILE^DICN
    195         L -^IBM(361.1,0)
    196         Q +Y
    197         ;
    198 UPD3611(IBEOB,IBTDA,IBAR)       ; From flat file 835 format, add EOB record
    199         ; IBEOB = the ien of the entry in file 361.1 being updated
    200         ; IBTDA = the ien in the source file
    201         ; IBAR = 1 if being called from AR
    202         N IBA1,IBFILE,IBEGBL,Z,IBREC,Q
    203         S IBFILE=$S('$G(IBAR):"^IBA(364.2,"_IBTDA_",2)",1:"^TMP("_$J_",""RCDP-EOB"","_IBTDA_")")
    204         S IBEGBL=$S('$G(IBAR):"IBCERR-EOB",1:"RCDPERR-EOB")
    205         I $G(IBAR),'$$HDR^IBCEOB1($G(^TMP($J,"RCDPEOB","HDR")),IBEGBL,IBEOB) Q
    206         S IBA1=0
    207         F  S IBA1=$O(@IBFILE@(IBA1)) Q:'IBA1  S IB0=$S('$G(IBAR):$P($G(^(IBA1,0)),"##RAW DATA: ",2),1:$G(@IBFILE@(IBA1,0))) I IB0'="" D
    208         . S IBREC=+IB0
    209         . I IBREC'=37 K ^TMP($J,37)
    210         . I IBREC S IB="S IBOK=$$"_IBREC_"(IB0,IBEGBL,IBEOB)",Q=IBREC_"^IBCEOB" I $T(@Q)'="" X IB S:'IBOK ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)=$S('$G(IBAR):"  ##RAW DATA: ",1:"")_IB0
    211         ;
    212         Q
    213         ;
    214 ERRUPD(IBEOB,IBEGBL)    ; Update error text in entry, if needed
    215         D WP^DIE(361.1,IBEOB_",",20,"","^TMP(IBEGBL,$J)","")
    216         Q
    217         ;
    218         ;
    219 DUP(IBARRAY,IBIFN)      ; Duplicate Check
    220         ; This function determines if the EOB data already exists in file
    221         ; 361.1 by comparing the checksums of the raw 835 data.
    222         ;
    223         ; IBARRAY = Literal array reference where the raw 835 data exists.
    224         ;           The data exists at @IBARRAY@(n,0), where n is the seq#.
    225         ;           For example, IBARRAY = "^IBA(364.2,IBIEN,2)"
    226         ;
    227         ; IBIFN = the bill # (ptr to 399).  The checksums of the EOB's on
    228         ;         file for this bill will be compared to the checksum of the
    229         ;         835 raw data in the IBARRAY reference.
    230         ;
    231         ; This function returns 0 if the entry is not found (no duplicate),
    232         ; Otherwise, the IEN of the entry in file 361.1 is returned if this
    233         ; is a duplicate EOB.
    234         ;
    235         NEW DUP,IBEOB,CHKSUM1,CHKSUM2
    236         S DUP=0,IBIFN=+$G(IBIFN)
    237         I $G(IBARRAY)=""!'IBIFN G DUPX
    238         I '$D(^IBM(361.1,"B",IBIFN)) G DUPX     ; no EOB's on file yet
    239         S CHKSUM1=$$CHKSUM^IBCEMU1(IBARRAY)     ; checksum of current EOB
    240         I 'CHKSUM1 G DUPX                       ; must be able to be calculated
    241         S IBEOB=0
    242         F  S IBEOB=$O(^IBM(361.1,"B",IBIFN,IBEOB)) Q:'IBEOB  D  Q:DUP
    243         . S CHKSUM2=+$P($G(^IBM(361.1,IBEOB,100)),U,5)   ; checksum of old EOB
    244         . I 'CHKSUM2 Q
    245         . I CHKSUM1=CHKSUM2 S DUP=IBEOB Q                    ; comparison
    246         . Q
    247 DUPX    ;
    248         Q DUP
    249         ;
     1IBCEOB ;ALB/TMP - 835 EDI EOB MESSAGE PROCESSING ;20-JAN-99
     2 ;;2.0;INTEGRATED BILLING;**137,135,265,155**;21-MAR-94
     3 Q
     4 ;
     5UPDEOB(IBTDA) ; Update EXPLANATION OF BENEFITS file (#361.1) from return msg
     6 ; IBTDA = ien of return message
     7 ; Function returns ien of EOB file entry or "" if errors found
     8 ;          the data.  Any errors found are
     9 ;          stored in array ^TMP("IBCERR-EOB",$J,n) in text format
     10 ;          n = seq # and are stored with the EOB in a wp field
     11 ;
     12 N IB0,IB100,IBBTCH,IBE,IBMNUM,IBT,DLAYGO,DIC,DD,DO,X,Y,Z,Z0,Z1,IBEOB,IBBAD,IBOK,IB,IBA1,IBIFN,IBFILE
     13 K ^TMP($J),^TMP("IBCERR-EOB",$J)
     14 ;
     15 S (IBBAD,IBEOB)=""
     16 S IB0=$G(^IBA(364.2,IBTDA,0))
     17 S IBMNUM=+$P(IB0,U)
     18 S X=+$G(^IBA(364,+$P(IB0,U,5),0))
     19 ;
     20 G:$S(IBMNUM=""!(X=""):1,1:$D(^IBM(361.1,"AC",IBMNUM))) UPDQ
     21 ;
     22 ; Duplicate EOB Check
     23 S IBFILE="^IBA(364.2,"_IBTDA_",2)"
     24 I $$DUP(IBFILE,X) G UPDQ
     25 ;
     26 I '$$LOCK^IBCEM(IBTDA) G UPDQ ;Lock msg file 364.2
     27 S IBEOB=+$$ADD3611(IBMNUM,$P(IB0,U,5),$P(IB0,U,4),X,0,IBFILE)
     28 L -^IBA(364.2,IBTDA,0)
     29 ;
     30 I IBEOB<0 S IBEOB="" G UPDQ
     31 D UPD3611(IBEOB,IBTDA,0)
     32 ;
     33UPDQ I IBEOB,$O(^TMP("IBCERR-EOB",$J,0)) D ERRUPD(IBEOB,"IBCERR-EOB")
     34 K ^TMP($J),^TMP("IBCERR-EOB",$J)
     35 D CLEAN^DILF
     36 Q +IBEOB
     37 ;
     38 ;
     39 ; NOTE: **** For all variables IB0,IBEGBL,IBEOB below:
     40 ; IB0 = raw data received for this record type on the 835 flat file
     41 ; IBEGBL = subscript to use in error global
     42 ; IBEOB = ien in file 361.1 for this EOB
     43 ;
     44835(IB0,IBEGBL,IBEOB) ; Store header
     45 ;
     46 Q $$HDR^IBCEOB1(IB0,IBEGBL,IBEOB)
     47 ;
     485(IB0,IBEGBL,IBEOB) ; Record '05'
     49 ;
     50 N IBOK,IBBULL,DA,DR,DIE,X,Y
     51 K IBZDATA
     52 S DR=";",IBOK=1
     53 S DIE="^IBM(361.1,",DA=IBEOB
     54 ;
     55 S IBBULL=""
     56 I $$UPDNM^IBCEOB00(IBEOB,IB0,.IBBULL,.DR)!$$UPDID^IBCEOB00(IBEOB,IB0,.IBBULL,.DR) D  ; New insured's name and/or HIC # found
     57 . D CHGBULL^IBCEOB3(IBEOB,IBBULL) ;Send a bulletin reporting change
     58 ;
     59 I $P(IB0,U,9) S DR=DR_"1.1///"_$$DATE^IBCEU($P(IB0,U,9))_";"
     60 I $P(IB0,U,10) S DR=DR_"1.11///"_$$DATE^IBCEU($P(IB0,U,10))_";"
     61 S DR=$P(DR,";",2,$L(DR,";")-1)
     62 I DR'="" D ^DIE S IBOK=$D(Y)=0
     63 I 'IBOK S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Bad record 5 data"
     64 Q IBOK
     65 ;
     6610(IB0,IBEGBL,IBEOB) ; Record '10'
     67 ;
     68 N DA,DR,DIE,X,Y,VAL,IBOK
     69 S DIE="^IBM(361.1,",DA=IBEOB
     70 S DR=".13////"_$S($P(IB0,U,3)="Y":1,$P(IB0,U,4)="Y":2,$P(IB0,U,5)="Y":3,$P(IB0,U,6)="Y":4,1:5)_";.21////"_$P(IB0,U,7)
     71 S DR=DR_";2.04////"_$$DOLLAR($P(IB0,U,10))_";1.01////"_$$DOLLAR($P(IB0,U,11))_$S($P(IB0,U,12)'="":";.14///"_$P(IB0,U,12),1:"")
     72 S DR=DR_$S($P(IB0,U,13)'="":";.1///"_$P(IB0,U,13),1:"")_";.11///"_($P(IB0,U,14)/10000)_";.12///"_($P(IB0,U,15)/100)
     73 I $P(IB0,U,8)'="" S DR=DR_";.08////"_$P(IB0,U,8)_$S($P(IB0,U,9)'="":";.09///"_$P(IB0,U,9),1:"")
     74 ;
     75 D ^DIE
     76 S IBOK=($D(Y)=0)
     77 I 'IBOK S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Bad record 10 data" G Q10
     78 ;
     79 ; File ICN in Bill
     80 D ICN^IBCEOB00(IBEOB,$P(IB0,U,12),$P($G(^IBM(361.1,IBEOB,0)),U,15),.IBOK)
     81 ;
     82Q10 Q IBOK
     83 ;
     8415(IB0,IBEGBL,IBEOB) ; Record '15'
     85 ;
     86 N A,IBOK
     87 ;
     88 S A="3;1.03;1;0;0^4;1.04;1;0;0^5;1.05;1;0;0^6;1.07;1;0;0^7;1.08;1;0;0^8;1.09;1;0;0^9;1.02;1;0;0^10;2.05;1;0;0"
     89 ;
     90 S IBOK=$$STORE^IBCEOB1(A,IB0,IBEOB)
     91 I 'IBOK S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Bad record 15 data" G Q15
     92 ;
     93 ; For Medicare MRA's only:
     94 ; If the Covered Amount is present (15 record, piece 3), then file
     95 ; a claim level adjustment with Group code=OA, Reason code=AB3.
     96 ;
     97 I $P($G(^IBM(361.1,IBEOB,0)),U,4)=1,+$P(IB0,U,3) D
     98 . N IB20
     99 . S IB20=20_U_$P(IB0,U,2)_U_"OA"_U_"AB3"_U_$P(IB0,U,3)_U_"0000000000"
     100 . S IB20=IB20_U_"Covered Amount"
     101 . S IBOK=$$20(IB20,IBEGBL,IBEOB)
     102 . I 'IBOK S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Could not file the OA-AB3 claim level adjustment for the Covered Amount"
     103 . K ^TMP($J,20)
     104 . Q
     105 ;
     106Q15 Q IBOK
     107 ;
     10817(IB0,IBEGBL,IBEOB) ; Record '17'
     109 N A,IBOK
     110 S A="3;25.01;0;1;0^4;25.02;0;1;0^5;25.03;0;1;0^6;25.04;0;1;0^7;25.05;0;1;0^8;25.06;0;1;0^9;25.07;0;1;0"
     111 S IBOK=$$STORE^IBCEOB1(A,IB0,IBEOB)
     112 I 'IBOK S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Bad record 17 data"
     113Q17 Q IBOK
     114 ;
     11520(IB0,IBEGBL,IBEOB) ; Record '20'
     116 ;
     117 N A,LEVEL,IBGRP,IBDA,IBOK
     118 ;
     119 S IBGRP=$P(IB0,U,3)
     120 I IBGRP'="" S ^TMP($J,20)=IBGRP
     121 I IBGRP="" S IBGRP=$G(^TMP($J,20))
     122 I IBGRP="" S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Missing claim level adjustment group code" G Q20
     123 ;
     124 S IBDA(1)=$O(^IBM(361.1,IBEOB,10,"B",IBGRP,0))
     125 ;
     126 I 'IBDA(1) D  ;Needs a new entry at group level
     127 . N X,Y,DA,DD,DO,DIC,DLAYGO
     128 . S DIC="^IBM(361.1,"_IBEOB_",10,",DIC(0)="L",DLAYGO=361.11,DA(1)=IBEOB
     129 . S DIC("P")=$$GETSPEC^IBEFUNC(361.1,10)
     130 . S X=IBGRP
     131 . D FILE^DICN K DIC,DO,DD,DLAYGO
     132 . I Y<0 K IBDA S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Adjustment group code could not be added" Q
     133 . S IBDA(1)=+Y
     134 ;
     135 I $G(IBDA(1)) D  ;Add a new entry at the reason code level
     136 . S DIC="^IBM(361.1,"_IBEOB_",10,"_IBDA(1)_",1,",DIC(0)="L",DLAYGO=361.111,DA(2)=IBEOB,DA(1)=IBDA(1)
     137 . S DIC("P")=$$GETSPEC^IBEFUNC(361.11,1)
     138 . S X=$P(IB0,U,4)
     139 . D FILE^DICN K DIC,DO,DD,DLAYGO
     140 . I Y<0 K IBDA S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Adjustment reason code could not be added" Q
     141 . S IBDA=+Y
     142 ;
     143 I $G(IBDA) D
     144 . S LEVEL=10,LEVEL("DIE")="^IBM(361.1,"_IBEOB_",10,"_IBDA(1)_",1,"
     145 . S LEVEL(0)=IBDA,LEVEL(1)=IBDA(1),LEVEL(2)=IBEOB
     146 . S A="5;.02;1;0;0^6;.03;0;1;1^7;.04;0;1;0"
     147 . S IBOK=$$STORE^IBCEOB1(A,IB0,IBEOB,.LEVEL)
     148 . I 'IBOK S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Bad adjustment reason code ("_$P(IB0,U,4)_") data" Q
     149Q20 Q $G(IBOK)
     150 ;
     15130(IB0,IBEGBL,IBEOB) ; Record '30'
     152 ;
     153 N IBOK
     154 D 30^IBCEOB0(IB0,IBEOB,.IBOK)
     155Q30 Q $G(IBOK)
     156 ;
     15735(IB0,IBEGBL,IBEOB) ; Record '35'
     158 ; Moved due to space constraints
     159Q35 Q $$35^IBCEOB00(IB0,IBEGBL,IBEOB)
     160 ;
     16137(IB0,IBEGBL,IBEOB) ; Record '37'
     162 ; Moved due to space constraints
     163Q37 Q $$37^IBCEOB00(IB0,IBEGBL,IBEOB)
     164 ;
     16540(IB0,IBEGBL,IBEOB) ; Record '40'
     166 ;
     167 N IBOK
     168 D 40^IBCEOB0(IB0,IBEOB,.IBOK)
     169Q40 Q $G(IBOK)
     170 ;
     17141(IB0,IBEGBL,IBEOB) ; Record '41'
     172 ;
     173 N IBOK
     174 D 41^IBCEOB0(IB0,IBEOB,.IBOK)
     175Q41 Q $G(IBOK)
     176 ;
     17742(IB0,IBEGBL,IBEOB) ; Record '42'
     178 ;
     179 N IBOK
     180 D 42^IBCEOB0(IB0,IBEOB,.IBOK)
     181Q42 Q $G(IBOK)
     182 ;
     18345(IB0,IBEGBL,IBEOB) ; Record '45'
     184 ;
     185 N IBOK
     186 D 45^IBCEOB0(IB0,IBEOB,.IBOK)
     187 Q $G(IBOK)
     188 ;
     189DOLLAR(X) ; Convert value in X to dollar format XXX.XX
     190 Q $S(+X:$J(X/100,$L(+X),2),1:0)
     191 ;
     192ADD3611(IBMNUM,IBTBILL,IBBATCH,X,IBAR,IBFILE) ; Add stub record to file 361.1
     193 ; X = the ien of the referenced bill in file 399
     194 ; IBTBILL = ien of transmitted bill (optional)
     195 ; IBBATCH = ien of batch # the transmitted bill was in (optional)
     196 ; IBMNUM = the message # from which this record originally came
     197 ; IBAR = 1 only if called from AR
     198 ; IBFILE = array reference of raw EOB data
     199 ;
     200 N DIC,DA,DR,DO,DD,DLAYGO,Y,REVSTAT,BS
     201 F  L +^IBM(361.1,0):10 Q:$T
     202 ;
     203 ; default proper review status
     204 S BS=$P($G(^DGCR(399,X,0)),U,13)   ; bill status
     205 S REVSTAT=$S(BS=7:9,BS=3:3,BS=4:3,1:0)
     206 S DIC(0)="L",DIC="^IBM(361.1,",DLAYGO=361.1
     207 S DIC("DR")=".16////"_REVSTAT_";.17////0"_";100.02////"_IBMNUM_$S('$G(IBAR):";.19////"_+IBTBILL_";100.01////"_IBBATCH,1:"")
     208 S DIC("DR")=DIC("DR")_";100.05////"_$$CHKSUM^IBCEMU1(IBFILE)
     209 D FILE^DICN
     210 L -^IBM(361.1,0)
     211 Q +Y
     212 ;
     213UPD3611(IBEOB,IBTDA,IBAR) ; From flat file 835 format, add EOB record
     214 ; IBEOB = the ien of the entry in file 361.1 being updated
     215 ; IBTDA = the ien in the source file
     216 ; IBAR = 1 if being called from AR
     217 N IBA1,IBFILE,IBEGBL,Z,IBREC,Q
     218 S IBFILE=$S('$G(IBAR):"^IBA(364.2,"_IBTDA_",2)",1:"^TMP("_$J_",""RCDP-EOB"","_IBTDA_")")
     219 S IBEGBL=$S('$G(IBAR):"IBCERR-EOB",1:"RCDPERR-EOB")
     220 I $G(IBAR),'$$HDR^IBCEOB1($G(^TMP($J,"RCDPEOB","HDR")),IBEGBL,IBEOB) Q
     221 S IBA1=0
     222 F  S IBA1=$O(@IBFILE@(IBA1)) Q:'IBA1  S IB0=$S('$G(IBAR):$P($G(^(IBA1,0)),"##RAW DATA: ",2),1:$G(@IBFILE@(IBA1,0))) I IB0'="" D
     223 . S IBREC=+IB0
     224 . I IBREC'=37 K ^TMP($J,37)
     225 . I IBREC S IB="S IBOK=$$"_IBREC_"(IB0,IBEGBL,IBEOB)",Q=IBREC_"^IBCEOB" I $T(@Q)'="" X IB S:'IBOK ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)=$S('$G(IBAR):"  ##RAW DATA: ",1:"")_IB0
     226 ;
     227 Q
     228 ;
     229ERRUPD(IBEOB,IBEGBL) ; Update error text in entry, if needed
     230 D WP^DIE(361.1,IBEOB_",",20,"","^TMP(IBEGBL,$J)","")
     231 Q
     232 ;
     233 ;
     234DUP(IBARRAY,IBIFN) ; Duplicate Check
     235 ; This function determines if the EOB data already exists in file
     236 ; 361.1 by comparing the checksums of the raw 835 data.
     237 ;
     238 ; IBARRAY = Literal array reference where the raw 835 data exists.
     239 ;           The data exists at @IBARRAY@(n,0), where n is the seq#.
     240 ;           For example, IBARRAY = "^IBA(364.2,IBIEN,2)"
     241 ;
     242 ; IBIFN = the bill # (ptr to 399).  The checksums of the EOB's on
     243 ;         file for this bill will be compared to the checksum of the
     244 ;         835 raw data in the IBARRAY reference.
     245 ;
     246 ; This function returns 0 if the entry is not found (no duplicate),
     247 ; Otherwise, the IEN of the entry in file 361.1 is returned if this
     248 ; is a duplicate EOB.
     249 ;
     250 NEW DUP,IBEOB,CHKSUM1,CHKSUM2
     251 S DUP=0,IBIFN=+$G(IBIFN)
     252 I $G(IBARRAY)=""!'IBIFN G DUPX
     253 I '$D(^IBM(361.1,"B",IBIFN)) G DUPX     ; no EOB's on file yet
     254 S CHKSUM1=$$CHKSUM^IBCEMU1(IBARRAY)     ; checksum of current EOB
     255 I 'CHKSUM1 G DUPX                       ; must be able to be calculated
     256 S IBEOB=0
     257 F  S IBEOB=$O(^IBM(361.1,"B",IBIFN,IBEOB)) Q:'IBEOB  D  Q:DUP
     258 . S CHKSUM2=+$P($G(^IBM(361.1,IBEOB,100)),U,5)   ; checksum of old EOB
     259 . I 'CHKSUM2 Q
     260 . I CHKSUM1=CHKSUM2 S DUP=IBEOB Q                    ; comparison
     261 . Q
     262DUPX ;
     263 Q DUP
     264 ;

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEOB00.m

    r613 r623  
    1 IBCEOB00        ;ALB/ESG - 835 EDI EOB MSG PROCESSING CONT ;30-JUN-2003
    2         ;;2.0;INTEGRATED BILLING;**155,349,377**;21-MAR-94;Build 23
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         Q
    5         ;
    6 RCRU(IBZDATA,IB0,IBLN)  ; Revenue Code Roll-up procedure check -
    7         ; Total up outbound line items by revenue code and compare with
    8         ; incoming EOB 40 record to see if it has been rolled up
    9         ;
    10         ; IBZDATA - UB output formatter array, passed by reference
    11         ; IB0     - 40 record data
    12         ; IBLN    - output parameter, passed by reference
    13         ;
    14         NEW Z,LN,REV,UN,CH,RUD,RUD2,UCH,MRAUCH
    15         I $P(IB0,U,4)="" G RCRUX
    16         S IBLN="",Z=0
    17         F  S Z=$O(IBZDATA(Z)) Q:'Z  S LN=IBZDATA(Z) D
    18         . S REV=$P(LN,U,1),UN=$P(LN,U,4),CH=$P(LN,U,5),UCH=+$P(LN,U,3)
    19         . I REV="" Q
    20         . ;
    21         . S RUD=$G(RUD(REV))                 ; roll up data array for rev code
    22         . S $P(RUD,U,1)=$P(RUD,U,1)+CH       ; total charges
    23         . S $P(RUD,U,2)=$P(RUD,U,2)+UN       ; total units
    24         . S $P(RUD,U,3)=$P(RUD,U,3)+1        ; total line items
    25         . S RUD(REV)=RUD
    26         . S RUD(REV,Z)=""
    27         . ;
    28         . S RUD2=$G(RUD2(REV,UCH))           ; roll up data array for rev code
    29         . S $P(RUD2,U,1)=$P(RUD2,U,1)+CH     ; total charges
    30         . S $P(RUD2,U,2)=$P(RUD2,U,2)+UN     ; total units
    31         . S $P(RUD2,U,3)=$P(RUD2,U,3)+1      ; total line items
    32         . S RUD2(REV,UCH)=RUD2
    33         . S RUD2(REV,UCH,Z)=""
    34         . ;
    35         . Q
    36         ;
    37         I '$D(RUD),'$D(RUD2) G RCRUX
    38         ;
    39         ; delete the revenue code roll-up, if only 1 line item.
    40         S REV=""     ; this is not a roll up situation
    41         F  S REV=$O(RUD(REV)) Q:REV=""  I $P(RUD(REV),U,3)=1 KILL RUD(REV)
    42         ;
    43         S (REV,UCH)=""
    44         F  S REV=$O(RUD2(REV)) Q:REV=""  F  S UCH=$O(RUD2(REV,UCH)) Q:UCH=""  I $P(RUD2(REV,UCH),U,3)=1 KILL RUD2(REV,UCH)
    45         ;
    46         I '$D(RUD),'$D(RUD2) G RCRUX
    47         ;
    48         S RUD=$G(RUD($P(IB0,U,4)))      ; compare with 40 record data
    49         I RUD="" G RCRU2                ; make sure it exists
    50         I $P(RUD,U,1)'=+$$DOLLAR^IBCEOB($P(IB0,U,15)) G RCRU2    ; charges
    51         I $P(RUD,U,2)'=$P(IB0,U,16) G RCRU2                      ; units
    52         S IBLN=$O(RUD($P(IB0,U,4),""))  ; use the first line# found
    53         G RCRUX
    54         ;
    55 RCRU2   ; check roll-up data by rev code and unit charge
    56         S MRAUCH=0
    57         I $P(IB0,U,16) S MRAUCH=+$$DOLLAR^IBCEOB($P(IB0,U,15))/$P(IB0,U,16)
    58         S RUD2=$G(RUD2($P(IB0,U,4),MRAUCH))     ; compare with 40 record data
    59         I RUD2="" G RCRUX                       ; make sure it exists
    60         I $P(RUD2,U,1)'=+$$DOLLAR^IBCEOB($P(IB0,U,15)) G RCRUX   ; charges
    61         I $P(RUD2,U,2)'=$P(IB0,U,16) G RCRUX                     ; units
    62         S IBLN=$O(RUD2($P(IB0,U,4),MRAUCH,""))  ; use the first line# found
    63         ;
    64 RCRUX   ;
    65         Q
    66         ;
    67 ICN(IBEOB,ICN,COBN,IBOK)        ; File the 835 ICN into the Bill
    68         ;
    69         ; Input parameters
    70         ;   IBEOB - ien to file 361.1
    71         ;   ICN   - the ICN# from the 835 transmission
    72         ;   COBN  - the insurance sequence#
    73         ;
    74         ; Output parameter
    75         ;   IBOK  - returns as 0 if we get a filing error here
    76         ;
    77         ; The field in file 399 depends on the current payer sequence
    78         ;     399,453 - primary ICN
    79         ;     399,454 - secondary ICN
    80         ;     399,455 - tertiary ICN
    81         ;
    82         NEW IBIFN,FIELD,D,D0,DA,DI,DIC,DIE,DQ,DR,X,Y
    83         S IBEOB=+$G(IBEOB),COBN=+$G(COBN)
    84         I 'IBEOB!'COBN G ICNX
    85         S IBIFN=+$P($G(^IBM(361.1,IBEOB,0)),U,1)
    86         I '$D(^DGCR(399,IBIFN)) G ICNX
    87         I $G(ICN)="" G ICNX
    88         I '$F(".1.2.3.","."_COBN_".") G ICNX
    89         ;
    90         S FIELD=452+COBN
    91         S DIE=399,DA=IBIFN,DR=FIELD_"////"_ICN D ^DIE
    92         S IBOK=($D(Y)=0)
    93         I 'IBOK S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Error in filing the ICN into the Bill/Claims file"
    94 ICNX    ;
    95         Q
    96         ;
    97 15(IB0,IBEGBL,IBEOB)    ; Record '15'
    98         ;
    99         N A,IBOK
    100         ;
    101         S A="3;1.03;1;0;0^4;1.04;1;0;0^5;1.05;1;0;0^6;1.07;1;0;0^7;1.08;1;0;0^8;1.09;1;0;0^9;1.02;1;0;0^10;2.05;1;0;0"
    102         ;
    103         S IBOK=$$STORE^IBCEOB1(A,IB0,IBEOB)
    104         I 'IBOK S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Bad record 15 data" G Q15
    105         ;
    106         ; For Medicare MRA's only:
    107         ; If the Covered Amount is present (15 record, piece 3), then file
    108         ; a claim level adjustment with Group code=OA, Reason code=AB3.
    109         ;
    110         I $P($G(^IBM(361.1,IBEOB,0)),U,4)=1,+$P(IB0,U,3) D
    111         . N IB20
    112         . S IB20=20_U_$P(IB0,U,2)_U_"OA"_U_"AB3"_U_$P(IB0,U,3)_U_"0000000000"
    113         . S IB20=IB20_U_"Covered Amount"
    114         . S IBOK=$$20(IB20,IBEGBL,IBEOB)
    115         . I 'IBOK S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Could not file the OA-AB3 claim level adjustment for the Covered Amount"
    116         . K ^TMP($J,20)
    117         . Q
    118         ;
    119 Q15     Q IBOK
    120         ;
    121 20(IB0,IBEGBL,IBEOB)    ; Record '20'
    122         ;
    123         N A,LEVEL,IBGRP,IBDA,IBOK
    124         ;
    125         S IBGRP=$P(IB0,U,3)
    126         I IBGRP'="" S ^TMP($J,20)=IBGRP
    127         I IBGRP="" S IBGRP=$G(^TMP($J,20))
    128         I IBGRP="" S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Missing claim level adjustment group code" G Q20
    129         ;
    130         S IBDA(1)=$O(^IBM(361.1,IBEOB,10,"B",IBGRP,0))
    131         ;
    132         I 'IBDA(1) D  ;Needs a new entry at group level
    133         . N X,Y,DA,DD,DO,DIC,DLAYGO
    134         . S DIC="^IBM(361.1,"_IBEOB_",10,",DIC(0)="L",DLAYGO=361.11,DA(1)=IBEOB
    135         . S DIC("P")=$$GETSPEC^IBEFUNC(361.1,10)
    136         . S X=IBGRP
    137         . D FILE^DICN K DIC,DO,DD,DLAYGO
    138         . I Y<0 K IBDA S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Adjustment group code could not be added" Q
    139         . S IBDA(1)=+Y
    140         ;
    141         I $G(IBDA(1)) D  ;Add a new entry at the reason code level
    142         . S DIC="^IBM(361.1,"_IBEOB_",10,"_IBDA(1)_",1,",DIC(0)="L",DLAYGO=361.111,DA(2)=IBEOB,DA(1)=IBDA(1)
    143         . S DIC("P")=$$GETSPEC^IBEFUNC(361.11,1)
    144         . S X=$P(IB0,U,4)
    145         . D FILE^DICN K DIC,DO,DD,DLAYGO
    146         . I Y<0 K IBDA S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Adjustment reason code could not be added" Q
    147         . S IBDA=+Y
    148         ;
    149         I $G(IBDA) D
    150         . S LEVEL=10,LEVEL("DIE")="^IBM(361.1,"_IBEOB_",10,"_IBDA(1)_",1,"
    151         . S LEVEL(0)=IBDA,LEVEL(1)=IBDA(1),LEVEL(2)=IBEOB
    152         . S A="5;.02;1;0;0^6;.03;0;1;1^7;.04;0;1;0"
    153         . S IBOK=$$STORE^IBCEOB1(A,IB0,IBEOB,.LEVEL)
    154         . I 'IBOK S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Bad adjustment reason code ("_$P(IB0,U,4)_") data" Q
    155 Q20     Q $G(IBOK)
    156         ;
    157 35(IB0,IBEGBL,IBEOB)    ; Record '35'
    158         ;
    159         N A,IBOK
    160         ;
    161         S A="3;4.12;1;0;0^4;4.13;1;0;0^5;4.14;0;1;1^6;4.15;1;0;0^7;4.16;1;0;0^8;4.17;1;0;0^9;4.18;1;0;0^10;4.04;1;0;0^11;3.01;0;1;1^12;3.02;1;0;0^13;3.08;1;0;0^14;3.09;1;0;0"
    162         ;
    163         S IBOK=$$STORE^IBCEOB1(A,IB0,IBEOB)
    164         I 'IBOK S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Bad MEDICARE Inpt Adjudication data"
    165 Q35     Q $G(IBOK)
    166         ;
    167 37(IB0,IBEGBL,IBEOB)    ; Record '37'
    168         ;
    169         N IBOK,IBCT
    170         S IBCT=$G(^TMP($J,37))+1
    171         I IBCT>5 S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Too many Medicare Claim Level Adjudication Remarks" G Q37    ; Max 5 allowed
    172         S A="4;"_$S($P(IB0,U,3)="O":"3.0"_(IBCT+2),1:"5.0"_IBCT)_";0;0;0^5;5.0"_IBCT_"1;0;0;0"
    173         S IBOK=$$STORE^IBCEOB1(A,IB0,IBEOB)
    174         I 'IBOK S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Bad Medicare Claim Level Adjudication Remarks data"
    175         ;
    176         ; 4/22/03 - esg - If claim level remark code MA15 is reported, then
    177         ;         this is a split EOB and we need to change the REVIEW STATUS
    178         ;         of this EOB to be ACCEPTED-INTERIM EOB.
    179         ;
    180         I $P(IB0,U,4)["MA15" D
    181         . N DA,DIE,DR,DIC
    182         . S DA=IBEOB,DIE=361.1,DR=".16////2" D ^DIE S IBOK=($D(Y)=0)
    183         . I 'IBOK S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Split EOB, but review status was not updated correctly"
    184         . Q
    185         ;
    186 Q37     S ^TMP($J,37)=$G(^TMP($J,37))+1 ; Saves the # of entries for 37 records
    187         Q $G(IBOK)
    188         ;
    189         ;
    190 DET40(IB0,ARRAY)        ; Format important details of record 40 for error
    191         ; IB0 = data on 40 record (some pieces pre-formatted)
    192         ;  ARRAY(n)=formatted line is returned if passed by ref
    193         N Q
    194         S ARRAY(1)="Payer reported the following was billed to them:"
    195         S ARRAY(2)=" "_$S($P(IB0,U,21)="NU":"Rev Cd",1:"Proc")_": "_$S($P(IB0,U,10)'="":$P(IB0,U,10),1:"Same as adjudicated")_"  Chg: "_$J($P(IB0,U,15)/100,"",2)_"  Units: "_$S($P(IB0,U,16):$P(IB0,U,16),1:1)
    196         S ARRAY(3)="  Svc Date(s): "_$S($P(IB0,U,19)'="":$$FDT($P(IB0,U,19)),1:"??")_$S($P(IB0,U,20)'="":"-"_$$FDT($P(IB0,U,20)),1:"")
    197         I $P(IB0,U,11)'="" S ARRAY(3)=ARRAY(3)_"  Mods: " F Q=11:1:14 I $P(IB0,U,Q)'="" S ARRAY(3)=ARRAY(3)_$P(IB0,U,Q)_$S(Q=14:"",$P(IB0,U,Q+1)'="":",",1:"")
    198         S ARRAY(4)="Payer reported adjudication on:"
    199         S ARRAY(5)=" "_$S($P(IB0,U,21)="NU":"Rev Cd",1:"Proc")_": "_$S($P(IB0,U,3)'="":$P(IB0,U,3),1:$P(IB0,U,4))
    200         S ARRAY(5)=ARRAY(5)_"  Type: "_$P(IB0,U,21)_$S($P(IB0,U,21)'="NU":"  Rev Cd: "_$P(IB0,U,4),1:"")_"  Units: "_$S($P(IB0,U,18):$P(IB0,U,18)/100,1:1)_"  Amt: "_$J($P(IB0,U,17)/100,"",2)
    201         I $P(IB0,U,5)'="" S ARRAY(5)=ARRAY(5)_"  Mods: " F Q=5:1:8 I $P(IB0,U,Q)'="" S ARRAY(5)=ARRAY(5)_$P(IB0,U,Q)_$S(Q=8:"",$P(IB0,U,Q+1)'="":",",1:"")
    202         Q
    203         ;
    204 DET4X(RECID,IB0,ARRAY)  ; Format important details of record 41-45 for error
    205         ; RECID = 41,42,45
    206         ; IB0 = data on RECID record
    207         ;  ARRAY(n)=formatted line is returned if passed by ref
    208         N CT,Q
    209         I RECID=41 D  Q
    210         . S ARRAY(1)="Allowed Amt: "_$J($P(IB0,U,3)/100,"",2)_"  Per Diem Amt: "_$J($P(IB0,U,4)/100,"",2)
    211         ;
    212         I RECID=42 D  Q
    213         . S ARRAY(1)="Line Item Remark Code: "_$P(IB0,U,3)
    214         . I $P(IB0,U,4)'="" S CT=1 F Q=0:80:190 I $E($P(IB0,U,4),Q+1,Q+80)'="" S CT=CT+1,ARRAY(CT)=$E($P(IB0,U,4),Q+1,Q+80)
    215         ;
    216         I RECID=45 D
    217         . S ARRAY(1)="Adj Group Cd: "_$P(IB0,U,3)_"  Reason Cd: "_$P(IB0,U,4)_"  Amt: "_$J($P(IB0,U,5)/100,"",2)_"  Quantity: "_+$P(IB0,U,6)
    218         . I $P(IB0,U,7)'="" S CT=1 F Q=0:80:190 I $E($P(IB0,U,7),Q+1,Q+80)'="" S CT=CT+1,ARRAY(CT)=$E($P(IB0,U,7),Q+1,Q+80)
    219         Q
    220         ;
    221 FDT(X)  ; Format date in X (YYYYMMDD) to MM/DD/YYYY
    222         S:X'="" X=$E(X,5,6)_"/"_$E(X,7,8)_"/"_$E(X,1,4)
    223         Q X
    224         ;
     1IBCEOB00 ;ALB/ESG - 835 EDI EOB MSG PROCESSING CONT ;30-JUN-2003
     2 ;;2.0;INTEGRATED BILLING;**155,349**;21-MAR-94;Build 46
     3 ;;Per VHA Directive 2004-038, this routine should not be modified.
     4 Q
     5 ;
     6RCRU(IBZDATA,IB0,IBLN) ; Revenue Code Roll-up procedure check -
     7 ; Total up outbound line items by revenue code and compare with
     8 ; incoming EOB 40 record to see if it has been rolled up
     9 ;
     10 ; IBZDATA - UB output formatter array, passed by reference
     11 ; IB0     - 40 record data
     12 ; IBLN    - output parameter, passed by reference
     13 ;
     14 NEW Z,LN,REV,UN,CH,RUD,RUD2,UCH,MRAUCH
     15 I $P(IB0,U,4)="" G RCRUX
     16 S IBLN="",Z=0
     17 F  S Z=$O(IBZDATA(Z)) Q:'Z  S LN=IBZDATA(Z) D
     18 . S REV=$P(LN,U,1),UN=$P(LN,U,4),CH=$P(LN,U,5),UCH=+$P(LN,U,3)
     19 . I REV="" Q
     20 . ;
     21 . S RUD=$G(RUD(REV))                 ; roll up data array for rev code
     22 . S $P(RUD,U,1)=$P(RUD,U,1)+CH       ; total charges
     23 . S $P(RUD,U,2)=$P(RUD,U,2)+UN       ; total units
     24 . S $P(RUD,U,3)=$P(RUD,U,3)+1        ; total line items
     25 . S RUD(REV)=RUD
     26 . S RUD(REV,Z)=""
     27 . ;
     28 . S RUD2=$G(RUD2(REV,UCH))           ; roll up data array for rev code
     29 . S $P(RUD2,U,1)=$P(RUD2,U,1)+CH     ; total charges
     30 . S $P(RUD2,U,2)=$P(RUD2,U,2)+UN     ; total units
     31 . S $P(RUD2,U,3)=$P(RUD2,U,3)+1      ; total line items
     32 . S RUD2(REV,UCH)=RUD2
     33 . S RUD2(REV,UCH,Z)=""
     34 . ;
     35 . Q
     36 ;
     37 I '$D(RUD),'$D(RUD2) G RCRUX
     38 ;
     39 ; delete the revenue code roll-up, if only 1 line item.
     40 S REV=""     ; this is not a roll up situation
     41 F  S REV=$O(RUD(REV)) Q:REV=""  I $P(RUD(REV),U,3)=1 KILL RUD(REV)
     42 ;
     43 S (REV,UCH)=""
     44 F  S REV=$O(RUD2(REV)) Q:REV=""  F  S UCH=$O(RUD2(REV,UCH)) Q:UCH=""  I $P(RUD2(REV,UCH),U,3)=1 KILL RUD2(REV,UCH)
     45 ;
     46 I '$D(RUD),'$D(RUD2) G RCRUX
     47 ;
     48 S RUD=$G(RUD($P(IB0,U,4)))      ; compare with 40 record data
     49 I RUD="" G RCRU2                ; make sure it exists
     50 I $P(RUD,U,1)'=+$$DOLLAR^IBCEOB($P(IB0,U,15)) G RCRU2    ; charges
     51 I $P(RUD,U,2)'=$P(IB0,U,16) G RCRU2                      ; units
     52 S IBLN=$O(RUD($P(IB0,U,4),""))  ; use the first line# found
     53 G RCRUX
     54 ;
     55RCRU2 ; check roll-up data by rev code and unit charge
     56 S MRAUCH=0
     57 I $P(IB0,U,16) S MRAUCH=+$$DOLLAR^IBCEOB($P(IB0,U,15))/$P(IB0,U,16)
     58 S RUD2=$G(RUD2($P(IB0,U,4),MRAUCH))     ; compare with 40 record data
     59 I RUD2="" G RCRUX                       ; make sure it exists
     60 I $P(RUD2,U,1)'=+$$DOLLAR^IBCEOB($P(IB0,U,15)) G RCRUX   ; charges
     61 I $P(RUD2,U,2)'=$P(IB0,U,16) G RCRUX                     ; units
     62 S IBLN=$O(RUD2($P(IB0,U,4),MRAUCH,""))  ; use the first line# found
     63 ;
     64RCRUX ;
     65 Q
     66 ;
     67ICN(IBEOB,ICN,COBN,IBOK) ; File the 835 ICN into the Bill
     68 ;
     69 ; Input parameters
     70 ;   IBEOB - ien to file 361.1
     71 ;   ICN   - the ICN# from the 835 transmission
     72 ;   COBN  - the insurance sequence#
     73 ;
     74 ; Output parameter
     75 ;   IBOK  - returns as 0 if we get a filing error here
     76 ;
     77 ; The field in file 399 depends on the current payer sequence
     78 ;     399,453 - primary ICN
     79 ;     399,454 - secondary ICN
     80 ;     399,455 - tertiary ICN
     81 ;
     82 NEW IBIFN,FIELD,D,D0,DA,DI,DIC,DIE,DQ,DR,X,Y
     83 S IBEOB=+$G(IBEOB),COBN=+$G(COBN)
     84 I 'IBEOB!'COBN G ICNX
     85 S IBIFN=+$P($G(^IBM(361.1,IBEOB,0)),U,1)
     86 I '$D(^DGCR(399,IBIFN)) G ICNX
     87 I $G(ICN)="" G ICNX
     88 I '$F(".1.2.3.","."_COBN_".") G ICNX
     89 ;
     90 S FIELD=452+COBN
     91 S DIE=399,DA=IBIFN,DR=FIELD_"////"_ICN D ^DIE
     92 S IBOK=($D(Y)=0)
     93 I 'IBOK S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Error in filing the ICN into the Bill/Claims file"
     94ICNX ;
     95 Q
     96 ;
     9735(IB0,IBEGBL,IBEOB) ; Record '35'
     98 ;
     99 N A,IBOK
     100 ;
     101 S A="3;4.12;1;0;0^4;4.13;1;0;0^5;4.14;0;1;1^6;4.15;1;0;0^7;4.16;1;0;0^8;4.17;1;0;0^9;4.18;1;0;0^10;4.04;1;0;0^11;3.01;0;1;1^12;3.02;1;0;0^13;3.08;1;0;0^14;3.09;1;0;0"
     102 ;
     103 S IBOK=$$STORE^IBCEOB1(A,IB0,IBEOB)
     104 I 'IBOK S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Bad MEDICARE Inpt Adjudication data"
     105Q35 Q $G(IBOK)
     106 ;
     10737(IB0,IBEGBL,IBEOB) ; Record '37'
     108 ;
     109 N IBOK,IBCT
     110 S IBCT=$G(^TMP($J,37))+1
     111 I IBCT>5 S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Too many Medicare Claim Level Adjudication Remarks" G Q37    ; Max 5 allowed
     112 S A="4;"_$S($P(IB0,U,3)="O":"3.0"_(IBCT+2),1:"5.0"_IBCT)_";0;0;0^5;5.0"_IBCT_"1;0;0;0"
     113 S IBOK=$$STORE^IBCEOB1(A,IB0,IBEOB)
     114 I 'IBOK S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Bad Medicare Claim Level Adjudication Remarks data"
     115 ;
     116 ; 4/22/03 - esg - If claim level remark code MA15 is reported, then
     117 ;         this is a split EOB and we need to change the REVIEW STATUS
     118 ;         of this EOB to be ACCEPTED-INTERIM EOB.
     119 ;
     120 I $P(IB0,U,4)["MA15" D
     121 . N DA,DIE,DR,DIC
     122 . S DA=IBEOB,DIE=361.1,DR=".16////2" D ^DIE S IBOK=($D(Y)=0)
     123 . I 'IBOK S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Split EOB, but review status was not updated correctly"
     124 . Q
     125 ;
     126Q37 S ^TMP($J,37)=$G(^TMP($J,37))+1 ; Saves the # of entries for 37 records
     127 Q $G(IBOK)
     128 ;
     129 ;
     130DET40(IB0,ARRAY) ; Format important details of record 40 for error
     131 ; IB0 = data on 40 record (some pieces pre-formatted)
     132 ;  ARRAY(n)=formatted line is returned if passed by ref
     133 N Q
     134 S ARRAY(1)="Payer reported the following was billed to them:"
     135 S ARRAY(2)=" "_$S($P(IB0,U,21)="NU":"Rev Cd",1:"Proc")_": "_$S($P(IB0,U,10)'="":$P(IB0,U,10),1:"Same as adjudicated")_"  Chg: "_$J($P(IB0,U,15)/100,"",2)_"  Units: "_$S($P(IB0,U,16):$P(IB0,U,16),1:1)
     136 S ARRAY(3)="  Svc Date(s): "_$S($P(IB0,U,19)'="":$$FDT($P(IB0,U,19)),1:"??")_$S($P(IB0,U,20)'="":"-"_$$FDT($P(IB0,U,20)),1:"")
     137 I $P(IB0,U,11)'="" S ARRAY(3)=ARRAY(3)_"  Mods: " F Q=11:1:14 I $P(IB0,U,Q)'="" S ARRAY(3)=ARRAY(3)_$P(IB0,U,Q)_$S(Q=14:"",$P(IB0,U,Q+1)'="":",",1:"")
     138 S ARRAY(4)="Payer reported adjudication on:"
     139 S ARRAY(5)=" "_$S($P(IB0,U,21)="NU":"Rev Cd",1:"Proc")_": "_$S($P(IB0,U,3)'="":$P(IB0,U,3),1:$P(IB0,U,4))
     140 S ARRAY(5)=ARRAY(5)_"  Type: "_$P(IB0,U,21)_$S($P(IB0,U,21)'="NU":"  Rev Cd: "_$P(IB0,U,4),1:"")_"  Units: "_$S($P(IB0,U,18):$P(IB0,U,18)/100,1:1)_"  Amt: "_$J($P(IB0,U,17)/100,"",2)
     141 I $P(IB0,U,5)'="" S ARRAY(5)=ARRAY(5)_"  Mods: " F Q=5:1:8 I $P(IB0,U,Q)'="" S ARRAY(5)=ARRAY(5)_$P(IB0,U,Q)_$S(Q=8:"",$P(IB0,U,Q+1)'="":",",1:"")
     142 Q
     143 ;
     144DET4X(RECID,IB0,ARRAY) ; Format important details of record 41-45 for error
     145 ; RECID = 41,42,45
     146 ; IB0 = data on RECID record
     147 ;  ARRAY(n)=formatted line is returned if passed by ref
     148 N CT,Q
     149 I RECID=41 D  Q
     150 . S ARRAY(1)="Allowed Amt: "_$J($P(IB0,U,3)/100,"",2)_"  Per Diem Amt: "_$J($P(IB0,U,4)/100,"",2)
     151 ;
     152 I RECID=42 D  Q
     153 . S ARRAY(1)="Line Item Remark Code: "_$P(IB0,U,3)
     154 . I $P(IB0,U,4)'="" S CT=1 F Q=0:80:190 I $E($P(IB0,U,4),Q+1,Q+80)'="" S CT=CT+1,ARRAY(CT)=$E($P(IB0,U,4),Q+1,Q+80)
     155 ;
     156 I RECID=45 D
     157 . S ARRAY(1)="Adj Group Cd: "_$P(IB0,U,3)_"  Reason Cd: "_$P(IB0,U,4)_"  Amt: "_$J($P(IB0,U,5)/100,"",2)_"  Quantity: "_+$P(IB0,U,6)
     158 . I $P(IB0,U,7)'="" S CT=1 F Q=0:80:190 I $E($P(IB0,U,7),Q+1,Q+80)'="" S CT=CT+1,ARRAY(CT)=$E($P(IB0,U,7),Q+1,Q+80)
     159 Q
     160 ;
     161FDT(X) ; Format date in X (YYYYMMDD) to MM/DD/YYYY
     162 S:X'="" X=$E(X,5,6)_"/"_$E(X,7,8)_"/"_$E(X,1,4)
     163 Q X
     164 ;
     165UPDNM(IBEOB,IB0,IBBULL,IBDR) ; Update name on claim if it comes back changed
     166 ; IBEOB = the internal entry # of the entry in file 361.1
     167 ; IB0 = the raw data returned from the 835 flat file
     168 ; IBBULL = holds result of name change check in piece 1 - if name
     169 ;          changed, first '^' piece is 1, 3rd '^' piece is the old
     170 ;          insured's name
     171 ; IBDR = returned as the updated 'DR' string with the name changed
     172 ;       fields to use to update the EOB file (361.1) - pass by reference
     173 ;
     174 N IBCHGED,IBIFN,IBNEW,IBCOB,DIE,DR,X,Y
     175 I $P(IB0,U,7) D
     176 . S IBNEW=$P(IB0,U,3)_","_$P(IB0,U,4)_$S($P(IB0,U,5)'="":" "_$P(IB0,U,5),1:""),$P(IBBULL,U)=1
     177 . S IBCOB=+$P($G(^IBM(361.1,IBEOB,0)),U,15)
     178 . S IBIFN=+$G(^IBM(361.1,+IBEOB,0))
     179 . S IB=$G(^DGCR(399,IBIFN,"I"_IBCOB))
     180 . ;
     181 . I IB'="",$P(IB,U,17)'=IBNEW D
     182 .. ; Update the claim data only
     183 .. S $P(IBBULL,U,3)=$P(IB,U,17) ; save old value
     184 .. S $P(IB,U,17)=IBNEW
     185 .. S DIE="^DGCR(399,",DA=IBIFN,DR="30"_IBCOB_"////"_IB
     186 .. D:DA ^DIE
     187 .. S IBCHGED=1
     188 . S IBDR=$G(IBDR)_"6.01////"_$P(IB0,U,3)_","_$P(IB0,U,4)_" "_$P(IB0,U,5)_";"
     189 ;
     190 Q $G(IBCHGED)
     191 ;
     192UPDID(IBEOB,IB0,IBBULL,IBDR) ; Update id # on claim and policy if it comes back
     193 ;   changed
     194 ; IBEOB = the internal entry # of the entry in file 361.1
     195 ; IB0 = the raw data returned from the 835 flat file
     196 ; IBBULL = holds result of id change check in piece 2 - if id changed,
     197 ;          second '^' piece = 1,4th '^' piece is the old insured's id
     198 ; IBDR = returned as the updated 'DR' string with the id changed fields
     199 ;        to use to update the EOB file (361.1) - pass by reference
     200 ;
     201 N IBCHGED,IBNEW,IBCOB,IB,DIE,DR,DA,X,Y
     202 I $P(IB0,U,8) D
     203 . S IBNEW=$P(IB0,U,6),$P(IBBULL,U,2)=1
     204 . S IBIFN=+$G(^IBM(361.1,+IBEOB,0))
     205 . S IBCOB=+$P($G(^IBM(361.1,IBEOB,0)),U,15)
     206 . S IB=$G(^DGCR(399,IBIFN,"I"_IBCOB))
     207 . ;
     208 . I IB'="",$P(IB,U,2)'=IBNEW D
     209 .. ; Update the claim
     210 .. S $P(IBBULL,U,4)=$P(IB,U,2) ; save old value
     211 .. S $P(IB,U,2)=IBNEW
     212 .. S DIE="^DGCR(399,",DA=IBIFN,DR="30"_IBCOB_"////"_IB D ^DIE
     213 .. ;
     214 .. ; Update the policy
     215 .. S DA(1)=$P($G(^DGCR(399,IBIFN,0)),U,2),DA=$P($G(^("M")),U,(11+IBCOB)),DR="1////"_IBNEW,DIE="^DPT("_DA(1)_",.312,"
     216 .. I DA(1),DA D ^DIE
     217 .. S IBCHGED=1
     218 . S IBDR=$G(IBDR)_"6.02////"_$P(IB0,U,6)_";"
     219 ;
     220 Q $G(IBCHGED)
     221 ;

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP0.m

    r613 r623  
    1 IBCEP0  ;ALB/TMP - Functions for PROVIDER ID MAINTENANCE ;13-DEC-99
    2         ;;2.0;INTEGRATED BILLING;**137,191,239,232,320,348,349,377**;21-MAR-94;Build 23
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5 EN      ; -- main entry point for IBCE PRV INS ID
    6         N IBINS,IBDSP,IBSORT,IBPRV ; Variables should be available throughout actions
    7         K IBFASTXT
    8         D FULL^VALM1
    9         D EN^VALM("IBCE PRVINS ID")
    10         Q
    11         ;
    12 EN1(IBINS)      ; Entrypoint from insurance co maintenance
    13         N IBDSP,IBSORT ; Variables should be available throughout actions
    14         D FULL^VALM1
    15         D EN^VALM("IBCE PRVINS ID FROM INS MAINT")
    16         Q
    17         ;
    18 HDR     ; -- header code
    19         N Z,Z0,Z1,IBCT,IBPPTYP,IBEMCTYP
    20         S IBCT=1
    21         K VALMHDR
    22         I $G(IBINS) D
    23         . N PCF,PCDISP
    24         . S PCF=$P($G(^DIC(36,+IBINS,3)),U,13)
    25         . S PCDISP=$S(PCF="C":"(Child)",PCF="P":"(Parent)",1:"")
    26         . S VALMHDR(1)="Insurance Co: "_$P($G(^DIC(36,+IBINS,0)),U)_" "_PCDISP
    27         . ; Get performing provider id type for insurance co
    28         . S IBPPTYP=$$PPTYP(IBINS)
    29         . ; Get ien of EMC ID from file 355.97
    30         . S IBEMCTYP=+$$EMCID^IBCEP()
    31         . I $G(IBSORT)="ALL"!($G(IBDSP)="I")!($G(IBSORT)=IBPPTYP)!($G(IBSORT)=IBEMCTYP) D
    32         .. ; Look for care unit in either of these id types - if there, report on line 2 of header
    33         .. I $G(IBSORT)=IBPPTYP S IBEMCTYP=0
    34         .. I $G(IBSORT)=IBEMCTYP S IBPPTYP=0
    35         .. F Z0=IBPPTYP_"P",IBEMCTYP_"E" S Z1="" F  S Z1=$O(^IBA(355.96,"D",+IBINS,+Z0,Z1)) Q:Z1=""  I Z1'="*N/A*" S Z($E(Z0,$L(Z0)))=1 Q
    36         .. I $D(Z("P"))!$D(Z("E")) D
    37         ... S IBCT=IBCT+1
    38         ... S VALMHDR(IBCT)="  "_$S($D(Z("P")):"PERFORMING PROV ID"_$S($D(Z("E")):" AND ",1:""),1:"")_$S($D(Z("E")):"EMC PROV ID",1:"")_" MAY REQUIRE CARE UNIT"
    39         . I $D(Z("P"))!$D(Z("E")) S IBCT=IBCT+1,VALMHDR(IBCT)=" "
    40         . S IBCT=IBCT+1,VALMHDR(IBCT)="     PROVIDER "_$S($G(IBDSP)="I":"ID TYPE",1:"NAME   ")_$J("",6)_"FORM   CARE TYPE    CARE UNIT       ID#"
    41         Q
    42         ;
    43 INIT    ; Initialization
    44         K ^TMP("IB_EDITED_IDS",$J)  ; This will be to keep track of ID's edited during this session
    45         D INSID(.IBINS,.IBDSP,.IBSORT)
    46         I $G(IBDSP)="I",$G(IBSORT) S IBPRV=IBSORT
    47         I '$G(IBINS) S VALMQUIT=1
    48         Q
    49         ;
    50 INSID(IBINS,IBDSP,IBSORT)       ;
    51         N DIC,DIR,DA,X,Y,IBOK,DTOUT,DUOUT
    52         S IBOK=1
    53         I '$G(IBINS) D
    54         . S DIC(0)="AEMQ",DIC="^DIC(36," D ^DIC
    55         . I Y'>0 S IBOK=0 Q
    56         . S IBINS=+Y
    57         I '$G(IBINS) S IBOK=0
    58         I 'IBOK G INSIDQ
    59         ;
    60         S DIR(0)="SA^D:INSURANCE CO DEFAULT IDS;I:INDIVIDUAL PROVIDER IDS FURNISHED BY THE INS CO;A:ALL IDS FURNISHED BY THE INS CO BY PROVIDER TYPE"
    61         S DIR("A")="SELECT DISPLAY CONTENT: ",DIR("B")="A"
    62         S DIR("?",1)="(D) DISPLAY CONTAINS ONLY THOSE IDS ASSIGNED AS DEFAULTS TO THE FACILITY BY",DIR("?",2)="    THE INSURANCE COMPANY"
    63         S DIR("?",3)="(I) DISPLAY CONTAINS ONLY THOSE IDS ASSIGNED TO INDIVIDUAL PROVIDERS BY THE",DIR("?",4)="    INSURANCE COMPANY"
    64         S DIR("?",5)="(A) DISPLAY CONTAINS ALL IDS ASSIGNED BY THE INSURANCE COMPANY FOR ONE OR ALL",DIR("?")="    PROVIDER ID TYPES"
    65         W ! D ^DIR K DIR W !
    66         I $D(DTOUT)!$D(DUOUT)!("DIA"'[Y) S IBOK=0 G INSIDQ
    67         S IBDSP=Y,IBSORT=""
    68         I IBDSP="A"!(IBDSP="I") F  D  Q:'IBOK!(IBSORT'="")
    69         . ;
    70         . I IBDSP="A" D
    71         .. S DIR("A")="Display only IDs with a specific ID Qualifier?: "
    72         .. S DIR("?",1)="Answer Yes to select a specific ID Qualifier by which to display IDs."
    73         .. S DIR("?")="Answer No to display all IDs."
    74         .. Q
    75         . ;
    76         . I IBDSP="I" D
    77         .. S DIR("A")="Display IDs for a specific Provider?: "
    78         .. S DIR("?",1)="Answer Yes to select a specific Provider."
    79         .. S DIR("?")="Answer No to display all Providers."
    80         .. Q
    81         . ;
    82         . S DIR("B")="NO",DIR(0)="YA"
    83         . W ! D ^DIR K DIR W !
    84         . I $D(DTOUT)!$D(DUOUT) S IBOK=0 Q
    85         . I Y'=1 S IBSORT="ALL" Q
    86         . ;
    87         . I IBDSP="A" D  Q
    88         .. S DIC(0)="AEMQ",DIC="^IBE(355.97,",DIC("S")="I $S('$P(^(0),U,2):1,1:$P(^(0),U,2)=3)"
    89         .. S DIC("A")="Select type of ID Qualifier: "
    90         .. D ^DIC K DIC
    91         .. I Y>0 S IBSORT=+Y Q
    92         .. I $D(DTOUT)!$D(DUOUT) S IBOK=0
    93         . ;
    94         . I IBDSP="I" D  Q
    95         .. N DA
    96         .. S DIR(0)="399.0222,.02A",DIR("A")="SELECT PROVIDER: "
    97         .. W ! D ^DIR K DIR W !
    98         .. I Y>0 S IBSORT=Y Q
    99         .. I $D(DTOUT)!$D(DUOUT) S IBOK=0 Q
    100         . S IBOK=0 Q
    101         ;
    102         G:'IBOK INSIDQ
    103         D BLD(IBINS,IBDSP,IBSORT)
    104 INSIDQ  I 'IBOK S VALMQUIT=1
    105         Q
    106         ;
    107 BLD(IBINS,IBDSP,IBSORT) ; Build display for Insurance co level provider ID's
    108         N IB,IBENT,IBLCT,IBCT,IBPRV,IBSRT1,IBSRT2,IBOSRT1,IBOSRT2,CU,FT,PT,CT,Z,Z0
    109         K ^TMP("IBPRV_INS_ID",$J),^TMP("IBPRV_INS_SORT",$J)
    110         ;
    111         S (IBENT,IBCT,IBLCT)=0
    112         ;
    113         I "DA"[$G(IBDSP) D
    114         . S CU="" F  S CU=$O(^IBA(355.91,"AUNIQ",IBINS,CU)) Q:CU=""  S FT="" F  S FT=$O(^IBA(355.91,"AUNIQ",IBINS,CU,FT)) Q:FT=""  D
    115         .. S CT="" F  S CT=$O(^IBA(355.91,"AUNIQ",IBINS,CU,FT,CT)) Q:CT=""  S PT=0 F  S PT=$S(IBDSP="A"&IBSORT:IBSORT,1:$O(^IBA(355.91,"AUNIQ",IBINS,CU,FT,CT,PT))) Q:'PT  D  Q:IBDSP="A"&IBSORT
    116         ... S Z=0 F  S Z=$O(^IBA(355.91,"AUNIQ",IBINS,CU,FT,CT,PT,Z)) Q:'Z  S IB=$G(^IBA(355.91,Z,0)) S ^TMP("IBPRV_INS_SORT",$J,PT,"^<<INS CO DEFAULT>>",FT,CT,CU,Z)=$P(IB,U,7)_U
    117         ;
    118         I "IA"[$G(IBDSP) D
    119         . S IBPRV=""
    120         . N IB1,IB2
    121         . F  S IBPRV=$O(^IBA(355.9,"AE",IBINS,IBPRV)) Q:'IBPRV  S Z=0 F  S Z=$O(^IBA(355.9,"AE",IBINS,IBPRV,Z)) Q:'Z  S IB=$G(^IBA(355.9,Z,0)) D
    122         .. Q:$P(IB,U,4)=""!($P(IB,U,5)="")!($P(IB,U,6)="")!($P(IB,U,16)="")
    123         .. I IBSORT,$S(IBDSP="I":IBPRV'=IBSORT,1:$P(IB,U,6)'=IBSORT) Q
    124         .. S IB1=$S(IBDSP="A":$P(IB,U,6),1:U_$$EXPAND^IBTRE(355.9,.01,IBPRV)_U_IBPRV)
    125         .. S IB2=$S(IBDSP="I":$P(IB,U,6),1:U_$$EXPAND^IBTRE(355.9,.01,IBPRV)_U_IBPRV)
    126         .. S ^TMP("IBPRV_INS_SORT",$J,IB1,IB2,$P(IB,U,4),$P(IB,U,5),$P(IB,U,16),Z)=$P(IB,U,7)_U_IBPRV
    127         ;
    128         S IBOSRT1=""
    129         S IBSRT1="" F  S IBSRT1=$O(^TMP("IBPRV_INS_SORT",$J,IBSRT1)) Q:IBSRT1=""  D
    130         . S IBSRT2="",IBOSRT2=""
    131         . F  S IBSRT2=$O(^TMP("IBPRV_INS_SORT",$J,IBSRT1,IBSRT2)) Q:IBSRT2=""  D
    132         .. I IBOSRT1'=IBSRT1 D
    133         ... I IBOSRT1'="" S IBLCT=IBLCT+1 D SET^VALM10(IBLCT," ",IBCT+1)
    134         ... S IBLCT=IBLCT+1 D SET^VALM10(IBLCT,$S(IBDSP'="I":"ID Qualifier",1:"Provider")_": "_$S(IBDSP'="I":$$EXPAND^IBTRE(355.91,.06,IBSRT1),1:$P(IBSRT1,U,2_$S($P(IBSRT2,U,3)["VA(200":" (VA)",1:"(NON-VA)"))),IBCT+1)
    135         ... S IBOSRT1=IBSRT1
    136         .. ;
    137         .. S FT="" F  S FT=$O(^TMP("IBPRV_INS_SORT",$J,IBSRT1,IBSRT2,FT)) Q:FT=""  S CT="" F  S CT=$O(^TMP("IBPRV_INS_SORT",$J,IBSRT1,IBSRT2,FT,CT)) Q:CT=""  D
    138         ... S CU="" F  S CU=$O(^TMP("IBPRV_INS_SORT",$J,IBSRT1,IBSRT2,FT,CT,CU)) Q:CU=""  S Z=0 F  S Z=$O(^TMP("IBPRV_INS_SORT",$J,IBSRT1,IBSRT2,FT,CT,CU,Z)) Q:'Z  S IB=$G(^(Z)) D
    139         .... S IBLCT=IBLCT+1,IBCT=IBCT+1
    140         .... S Z0=$E(IBCT_$J("",4),1,4)_" "
    141         .... I IBDSP'="I" S Z0=Z0_$E($S(IBOSRT2'=IBSRT2:$P(IBSRT2,U,2),1:"")_$J("",20),1,20)
    142         .... I IBDSP="I" S Z0=Z0_$E($S(IBOSRT2'=IBSRT2:$$EXPAND^IBTRE(355.9,.06,IBSRT2),1:"")_$J("",20),1,20)
    143         .... S IBOSRT2=IBSRT2
    144         .... S Z0=Z0_"  "_$S(FT=1:"UB-04",FT=2:"1500 ",1:"BOTH ")_"  "_$E($S(CT=3:"RX",CT=1:"INPT",CT=2:"OUTPT",1:"INPT/OUTPT")_$J("",11),1,11)_"  "_$E($S(CU'="*N/A*":$P($G(^IBA(355.95,+$P($G(^IBA(355.96,+CU,0)),U),0)),U),1:"")_$J("",15),1,15)
    145         .... D SET^VALM10(IBLCT,Z0_" "_$P(IB,U),IBCT)
    146         .... S ^TMP("IBPRV_INS_ID",$J,"ZIDX",IBCT)=Z,^(IBCT,"PRV")=$P(IB,U,2)
    147         .... I '$D(^TMP("IBPRV_INS_ID",$J,$S(IBDSP="I":"ZXPRV",1:"ZXPTYP"),IBSRT1)) S ^(IBSRT1)=IBLCT-1
    148         K ^TMP("IBPRV_INS_SORT",$J)
    149         ;
    150         I IBLCT=0 D  G BLDQ ; No entries found
    151         . D SET^VALM10(1," ")
    152         . S Z="  No "_$S(IBDSP="D":"default ",1:"")
    153         . S Z=Z_"ID's found for "_$S(IBDSP="I":"provider "_$S(IBSORT:"("_$$EXPAND^IBTRE(355.9,.01,IBSORT)_") ",1:"")_"and ",IBDSP="A":"provider type "_$S(IBSORT:"("_$$EXPAND^IBTRE(355.9,.06,IBSORT)_") ",1:"")_"and ",1:"")_"insurance co"
    154         . D SET^VALM10(2,Z)
    155         . S IBLCT=2
    156         ;
    157 BLDQ    S VALMCNT=IBLCT,VALMBG=1
    158         Q
    159         ;
    160 EXPND   ;
    161         Q
    162         ;
    163 HELP    ;
    164         Q
    165         ;
    166 EXIT    ;
    167         K IBFASTXT
    168         D COPYPROV^IBCEP5A(IBINS)
    169         K ^TMP("IBPRV_INS_ID",$J)
    170         D CLEAN^VALM10
    171         Q
    172         ;
    173 SEL(IBDA,MANY)  ; Select from provider id list
    174         ; IBDA is passed by reference and IBDA(1) returned containing
    175         ;  ien's of the provider id records selected (file 355.9).
    176         ; If > 1 entry can be selected, MANY is set to 1
    177         N Z
    178         S IBDA=0
    179         D EN^VALM2($G(XQORNOD(0)),$S($G(MANY):"",1:"S"))
    180         S Z=0 F  S Z=$O(VALMY(Z)) Q:'Z  S IBDA=IBDA+1,IBDA(IBDA)=+$G(^TMP("IBPRV_INS_ID",$J,"ZIDX",Z))_U_$G(^(Z,"PRV"))
    181         Q
    182         ;
    183 ENX(IBINS1)     ; Insurance co level defaults for all providers or
    184         ; for all providers by care unit
    185         N DIC,DIE,DR,DA,X,Y,DLAYGO
    186         I '$G(IBINS1) D  G:'$G(IBINS1) ENQ
    187         . S DIC="^IBA(355.91,",DIC(0)="AELMQ",DLAYGO=355.91 D ^DIC
    188         . I Y>0 S IBINS1=+Y
    189         S DIE="^IBA(355.91,",DA=IBINS1,DR=".01;.06;.04;.05;.03;.07" D ^DIE
    190         ;
    191 ENQ     Q
    192         ;
    193 PPTYP(IBINS)    ; Returns the ien of the default performing provider type for
    194         ;  insurance company IBINS (ien file 36)
    195         Q +$G(^DIC(36,+IBINS,4))
    196         ;
    197 SCREEN(WHICH)   ; This screen is used the menu protocol to screen out the ID functions if it is a child ins co
    198         Q:'$G(DA) 0
    199         Q:'$G(DA(1)) 0
    200         N FILE,IENS,FIELD,FLAG,TARGET
    201         S FILE=101.01,IENS=DA_","_DA(1),FIELD=".01",FLAG="I"
    202         D GETS^DIQ(FILE,IENS,FIELD,FLAG,"TARGET")
    203         Q:'$D(TARGET) 0
    204         N IEN
    205         S IEN=$G(TARGET(FILE,IENS_",",FIELD,FLAG))
    206         Q:'+IEN 0
    207         S FILE=101,FIELD=1,FLAG="E"
    208         K TARGET
    209         D GETS^DIQ(FILE,IEN,FIELD,FLAG,"TARGET")
    210         Q:'$D(TARGET) 0
    211         I $G(TARGET(FILE,IEN_",",FIELD,FLAG))'[WHICH Q 1
    212         Q:'$G(IBINS) 0
    213         N PCF
    214         S PCF=$P($G(^DIC(36,+IBINS,3)),U,13)
    215         I PCF="C" Q 0
    216         Q 1
     1IBCEP0 ;ALB/TMP - Functions for PROVIDER ID MAINTENANCE ;13-DEC-99
     2 ;;2.0;INTEGRATED BILLING;**137,191,239,232,320,348,349**;21-MAR-94;Build 46
     3 ;;Per VHA Directive 2004-038, this routine should not be modified.
     4 ;
     5EN ; -- main entry point for IBCE PRV INS ID
     6 N IBINS,IBDSP,IBSORT,IBPRV ; Variables should be available throughout actions
     7 K IBFASTXT
     8 D FULL^VALM1
     9 D EN^VALM("IBCE PRVINS ID")
     10 Q
     11 ;
     12EN1(IBINS) ; Entrypoint from insurance co maintenance
     13 N IBDSP,IBSORT ; Variables should be available throughout actions
     14 D FULL^VALM1
     15 D EN^VALM("IBCE PRVINS ID FROM INS MAINT")
     16 Q
     17 ;
     18HDR ; -- header code
     19 N Z,Z0,Z1,IBCT,IBPPTYP,IBEMCTYP
     20 S IBCT=1
     21 K VALMHDR
     22 I $G(IBINS) D
     23 . N PCF,PCDISP
     24 . S PCF=$P($G(^DIC(36,+IBINS,3)),U,13)
     25 . S PCDISP=$S(PCF="C":"(Child)",PCF="P":"(Parent)",1:"")
     26 . S VALMHDR(1)="Insurance Co: "_$P($G(^DIC(36,+IBINS,0)),U)_" "_PCDISP
     27 . ; Get performing provider id type for insurance co
     28 . S IBPPTYP=$$PPTYP(IBINS)
     29 . ; Get ien of EMC ID from file 355.97
     30 . S IBEMCTYP=+$$EMCID^IBCEP()
     31 . I $G(IBSORT)="ALL"!($G(IBDSP)="I")!($G(IBSORT)=IBPPTYP)!($G(IBSORT)=IBEMCTYP) D
     32 .. ; Look for care unit in either of these id types - if there, report on line 2 of header
     33 .. I $G(IBSORT)=IBPPTYP S IBEMCTYP=0
     34 .. I $G(IBSORT)=IBEMCTYP S IBPPTYP=0
     35 .. F Z0=IBPPTYP_"P",IBEMCTYP_"E" S Z1="" F  S Z1=$O(^IBA(355.96,"D",+IBINS,+Z0,Z1)) Q:Z1=""  I Z1'="*N/A*" S Z($E(Z0,$L(Z0)))=1 Q
     36 .. I $D(Z("P"))!$D(Z("E")) D
     37 ... S IBCT=IBCT+1
     38 ... S VALMHDR(IBCT)="  "_$S($D(Z("P")):"PERFORMING PROV ID"_$S($D(Z("E")):" AND ",1:""),1:"")_$S($D(Z("E")):"EMC PROV ID",1:"")_" MAY REQUIRE CARE UNIT"
     39 . I $D(Z("P"))!$D(Z("E")) S IBCT=IBCT+1,VALMHDR(IBCT)=" "
     40 . S IBCT=IBCT+1,VALMHDR(IBCT)="     PROVIDER "_$S($G(IBDSP)="I":"ID TYPE",1:"NAME   ")_$J("",6)_"FORM   CARE TYPE    CARE UNIT       ID#"
     41 Q
     42 ;
     43INIT ; Initialization
     44 K ^TMP("IB_EDITED_IDS",$J)  ; This will be to keep track of ID's edited during this session
     45 D INSID(.IBINS,.IBDSP,.IBSORT)
     46 I $G(IBDSP)="I",$G(IBSORT) S IBPRV=IBSORT
     47 I '$G(IBINS) S VALMQUIT=1
     48 Q
     49 ;
     50INSID(IBINS,IBDSP,IBSORT) ;
     51 N DIC,DIR,DA,X,Y,IBOK,DTOUT,DUOUT
     52 S IBOK=1
     53 I '$G(IBINS) D
     54 . S DIC(0)="AEMQ",DIC="^DIC(36," D ^DIC
     55 . I Y'>0 S IBOK=0 Q
     56 . S IBINS=+Y
     57 I '$G(IBINS) S IBOK=0
     58 I 'IBOK G INSIDQ
     59 ;
     60 S DIR(0)="SA^D:INSURANCE CO DEFAULT IDS;I:INDIVIDUAL PROVIDER IDS FURNISHED BY THE INS CO;A:ALL IDS FURNISHED BY THE INS CO BY PROVIDER TYPE"
     61 S DIR("A")="SELECT DISPLAY CONTENT: ",DIR("B")="A"
     62 S DIR("?",1)="(D) DISPLAY CONTAINS ONLY THOSE IDS ASSIGNED AS DEFAULTS TO THE FACILITY BY",DIR("?",2)="    THE INSURANCE COMPANY"
     63 S DIR("?",3)="(I) DISPLAY CONTAINS ONLY THOSE IDS ASSIGNED TO INDIVIDUAL PROVIDERS BY THE",DIR("?",4)="    INSURANCE COMPANY"
     64 S DIR("?",5)="(A) DISPLAY CONTAINS ALL IDS ASSIGNED BY THE INSURANCE COMPANY FOR ONE OR ALL",DIR("?")="    PROVIDER ID TYPES"
     65 W ! D ^DIR K DIR W !
     66 I $D(DTOUT)!$D(DUOUT)!("DIA"'[Y) S IBOK=0 G INSIDQ
     67 S IBDSP=Y,IBSORT=""
     68 I IBDSP="A"!(IBDSP="I") F  D  Q:'IBOK!(IBSORT'="")
     69 . N Z
     70 . S Z=$S(IBDSP="I":"",1:" ID TYPE")
     71 . S DIR("A")="DO YOU WANT TO DISPLAY IDS FOR A SPECIFIC PROVIDER"_Z_"?: ",DIR("B")="NO",DIR(0)="YA"
     72 . S DIR("?",1)="IF YOU ANSWER YES TO THIS QUESTION, YOU MAY SELECT A SPECIFIC PROVIDER"_Z,DIR("?")="  TO DISPLAY, OTHERWISE, ALL PROVIDER"_Z_"S FOUND WILL BE DISPLAYED"
     73 . W ! D ^DIR K DIR W !
     74 . I $D(DTOUT)!$D(DUOUT) S IBOK=0 Q
     75 . I Y'=1 S IBSORT="ALL" Q
     76 . ;
     77 . I IBDSP="A" D  Q
     78 .. S DIC(0)="AEMQ",DIC="^IBE(355.97,",DIC("S")="I $S('$P(^(0),U,2):1,1:$P(^(0),U,2)=3)" D ^DIC K DIC
     79 .. I Y>0 S IBSORT=+Y Q
     80 .. I $D(DTOUT)!$D(DUOUT) S IBOK=0
     81 . ;
     82 . I IBDSP="I" D  Q
     83 .. N DA
     84 .. S DIR(0)="399.0222,.02A",DIR("A")="SELECT PROVIDER: "
     85 .. W ! D ^DIR K DIR W !
     86 .. I Y>0 S IBSORT=Y Q
     87 .. I $D(DTOUT)!$D(DUOUT) S IBOK=0 Q
     88 . S IBOK=0 Q
     89 ;
     90 G:'IBOK INSIDQ
     91 D BLD(IBINS,IBDSP,IBSORT)
     92INSIDQ I 'IBOK S VALMQUIT=1
     93 Q
     94 ;
     95BLD(IBINS,IBDSP,IBSORT) ; Build display for Insurance co level provider ID's
     96 N IB,IBENT,IBLCT,IBCT,IBPRV,IBSRT1,IBSRT2,IBOSRT1,IBOSRT2,CU,FT,PT,CT,Z,Z0
     97 K ^TMP("IBPRV_INS_ID",$J),^TMP("IBPRV_INS_SORT",$J)
     98 ;
     99 S (IBENT,IBCT,IBLCT)=0
     100 ;
     101 I "DA"[$G(IBDSP) D
     102 . S CU="" F  S CU=$O(^IBA(355.91,"AUNIQ",IBINS,CU)) Q:CU=""  S FT="" F  S FT=$O(^IBA(355.91,"AUNIQ",IBINS,CU,FT)) Q:FT=""  D
     103 .. S CT="" F  S CT=$O(^IBA(355.91,"AUNIQ",IBINS,CU,FT,CT)) Q:CT=""  S PT=0 F  S PT=$S(IBDSP="A"&IBSORT:IBSORT,1:$O(^IBA(355.91,"AUNIQ",IBINS,CU,FT,CT,PT))) Q:'PT  D  Q:IBDSP="A"&IBSORT
     104 ... S Z=0 F  S Z=$O(^IBA(355.91,"AUNIQ",IBINS,CU,FT,CT,PT,Z)) Q:'Z  S IB=$G(^IBA(355.91,Z,0)) S ^TMP("IBPRV_INS_SORT",$J,PT,"^<<INS CO DEFAULT>>",FT,CT,CU,Z)=$P(IB,U,7)_U
     105 ;
     106 I "IA"[$G(IBDSP) D
     107 . S IBPRV=""
     108 . N IB1,IB2
     109 . F  S IBPRV=$O(^IBA(355.9,"AE",IBINS,IBPRV)) Q:'IBPRV  S Z=0 F  S Z=$O(^IBA(355.9,"AE",IBINS,IBPRV,Z)) Q:'Z  S IB=$G(^IBA(355.9,Z,0)) D
     110 .. Q:$P(IB,U,4)=""!($P(IB,U,5)="")!($P(IB,U,6)="")!($P(IB,U,16)="")
     111 .. I IBSORT,$S(IBDSP="I":IBPRV'=IBSORT,1:$P(IB,U,6)'=IBSORT) Q
     112 .. S IB1=$S(IBDSP="A":$P(IB,U,6),1:U_$$EXPAND^IBTRE(355.9,.01,IBPRV)_U_IBPRV)
     113 .. S IB2=$S(IBDSP="I":$P(IB,U,6),1:U_$$EXPAND^IBTRE(355.9,.01,IBPRV)_U_IBPRV)
     114 .. S ^TMP("IBPRV_INS_SORT",$J,IB1,IB2,$P(IB,U,4),$P(IB,U,5),$P(IB,U,16),Z)=$P(IB,U,7)_U_IBPRV
     115 ;
     116 S IBOSRT1=""
     117 S IBSRT1="" F  S IBSRT1=$O(^TMP("IBPRV_INS_SORT",$J,IBSRT1)) Q:IBSRT1=""  D
     118 . S IBSRT2="",IBOSRT2=""
     119 . F  S IBSRT2=$O(^TMP("IBPRV_INS_SORT",$J,IBSRT1,IBSRT2)) Q:IBSRT2=""  D
     120 .. I IBOSRT1'=IBSRT1 D
     121 ... I IBOSRT1'="" S IBLCT=IBLCT+1 D SET^VALM10(IBLCT," ",IBCT+1)
     122 ... S IBLCT=IBLCT+1 D SET^VALM10(IBLCT,$S(IBDSP'="I":"ID Qualifier",1:"Provider")_": "_$S(IBDSP'="I":$$EXPAND^IBTRE(355.91,.06,IBSRT1),1:$P(IBSRT1,U,2_$S($P(IBSRT2,U,3)["VA(200":" (VA)",1:"(NON-VA)"))),IBCT+1)
     123 ... S IBOSRT1=IBSRT1
     124 .. ;
     125 .. S FT="" F  S FT=$O(^TMP("IBPRV_INS_SORT",$J,IBSRT1,IBSRT2,FT)) Q:FT=""  S CT="" F  S CT=$O(^TMP("IBPRV_INS_SORT",$J,IBSRT1,IBSRT2,FT,CT)) Q:CT=""  D
     126 ... S CU="" F  S CU=$O(^TMP("IBPRV_INS_SORT",$J,IBSRT1,IBSRT2,FT,CT,CU)) Q:CU=""  S Z=0 F  S Z=$O(^TMP("IBPRV_INS_SORT",$J,IBSRT1,IBSRT2,FT,CT,CU,Z)) Q:'Z  S IB=$G(^(Z)) D
     127 .... S IBLCT=IBLCT+1,IBCT=IBCT+1
     128 .... S Z0=$E(IBCT_$J("",4),1,4)_" "
     129 .... I IBDSP'="I" S Z0=Z0_$E($S(IBOSRT2'=IBSRT2:$P(IBSRT2,U,2),1:"")_$J("",20),1,20)
     130 .... I IBDSP="I" S Z0=Z0_$E($S(IBOSRT2'=IBSRT2:$$EXPAND^IBTRE(355.9,.06,IBSRT2),1:"")_$J("",20),1,20)
     131 .... S IBOSRT2=IBSRT2
     132 .... S Z0=Z0_"  "_$S(FT=1:"UB-04",FT=2:"1500 ",1:"BOTH ")_"  "_$E($S(CT=3:"RX",CT=1:"INPT",CT=2:"OUTPT",1:"INPT/OUTPT")_$J("",11),1,11)_"  "_$E($S(CU'="*N/A*":$P($G(^IBA(355.95,+$P($G(^IBA(355.96,+CU,0)),U),0)),U),1:"")_$J("",15),1,15)
     133 .... D SET^VALM10(IBLCT,Z0_" "_$P(IB,U),IBCT)
     134 .... S ^TMP("IBPRV_INS_ID",$J,"ZIDX",IBCT)=Z,^(IBCT,"PRV")=$P(IB,U,2)
     135 .... I '$D(^TMP("IBPRV_INS_ID",$J,$S(IBDSP="I":"ZXPRV",1:"ZXPTYP"),IBSRT1)) S ^(IBSRT1)=IBLCT-1
     136 K ^TMP("IBPRV_INS_SORT",$J)
     137 ;
     138 I IBLCT=0 D  G BLDQ ; No entries found
     139 . D SET^VALM10(1," ")
     140 . S Z="  No "_$S(IBDSP="D":"default ",1:"")
     141 . S Z=Z_"ID's found for "_$S(IBDSP="I":"provider "_$S(IBSORT:"("_$$EXPAND^IBTRE(355.9,.01,IBSORT)_") ",1:"")_"and ",IBDSP="A":"provider type "_$S(IBSORT:"("_$$EXPAND^IBTRE(355.9,.06,IBSORT)_") ",1:"")_"and ",1:"")_"insurance co"
     142 . D SET^VALM10(2,Z)
     143 . S IBLCT=2
     144 ;
     145BLDQ S VALMCNT=IBLCT,VALMBG=1
     146 Q
     147 ;
     148EXPND ;
     149 Q
     150 ;
     151HELP ;
     152 Q
     153 ;
     154EXIT ;
     155 K IBFASTXT
     156 D COPYPROV^IBCEP5A(IBINS)
     157 K ^TMP("IBPRV_INS_ID",$J)
     158 D CLEAN^VALM10
     159 Q
     160 ;
     161SEL(IBDA,MANY) ; Select from provider id list
     162 ; IBDA is passed by reference and IBDA(1) returned containing
     163 ;  ien's of the provider id records selected (file 355.9).
     164 ; If > 1 entry can be selected, MANY is set to 1
     165 N Z
     166 S IBDA=0
     167 D EN^VALM2($G(XQORNOD(0)),$S($G(MANY):"",1:"S"))
     168 S Z=0 F  S Z=$O(VALMY(Z)) Q:'Z  S IBDA=IBDA+1,IBDA(IBDA)=+$G(^TMP("IBPRV_INS_ID",$J,"ZIDX",Z))_U_$G(^(Z,"PRV"))
     169 Q
     170 ;
     171ENX(IBINS1) ; Insurance co level defaults for all providers or
     172 ; for all providers by care unit
     173 N DIC,DIE,DR,DA,X,Y,DLAYGO
     174 I '$G(IBINS1) D  G:'$G(IBINS1) ENQ
     175 . S DIC="^IBA(355.91,",DIC(0)="AELMQ",DLAYGO=355.91 D ^DIC
     176 . I Y>0 S IBINS1=+Y
     177 S DIE="^IBA(355.91,",DA=IBINS1,DR=".01;.06;.04;.05;.03;.07" D ^DIE
     178 ;
     179ENQ Q
     180 ;
     181PPTYP(IBINS) ; Returns the ien of the default performing provider type for
     182 ;  insurance company IBINS (ien file 36)
     183 Q +$G(^DIC(36,+IBINS,4))
     184 ;
     185SCREEN(WHICH) ; This screen is used the menu protocol to screen out the ID functions if it is a child ins co
     186 Q:'$G(DA) 0
     187 Q:'$G(DA(1)) 0
     188 N FILE,IENS,FIELD,FLAG,TARGET
     189 S FILE=101.01,IENS=DA_","_DA(1),FIELD=".01",FLAG="I"
     190 D GETS^DIQ(FILE,IENS,FIELD,FLAG,"TARGET")
     191 Q:'$D(TARGET) 0
     192 N IEN
     193 S IEN=$G(TARGET(FILE,IENS_",",FIELD,FLAG))
     194 Q:'+IEN 0
     195 S FILE=101,FIELD=1,FLAG="E"
     196 K TARGET
     197 D GETS^DIQ(FILE,IEN,FIELD,FLAG,"TARGET")
     198 Q:'$D(TARGET) 0
     199 I $G(TARGET(FILE,IEN_",",FIELD,FLAG))'[WHICH Q 1
     200 Q:'$G(IBINS) 0
     201 N PCF
     202 S PCF=$P($G(^DIC(36,+IBINS,3)),U,13)
     203 I PCF="C" Q 0
     204 Q 1

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP0A.m

    r613 r623  
    1 IBCEP0A ;ALB/TMP - EDI UTILITIES for insurance assigned provider ID ;01-NOV-00
    2         ;;2.0;INTEGRATED BILLING;**137,232,320,377**;21-MAR-94;Build 23
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5 NEW(IBINS,IBPRV,IBPTYP,IBDEF)   ; Add new insurance co assigned id
    6         ; IBDEF = flag sent as 1 if only insurance co defaults are being added
    7         N DIC,DIR,X,Y,Z,DA,DR,DIE,DO,DD,DLAYGO,IBQ,IBIEN,IBCUND,DTOUT,DUOUT
    8         D FULL^VALM1
    9         S IBQ=0
    10         I $G(IBDEF)="D" W !!,"YOU ARE ADDING A PROVIDER ID THAT WILL BE THE INSURANCE CO DEFAULT",!
    11         I '$G(IBPRV),$G(IBDEF)'="D" D  G:IBQ NEWQ
    12         . N DA,IBO
    13         . S IBO=($G(IBDSP)'="I")
    14         . S DIR(0)="355.9,.01A"_$S(IBO:"O",1:""),DIR("A")="Select PROVIDER"_$S(IBO:" (optional)",1:"")_": "
    15         . S DIR("?")="Select the PROVIDER to be assigned a provider ID"
    16         . I IBO S DIR("?",1)=DIR("?"),DIR("?")="Or    Press ENTER to add an insurance co level default id (all providers)"
    17         . W ! D ^DIR K DIR W !
    18         . I $D(DTOUT)!$D(DUOUT) S IBQ=1 Q
    19         . S IBPRV=$S(Y>0:$P(Y,U),1:"")
    20         . Q:IBPRV
    21         . S DIR(0)="YA",DIR("B")="YES",DIR("A",1)="YOU ARE ADDING A PROVIDER ID THAT WILL BE THE INSURANCE CO DEFAULT",DIR("A")="IS THIS OK?: "
    22         . W ! D ^DIR K DIR W !
    23         . I $D(DTOUT)!$D(DUOUT)!(Y'=1) S IBQ=1
    24         . Q
    25         ;
    26         I '$G(IBPTYP) D  G:IBQ NEWQ
    27         . S DIR(0)="PAr^355.97:AEMQ",DIR("A")="Select Provider ID Qualifier: "
    28         . S DIR("?")="Enter a Qualifier to identify the type of ID number you are entering."
    29         . S DIR("S")="I $$RAINS^IBCEPU(Y)"   ; Rendering/Attending IDs provided by ins
    30         . S DA=0
    31         . W ! D ^DIR K DIR W !
    32         . I $D(DTOUT)!$D(DUOUT)!'Y S IBQ=1 Q
    33         . S IBPTYP=+Y
    34         ;
    35         S IBQ=$$ADDID(IBINS,IBPRV,IBPTYP)
    36         ;
    37 NEWQ    D:'$G(IBQ) BLD^IBCEP0($G(IBINS),$G(IBDSP),$G(IBSORT))
    38         S VALMBCK="R"
    39         Q
    40         ;
    41 DEL1    ; Delete Insurance Co assigned provider ID's
    42         ; IBPRV = vp ien of provider if editing entry in file 355.9
    43         ;         otherwise, null
    44         N IB1,IBDA,IBFILE
    45         D FULL^VALM1
    46         D SEL^IBCEP0(.IBDA)
    47         G:'$O(IBDA(0)) DEL1Q
    48         S IBDA=+$O(IBDA("")),IBDA=$G(IBDA(IBDA))
    49         G:'IBDA DEL1Q
    50         S IB1=$P(IBDA,U,2),IBDA=+IBDA
    51         S IBFILE=$S(IB1:355.9,1:355.91)
    52         I IBDA>0 D DEL^IBCEP5B(IBFILE,IBDA,1),BLD^IBCEP0($G(IBINS),$G(IBDSP),$G(IBSORT))
    53         ;
    54 DEL1Q   S VALMBCK="R"
    55         Q
    56         ;
    57 CHG1    ; Edit Provider ID's
    58         N IBDA,IB1,IBFILE
    59         D FULL^VALM1
    60         D SEL^IBCEP0(.IBDA)
    61         G:'$O(IBDA(0)) CHG1Q
    62         S IBDA=+$O(IBDA("")),IBDA=$G(IBDA(IBDA))
    63         G:'IBDA CHG1Q
    64         S IB1=$P(IBDA,U,2),IBDA=+IBDA
    65         S IBFILE=$S(IB1:355.9,1:355.91)
    66         I IBDA>0 D
    67         . I IBFILE=355.9 W !!,"PROVIDER: ",$$EXPAND^IBTRE(355.9,.01,IB1)
    68         . I IBFILE'=355.9 W !!,"  <<INS CO DEFAULT>>"
    69         . D CHG^IBCEP5B(IBFILE,IBDA),BLD^IBCEP0($G(IBINS),$G(IBDSP),$G(IBSORT))
    70         ;
    71 CHG1Q   S VALMBCK="R"
    72         Q
    73         ;
    74 PRVJMP(IBDSP)   ; Navigate to a specific sort level in current LM list
    75         ;   (from insurance co option)
    76         ; IBDSP = 'I', 'A' or 'D' to indicate format selected for display
    77         ;        ([P]ROVIDER, PROVIDER [T]YPE OR [I]NSURANCE DEFAULT)
    78         ; Sets VALMBG = LINE # if a provider in list selected
    79         ;
    80         I $G(IBDSP)="I" D PRVNJMP(.VALMBG)
    81         I $G(IBDSP)="D"!($G(IBDSP)="A") D PRVTJMP(.VALMBG)
    82         S VALMBCK="R"
    83         Q
    84         ;
    85 PRVNJMP(VALMBG) ; Navigate to a specific provider name (from insurance co
    86         ;  option)
    87         ;
    88         N DIR,X,Y,DA
    89         D FULL^VALM1
    90         S DIR(0)="355.9,.01AO^^I '$D(^TMP(""IBPRV_INS_ID"",$J,""ZXPRV"",U_$$EXPAND^IBTRE(355.9,.01,Y)_U_$P(Y,U))) K X"
    91         S DIR("?",1)="*** YOU MAY ONLY SELECT PROVIDERS INCLUDED IN THE CURRENT LIST ***",DIR("?",2)=" ",DIR("?",3)="SELECTING A PROVIDER WILL FORCE THE DISPLAY TO SKIP TO THE DATA FOR THAT",DIR("?")="   PROVIDER"
    92         S DIR("A")="SELECT PROVIDER: "
    93         S DIR("S")="N Z S Z=$P(^(0),U) I $D(^TMP(""IBPRV_INS_ID"",$J,""ZXPRV"",U_$$EXPAND^IBTRE(355.9,.01,Z)_U_Z))"
    94         W ! D ^DIR K DIR W !
    95         I Y>0,'$D(DTOUT),'$D(DUOUT) D
    96         . N Z
    97         . S Z=$G(^TMP("IBPRV_INS_ID",$J,"ZXPRV",U_$$EXPAND^IBTRE(355.9,.01,$P(Y,U))_U_$P(Y,U)))
    98         . I Z S VALMBG=Z Q
    99         . S DIR(0)="EA",DIR("A",1)="THIS PROVIDER DOES NOT EXIST IN THE CURRENT DISPLAY",DIR("A")="PRESS THE ENTER KEY TO CONTINUE"
    100         . W ! D ^DIR K DIR W !
    101         Q
    102         ;
    103 PRVTJMP(VALMBG) ; Navigate to a specific type of ID qualifier (from ins co option)
    104         ;
    105         N DIR,X,Y
    106         D FULL^VALM1
    107         S DIR(0)="PAO^355.97:AEMQ",DIR("A")="Select type of ID Qualifier: "
    108         S DIR("?")="Select a type of ID Qualifier to display the IDs of that type."
    109         S DIR("S")="I $D(^TMP(""IBPRV_INS_ID"",$J,""ZXPTYP"",+Y))"
    110         W ! D ^DIR K DIR W !
    111         I Y>0,'$D(DTOUT),'$D(DUOUT) D
    112         . N Z
    113         . S Z=$G(^TMP("IBPRV_INS_ID",$J,"ZXPTYP",+Y))
    114         . I Z S VALMBG=Z Q
    115         . S DIR(0)="EA",DIR("A",1)="This type of ID Qualifier does not exist in the current display",DIR("A")="Press the Enter key to continue"
    116         . W ! D ^DIR K DIR W !
    117         Q
    118         ;
    119 CHGINS  ; Change insurance co being displayed, using the same or new params
    120         ; Assumes IBINS exists = IEN of insurance co (file 36)
    121         N IBINEW,IBSAVE,DIC,DA,Y,X,DIR
    122         D FULL^VALM1
    123         S DIC="^DIC(36,",DIC(0)="AEMQ" D ^DIC
    124         S IBINEW=+Y
    125         ;
    126         I IBINEW>0,IBINS'=IBINEW D
    127         . D COPYPROV^IBCEP5A(IBINS)
    128         . S DIR(0)="YA",DIR("?")="IF YOU WANT TO CHANGE THE FORMAT OF THE DISPLAY, RESPOND NO HERE"
    129         . S DIR("A")="DO YOU WANT TO DISPLAY THE NEW INS. CO IDS USING THE CURRENT DISPLAY FORMAT?: ",DIR("B")="YES" W ! D ^DIR W ! K DIR
    130         . Q:Y'=1
    131         . S IBSAVE("IBINS")=IBINS
    132         . K ^TMP("IBPRV_INS_ID",$J),VALMHDR S VALMBG=1,IBINS=IBINEW
    133         . I Y=1 D BLD^IBCEP0($G(IBINS),$G(IBDSP),$G(IBSORT)) Q
    134         . D INIT^IBCEP0
    135         . I '$G(VALMQUIT) Q
    136         . S IBINS=IBSAVE("IBINS") D BLD^IBCEP0($G(IBINS),$G(IBDSP),$G(IBSORT))
    137         S VALMBCK="R"
    138         Q
    139         ;
    140 CHGFMT  ; Change format parameters for display
    141         N IBSAVE
    142         S IBSAVE("IBINS")=$G(IBINS)
    143         D INIT^IBCEP0
    144         I '$G(VALMQUIT) G CHGFMTQ
    145         S IBINS=IBSAVE("IBINS") D BLD^IBCEP0($G(IBINS),$G(IBDSP),$G(IBSORT))
    146 CHGFMTQ S VALMBCK="R"
    147         Q
    148         ;
    149 IPARAM  ; Display Insurance co parameters and care unit requirements
    150         ; Assumes IBINS exists = IEN of insurance co
    151         N IBDSP,IBSORT,IBHOLD
    152         D FULL^VALM1
    153         S IBHOLD("IBINS")=$G(IBINS)
    154         D EN^VALM("IBCE PRVINS PARAM DISPLAY")
    155         S:$G(IBHOLD("IBINS"))'="" IBINS=IBHOLD("IBINS")
    156         K VALMQUIT
    157         S VALMBCK="R"
    158         Q
    159         ;
    160 ADDID(IBINS,IBPRV,IBPTYP)       ; Adds a new ID for the provider and/or ins co
    161         ; IBINS = ien of file 36
    162         ; IBPRV = vp ien of file 355.9
    163         ; IBPTYP = ien of file 355.97
    164         ; FUNCTION returns 1 if record not added, 0 if filed OK
    165         N IBIEN,IBQ,DIC,DA,DO,DD,DLAYGO,X,Y
    166         S IBQ=0
    167         I $G(IBPRV) D  G:IBQ ADDIDQ
    168         . ; Provider specific for insurance co - add to file 355.9
    169         . S DIC(0)="L",DLAYGO=355.9,DIC="^IBA(355.9,",X=IBPRV
    170         . S:$G(IBINS) DIC("DR")=".02////"_IBINS
    171         . D FILE^DICN K DIC,DLAYGO,DD,DO
    172         . I Y'>0!$D(DUOUT)!$D(DTOUT) S IBIEN=0,IBQ=1 Q
    173         . S IBIEN=+Y
    174         . D NEWID^IBCEP5B(355.9,IBINS,IBPRV,IBPTYP,IBIEN,"")
    175         E  D
    176         . ; Insurance co default - add to file 355.91
    177         . S DIC(0)="L",DLAYGO=355.91,DIC="^IBA(355.91,",X=IBINS
    178         . D FILE^DICN K DIC,DLAYGO,DD,DO
    179         . I Y'>0!$D(DUOUT)!$D(DTOUT) S IBIEN=0,IBQ=1 Q
    180         . S IBIEN=+Y
    181         . D NEWID^IBCEP5B(355.91,IBINS,"",IBPTYP,IBIEN,1)
    182 ADDIDQ  Q IBQ
     1IBCEP0A ;ALB/TMP - EDI UTILITIES for insurance assigned provider ID ;01-NOV-00
     2 ;;2.0;INTEGRATED BILLING;**137,232,320**;21-MAR-94
     3 ;
     4NEW(IBINS,IBPRV,IBPTYP,IBDEF) ; Add new insurance co assigned id
     5 ; IBDEF = flag sent as 1 if only insurance co defaults are being added
     6 N DIC,DIR,X,Y,Z,DA,DR,DIE,DO,DD,DLAYGO,IBQ,IBIEN,IBCUND,DTOUT,DUOUT
     7 D FULL^VALM1
     8 S IBQ=0
     9 I $G(IBDEF)="D" W !!,"YOU ARE ADDING A PROVIDER ID THAT WILL BE THE INSURANCE CO DEFAULT",!
     10 I '$G(IBPRV),$G(IBDEF)'="D" D  G:IBQ NEWQ
     11 . N DA,IBO
     12 . S IBO=($G(IBDSP)'="I")
     13 . S DIR(0)="355.9,.01A"_$S(IBO:"O",1:""),DIR("A")="Select PROVIDER"_$S(IBO:" (optional)",1:"")_": "
     14 . S DIR("?")="Select the PROVIDER to be assigned a provider ID"
     15 . I IBO S DIR("?",1)=DIR("?"),DIR("?")="Or    Press ENTER to add an insurance co level default id (all providers)"
     16 . W ! D ^DIR K DIR W !
     17 . I $D(DTOUT)!$D(DUOUT) S IBQ=1 Q
     18 . S IBPRV=$S(Y>0:$P(Y,U),1:"")
     19 . Q:IBPRV
     20 . S DIR(0)="YA",DIR("B")="YES",DIR("A",1)="YOU ARE ADDING A PROVIDER ID THAT WILL BE THE INSURANCE CO DEFAULT",DIR("A")="IS THIS OK?: "
     21 . W ! D ^DIR K DIR W !
     22 . I $D(DTOUT)!$D(DUOUT)!(Y'=1) S IBQ=1
     23 . Q
     24 ;
     25 I '$G(IBPTYP) D  G:IBQ NEWQ
     26 . S DIR(0)="PAr^355.97:AEMQ",DIR("A")="Select Provider ID Qualifier: "
     27 . S DIR("?")="Enter a Qualifier to indentify the type of ID number you are entering."
     28 . S DIR("S")="I $$RAINS^IBCEPU(Y)"   ; Rendering/Attending IDs provided by ins
     29 . S DA=0
     30 . W ! D ^DIR K DIR W !
     31 . I $D(DTOUT)!$D(DUOUT)!'Y S IBQ=1 Q
     32 . S IBPTYP=+Y
     33 ;
     34 S IBQ=$$ADDID(IBINS,IBPRV,IBPTYP)
     35 ;
     36NEWQ D:'$G(IBQ) BLD^IBCEP0($G(IBINS),$G(IBDSP),$G(IBSORT))
     37 S VALMBCK="R"
     38 Q
     39 ;
     40DEL1 ; Delete Insurance Co assigned provider ID's
     41 ; IBPRV = vp ien of provider if editing entry in file 355.9
     42 ;         otherwise, null
     43 N IB1,IBDA,IBFILE
     44 D FULL^VALM1
     45 D SEL^IBCEP0(.IBDA)
     46 G:'$O(IBDA(0)) DEL1Q
     47 S IBDA=+$O(IBDA("")),IBDA=$G(IBDA(IBDA))
     48 G:'IBDA DEL1Q
     49 S IB1=$P(IBDA,U,2),IBDA=+IBDA
     50 S IBFILE=$S(IB1:355.9,1:355.91)
     51 I IBDA>0 D DEL^IBCEP5B(IBFILE,IBDA,1),BLD^IBCEP0($G(IBINS),$G(IBDSP),$G(IBSORT))
     52 ;
     53DEL1Q S VALMBCK="R"
     54 Q
     55 ;
     56CHG1 ; Edit Provider ID's
     57 N IBDA,IB1,IBFILE
     58 D FULL^VALM1
     59 D SEL^IBCEP0(.IBDA)
     60 G:'$O(IBDA(0)) CHG1Q
     61 S IBDA=+$O(IBDA("")),IBDA=$G(IBDA(IBDA))
     62 G:'IBDA CHG1Q
     63 S IB1=$P(IBDA,U,2),IBDA=+IBDA
     64 S IBFILE=$S(IB1:355.9,1:355.91)
     65 I IBDA>0 D
     66 . I IBFILE=355.9 W !!,"PROVIDER: ",$$EXPAND^IBTRE(355.9,.01,IB1)
     67 . I IBFILE'=355.9 W !!,"  <<INS CO DEFAULT>>"
     68 . D CHG^IBCEP5B(IBFILE,IBDA),BLD^IBCEP0($G(IBINS),$G(IBDSP),$G(IBSORT))
     69 ;
     70CHG1Q S VALMBCK="R"
     71 Q
     72 ;
     73PRVJMP(IBDSP) ; Navigate to a specific sort level in current LM list
     74 ;   (from insurance co option)
     75 ; IBDSP = 'I', 'A' or 'D' to indicate format selected for display
     76 ;        ([P]ROVIDER, PROVIDER [T]YPE OR [I]NSURANCE DEFAULT)
     77 ; Sets VALMBG = LINE # if a provider in list selected
     78 ;
     79 I $G(IBDSP)="I" D PRVNJMP(.VALMBG)
     80 I $G(IBDSP)="D"!($G(IBDSP)="A") D PRVTJMP(.VALMBG)
     81 S VALMBCK="R"
     82 Q
     83 ;
     84PRVNJMP(VALMBG) ; Navigate to a specific provider name (from insurance co
     85 ;  option)
     86 ;
     87 N DIR,X,Y,DA
     88 D FULL^VALM1
     89 S DIR(0)="355.9,.01AO^^I '$D(^TMP(""IBPRV_INS_ID"",$J,""ZXPRV"",U_$$EXPAND^IBTRE(355.9,.01,Y)_U_$P(Y,U))) K X"
     90 S DIR("?",1)="*** YOU MAY ONLY SELECT PROVIDERS INCLUDED IN THE CURRENT LIST ***",DIR("?",2)=" ",DIR("?",3)="SELECTING A PROVIDER WILL FORCE THE DISPLAY TO SKIP TO THE DATA FOR THAT",DIR("?")="   PROVIDER"
     91 S DIR("A")="SELECT PROVIDER: "
     92 S DIR("S")="N Z S Z=$P(^(0),U) I $D(^TMP(""IBPRV_INS_ID"",$J,""ZXPRV"",U_$$EXPAND^IBTRE(355.9,.01,Z)_U_Z))"
     93 W ! D ^DIR K DIR W !
     94 I Y>0,'$D(DTOUT),'$D(DUOUT) D
     95 . N Z
     96 . S Z=$G(^TMP("IBPRV_INS_ID",$J,"ZXPRV",U_$$EXPAND^IBTRE(355.9,.01,$P(Y,U))_U_$P(Y,U)))
     97 . I Z S VALMBG=Z Q
     98 . S DIR(0)="EA",DIR("A",1)="THIS PROVIDER DOES NOT EXIST IN THE CURRENT DISPLAY",DIR("A")="PRESS THE ENTER KEY TO CONTINUE"
     99 . W ! D ^DIR K DIR W !
     100 Q
     101 ;
     102PRVTJMP(VALMBG) ; Navigate to a specific provider id type (from ins co option)
     103 ;
     104 N DIR,X,Y
     105 D FULL^VALM1
     106 S DIR(0)="PAO^355.97:AEMQ",DIR("A")="SELECT PROVIDER ID TYPE: ",DIR("?",1)="SELECTING A PROVIDER ID TYPE WILL FORCE THE DISPLAY TO SKIP TO THE DATA FOR ",DIR("?")="  THAT PROVIDER ID TYPE"
     107 S DIR("S")="I $D(^TMP(""IBPRV_INS_ID"",$J,""ZXPTYP"",+Y))"
     108 W ! D ^DIR K DIR W !
     109 I Y>0,'$D(DTOUT),'$D(DUOUT) D
     110 . N Z
     111 . S Z=$G(^TMP("IBPRV_INS_ID",$J,"ZXPTYP",+Y))
     112 . I Z S VALMBG=Z Q
     113 . S DIR(0)="EA",DIR("A",1)="THIS PROVIDER ID TYPE DOES NOT EXIST IN THE CURRENT DISPLAY",DIR("A")="PRESS THE ENTER KEY TO CONTINUE"
     114 . W ! D ^DIR K DIR W !
     115 Q
     116 ;
     117CHGINS ; Change insurance co being displayed, using the same or new params
     118 ; Assumes IBINS exists = IEN of insurance co (file 36)
     119 N IBINEW,IBSAVE,DIC,DA,Y,X,DIR
     120 D FULL^VALM1
     121 S DIC="^DIC(36,",DIC(0)="AEMQ" D ^DIC
     122 S IBINEW=+Y
     123 ;
     124 I IBINEW>0,IBINS'=IBINEW D
     125 . D COPYPROV^IBCEP5A(IBINS)
     126 . S DIR(0)="YA",DIR("?")="IF YOU WANT TO CHANGE THE FORMAT OF THE DISPLAY, RESPOND NO HERE"
     127 . S DIR("A")="DO YOU WANT TO DISPLAY THE NEW INS. CO IDS USING THE CURRENT DISPLAY FORMAT?: ",DIR("B")="YES" W ! D ^DIR W ! K DIR
     128 . Q:Y'=1
     129 . S IBSAVE("IBINS")=IBINS
     130 . K ^TMP("IBPRV_INS_ID",$J),VALMHDR S VALMBG=1,IBINS=IBINEW
     131 . I Y=1 D BLD^IBCEP0($G(IBINS),$G(IBDSP),$G(IBSORT)) Q
     132 . D INIT^IBCEP0
     133 . I '$G(VALMQUIT) Q
     134 . S IBINS=IBSAVE("IBINS") D BLD^IBCEP0($G(IBINS),$G(IBDSP),$G(IBSORT))
     135 S VALMBCK="R"
     136 Q
     137 ;
     138CHGFMT ; Change format parameters for display
     139 N IBSAVE
     140 S IBSAVE("IBINS")=$G(IBINS)
     141 D INIT^IBCEP0
     142 I '$G(VALMQUIT) G CHGFMTQ
     143 S IBINS=IBSAVE("IBINS") D BLD^IBCEP0($G(IBINS),$G(IBDSP),$G(IBSORT))
     144CHGFMTQ S VALMBCK="R"
     145 Q
     146 ;
     147IPARAM ; Display Insurance co parameters and care unit requirements
     148 ; Assumes IBINS exists = IEN of insurance co
     149 N IBDSP,IBSORT,IBHOLD
     150 D FULL^VALM1
     151 S IBHOLD("IBINS")=$G(IBINS)
     152 D EN^VALM("IBCE PRVINS PARAM DISPLAY")
     153 S:$G(IBHOLD("IBINS"))'="" IBINS=IBHOLD("IBINS")
     154 K VALMQUIT
     155 S VALMBCK="R"
     156 Q
     157 ;
     158ADDID(IBINS,IBPRV,IBPTYP) ; Adds a new ID for the provider and/or ins co
     159 ; IBINS = ien of file 36
     160 ; IBPRV = vp ien of file 355.9
     161 ; IBPTYP = ien of file 355.97
     162 ; FUNCTION returns 1 if record not added, 0 if filed OK
     163 N IBIEN,IBQ,DIC,DA,DO,DD,DLAYGO,X,Y
     164 S IBQ=0
     165 I $G(IBPRV) D  G:IBQ ADDIDQ
     166 . ; Provider specific for insurance co - add to file 355.9
     167 . S DIC(0)="L",DLAYGO=355.9,DIC="^IBA(355.9,",X=IBPRV
     168 . S:$G(IBINS) DIC("DR")=".02////"_IBINS
     169 . D FILE^DICN K DIC,DLAYGO,DD,DO
     170 . I Y'>0!$D(DUOUT)!$D(DTOUT) S IBIEN=0,IBQ=1 Q
     171 . S IBIEN=+Y
     172 . D NEWID^IBCEP5B(355.9,IBINS,IBPRV,IBPTYP,IBIEN,"")
     173 E  D
     174 . ; Insurance co default - add to file 355.91
     175 . S DIC(0)="L",DLAYGO=355.91,DIC="^IBA(355.91,",X=IBINS
     176 . D FILE^DICN K DIC,DLAYGO,DD,DO
     177 . I Y'>0!$D(DUOUT)!$D(DTOUT) S IBIEN=0,IBQ=1 Q
     178 . S IBIEN=+Y
     179 . D NEWID^IBCEP5B(355.91,IBINS,"",IBPTYP,IBIEN,1)
     180ADDIDQ Q IBQ

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP4.m

    r613 r623  
    1 IBCEP4  ;ALB/TMP - EDI UTILITIES for provider ID ;29-SEP-00
    2         ;;2.0;INTEGRATED BILLING;**137,320,348,349,377**;21-MAR-94;Build 23
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5 EN      ; -- main entry point
    6         N IBINS,IBALL,IB95
    7         D ENX
    8         Q
    9         ;
    10 EN1(IBINS)      ; -- Entry point from provider number maintenence
    11         N IBPRV,IBALL,IB95
    12         S VALMBCK="R"
    13         D ENX
    14         Q
    15         ;
    16 ENX     ; Common call to list template for dual entry points
    17         N IBSLEV,DIR,Y
    18         K IBFASTXT
    19         D FULL^VALM1
    20         S DIR(0)="SA^1:Performing Provider Care Units;2:Billing Provider Care Units"
    21         S DIR("A")="Enter Type of Care Unit: ",DIR("B")=$P($P(DIR(0),":",2),";",1)
    22         W ! D ^DIR K DIR W !
    23         I Y'>0 Q
    24         S IBSLEV=+Y
    25         I IBSLEV=2 D EN^VALM("IBCE 2ND PRVID CARE UNIT MAINT") Q
    26         D EN^VALM("IBCE PRVCARE UNIT MAINT")
    27         Q
    28         ;
    29 HDR     ; -- header
    30         K VALMHDR
    31         S VALMHDR(1)=" "
    32         S VALMHDR(2)="Insurance Co: "_$S('$G(IBALL)&$G(IBINS):$P($G(^DIC(36,+IBINS,0)),U),1:"ALL")
    33         Q
    34         ;
    35 INIT    ; -- init variables, list array
    36         N Z,IB,IBLCT,IBENT,IBNM,IB0,Z0,Z1,IBQ,DIR,Y,X
    37         I $G(IBINS) S Y=IBINS ; For entrypoint from provider number maintenance
    38         ;
    39         I '$G(IBINS) D
    40         . S DIR(0)="PA^DIC(36,:AEMQ",DIR("A")="Select INSURANCE CO: ",DIR("?")="Select an INSURANCE CO to display its care units"
    41         . D ^DIR K DIR
    42         . I $D(DTOUT)!$D(DUOUT) S Y=-2 Q
    43         . I Y>0 S IBINS=+Y Q
    44         ;
    45         I Y'=-2 D
    46         . D BLD
    47         E  D
    48         . S VALMQUIT=1
    49         Q
    50         ;
    51 BLD     ;  Bld display  - IBINS must = ien of file 36
    52         K ^TMP("IBPRV_CU",$J)
    53         ;
    54         I $G(IBSLEV)=2 Q
    55         ;
    56         S (IBENT,IBLCT)=0,IBNM=""
    57         F  S IBNM=$O(^IBA(355.95,"C",IBINS,IBNM)) Q:IBNM=""  S Z=0 F  S Z=$O(^IBA(355.95,"C",IBINS,IBNM,Z)) Q:'Z  S IB=$G(^IBA(355.95,Z,0)) I IB'="",$P(IB,U,4)="" D
    58         . S IBLCT=IBLCT+1,IBENT=IBENT+1
    59         . I '$D(^IBA(355.96,"AUNIQ",IBINS,Z)) D SET^VALM10(IBLCT,$E(IBENT_"    ",1,4)_$E($P(IB,U)_$J("",30),1,30)_"  "_$E($P(IB,U,2)_$J("",20),1,20)_" (NO COMBINATIONS FOUND)",IBENT) Q
    60         . D SET^VALM10(IBLCT,$E(IBENT_"    ",1,4)_$E($P(IB,U)_$J("",30),1,30)_"  "_$E($P(IB,U,2)_$J("",20),1,20),IBENT)
    61         . S ^TMP("IBPRV_CU",$J,"ZIDX",IBENT)=Z
    62         . S Z0=0 F  S Z0=$O(^IBA(355.96,"AE",Z,Z0)) Q:'Z0  S Z1=0 F  S Z1=$O(^IBA(355.96,"AE",Z,Z0,Z1)) Q:'Z1  S IB0=$G(^IBA(355.96,Z1,0)) I IB0'="" D
    63         .. S IBLCT=IBLCT+1
    64         .. S IBQ=$J("",28)_"o "_$E($$EXPAND^IBTRE(355.96,.06,+$P(IB0,U,6))_$J("",20),1,20)
    65         .. S IBQ=IBQ_"  "_$E($P("Both form types^UB-04 Only^CMS-1500 Only",U,$P(IB0,U,4)+1)_$J("",15),1,15)_"  "_$E($P("Inpt/Outpt^Inpt Only^Outpt Only^RX Only",U,+$P(IB0,U,5)+1)_$J("",10),1,10)
    66         .. D SET^VALM10(IBLCT,IBQ,IBENT)
    67         ;
    68         I 'IBLCT D SET^VALM10(1,"No CARE UNITs Found"_$S('$G(IBINS):"",1:" for Insurance Co")) S IBLCT=1
    69         S VALMCNT=IBLCT,VALMBG=1
    70         Q
    71         ;
    72 HELP    ; -- help
    73         ;
    74         I $G(IBSLEV)=2 Q
    75         ;
    76         S X="?" D DISP^XQORM1 W !!
    77         Q
    78         ;
    79 EXIT    ; -- exit
    80         D CLEAN^VALM10
    81         K ^TMP("IBPRV_CU",$J),IBINS,IBALL
    82         Q
    83         ;
    84 EXPND   ;
    85         Q
    86         ;
    87 SEL(IBDA,MANY)  ; Select from care unit list
    88         ; IBDA is passed by reference and IBDA(1) returned containing
    89         ;  ien's of the care unit selected (file 355.95).
    90         ; If > 1 entry can be selected, MANY is set to 1
    91         N Z
    92         S IBDA=0
    93         D EN^VALM2($G(XQORNOD(0)),$S($G(MANY):"",1:"S"))
    94         S Z=0 F  S Z=$O(VALMY(Z)) Q:'Z  S IBDA=IBDA+1,IBDA(IBDA)=+$G(^TMP("IBPRV_CU",$J,"ZIDX",Z))
    95         Q
    96         ;
    97 DISP(IBVAR,IBINS,IBPTYP,IBFT,IBCT,START,END)    ; Set up display array for
    98         ; provider id
    99         N Z
    100         S START=$S($G(START):START,1:1)
    101         S (Z,END)=$G(START)
    102         S @IBVAR@(START)="INSURANCE: "_$S(IBINS:$P($G(^DIC(36,+IBINS,0)),U),1:"ALL INSURANCE")
    103         S @IBVAR@(START+1)="PROV TYPE: "_$$EXPAND^IBTRE(355.96,.06,IBPTYP)
    104         S @IBVAR@(START+2)="FORM TYPE: "_$$EXPAND^IBTRE(355.96,.04,IBFT)
    105         S @IBVAR@(START+3)="CARE TYPE: "_$$EXPAND^IBTRE(355.96,.05,IBCT)
    106         S END=$G(START)+3
    107         Q
    108         ;
    109 CAREUOK(IBIFN,IBCU,IBTYPE,IBSEQ)        ; Returns 1 if care unit is appropriate
    110         ; for bill based on provider type, care type, bill type and insurance co
    111         ; IBIFN = ien of bill (file 399)
    112         ; IBCU = the ien of the care unit (file 355.96)
    113         ; IBTYPE = type of ID being checked (1=performing, 2=EMC)
    114         ; IBSEQ = the COB seq being checked (1-3)
    115         N Z,IBOK,IBINS,IBCT,IBFT,IBPTYP,IBRX
    116         S IBOK=0
    117         S IBINS=+$$FINDINS^IBCEF1(IBIFN,+IBSEQ),IBFT=$S($$FT^IBCEF(IBIFN)=2:2,1:1)
    118         S IBPTYP=+$S(IBTYPE=1:$$PPTYP^IBCEP0(IBINS),1:$$EMCID^IBCEP())
    119         S IBRX=$$ISRX^IBCEF1(IBIFN)
    120         S IBCT=$S('IBRX:$S($$INPAT^IBCEF(IBIFN,1):1,1:2),1:3)
    121         ;Check from most general to most specific
    122         I $D(^IBA(355.96,"AD",IBINS,0,0,IBPTYP,IBCU)) S IBOK=1 G CAREOKQ
    123         I 'IBRX,$D(^IBA(355.96,"AD",IBINS,IBFT,0,IBPTYP,IBCU)) S IBOK=1 G CAREOKQ
    124         I $D(^IBA(355.96,"AD",IBINS,0,IBCT,IBPTYP,IBCU)) S IBOK=1 G CAREOKQ
    125         I $D(^IBA(355.96,"AD",IBINS,IBFT,IBCT,IBPTYP,IBCU)) S IBOK=1 G CAREOKQ
    126         ;
    127 CAREOKQ Q IBOK
    128         ;
     1IBCEP4 ;ALB/TMP - EDI UTILITIES for provider ID ;29-SEP-00
     2 ;;2.0;INTEGRATED BILLING;**137,320,348,349**;21-MAR-94;Build 46
     3 ;;Per VHA Directive 2004-038, this routine should not be modified.
     4 ;
     5EN ; -- main entry point
     6 N IBINS,IBALL,IB95
     7 D ENX
     8 Q
     9 ;
     10EN1(IBINS) ; -- Entry point from provider number maintenence
     11 N IBPRV,IBALL,IB95
     12 D ENX
     13 Q
     14 ;
     15ENX ; Common call to list template for dual entry points
     16 N IBSLEV,DIR,Y
     17 K IBFASTXT
     18 D FULL^VALM1
     19 S DIR(0)="SA^1:Care Units for Performing Provider IDs;2:Care Units for Billing Provider Secondary IDs"
     20 S DIR("A")="Enter Type of Care Unit: ",DIR("B")=$P($P(DIR(0),":",2),";")
     21 W ! D ^DIR K DIR W !
     22 I Y'>0 Q
     23 S IBSLEV=+Y
     24 I IBSLEV=2 D EN^VALM("IBCE 2ND PRVID CARE UNIT MAINT") Q
     25 D EN^VALM("IBCE PRVCARE UNIT MAINT")
     26 Q
     27 ;
     28HDR ; -- header
     29 K VALMHDR
     30 S VALMHDR(1)=" "
     31 S VALMHDR(2)="Insurance Co: "_$S('$G(IBALL)&$G(IBINS):$P($G(^DIC(36,+IBINS,0)),U),1:"ALL")
     32 Q
     33 ;
     34INIT ; -- init variables, list array
     35 N Z,IB,IBLCT,IBENT,IBNM,IB0,Z0,Z1,IBQ,DIR,Y,X
     36 I $G(IBINS) S Y=IBINS ; For entrypoint from provider number maintenance
     37 ;
     38 I '$G(IBINS) D
     39 . S DIR(0)="PA^DIC(36,:AEMQ",DIR("A")="Select INSURANCE CO: ",DIR("?")="Select an INSURANCE CO to display its care units"
     40 . D ^DIR K DIR
     41 . I $D(DTOUT)!$D(DUOUT) S Y=-2 Q
     42 . I Y>0 S IBINS=+Y Q
     43 ;
     44 I Y'=-2 D
     45 . D BLD
     46 E  D
     47 . S VALMQUIT=1
     48 Q
     49 ;
     50BLD ;  Bld display  - IBINS must = ien of file 36
     51 K ^TMP("IBPRV_CU",$J)
     52 ;
     53 I $G(IBSLEV)=2 Q
     54 ;
     55 S (IBENT,IBLCT)=0,IBNM=""
     56 F  S IBNM=$O(^IBA(355.95,"C",IBINS,IBNM)) Q:IBNM=""  S Z=0 F  S Z=$O(^IBA(355.95,"C",IBINS,IBNM,Z)) Q:'Z  S IB=$G(^IBA(355.95,Z,0)) I IB'="",$P(IB,U,4)="" D
     57 . S IBLCT=IBLCT+1,IBENT=IBENT+1
     58 . I '$D(^IBA(355.96,"AUNIQ",IBINS,Z)) D SET^VALM10(IBLCT,$E(IBENT_"    ",1,4)_$E($P(IB,U)_$J("",30),1,30)_"  "_$E($P(IB,U,2)_$J("",20),1,20)_" (NO COMBINATIONS FOUND)",IBENT) Q
     59 . D SET^VALM10(IBLCT,$E(IBENT_"    ",1,4)_$E($P(IB,U)_$J("",30),1,30)_"  "_$E($P(IB,U,2)_$J("",20),1,20),IBENT)
     60 . S ^TMP("IBPRV_CU",$J,"ZIDX",IBENT)=Z
     61 . S Z0=0 F  S Z0=$O(^IBA(355.96,"AE",Z,Z0)) Q:'Z0  S Z1=0 F  S Z1=$O(^IBA(355.96,"AE",Z,Z0,Z1)) Q:'Z1  S IB0=$G(^IBA(355.96,Z1,0)) I IB0'="" D
     62 .. S IBLCT=IBLCT+1
     63 .. S IBQ=$J("",28)_"o "_$E($$EXPAND^IBTRE(355.96,.06,+$P(IB0,U,6))_$J("",20),1,20)
     64 .. S IBQ=IBQ_"  "_$E($P("Both form types^UB-04 Only^CMS-1500 Only",U,$P(IB0,U,4)+1)_$J("",15),1,15)_"  "_$E($P("Inpt/Outpt^Inpt Only^Outpt Only^RX Only",U,+$P(IB0,U,5)+1)_$J("",10),1,10)
     65 .. D SET^VALM10(IBLCT,IBQ,IBENT)
     66 ;
     67 I 'IBLCT D SET^VALM10(1,"No CARE UNITs Found"_$S('$G(IBINS):"",1:" for Insurance Co"))
     68 S VALMCNT=IBLCT,VALMBG=1
     69 Q
     70 ;
     71HELP ; -- help
     72 ;
     73 I $G(IBSLEV)=2 Q
     74 ;
     75 S X="?" D DISP^XQORM1 W !!
     76 Q
     77 ;
     78EXIT ; -- exit
     79 K IBFASTXT
     80 D CLEAN^VALM10
     81 K ^TMP("IBPRV_CU",$J),IBINS,IBALL
     82 Q
     83 ;
     84EXPND ;
     85 Q
     86 ;
     87SEL(IBDA,MANY) ; Select from care unit list
     88 ; IBDA is passed by reference and IBDA(1) returned containing
     89 ;  ien's of the care unit selected (file 355.95).
     90 ; If > 1 entry can be selected, MANY is set to 1
     91 N Z
     92 S IBDA=0
     93 D EN^VALM2($G(XQORNOD(0)),$S($G(MANY):"",1:"S"))
     94 S Z=0 F  S Z=$O(VALMY(Z)) Q:'Z  S IBDA=IBDA+1,IBDA(IBDA)=+$G(^TMP("IBPRV_CU",$J,"ZIDX",Z))
     95 Q
     96 ;
     97DISP(IBVAR,IBINS,IBPTYP,IBFT,IBCT,START,END) ; Set up display array for
     98 ; provider id
     99 N Z
     100 S START=$S($G(START):START,1:1)
     101 S (Z,END)=$G(START)
     102 S @IBVAR@(START)="INSURANCE: "_$S(IBINS:$P($G(^DIC(36,+IBINS,0)),U),1:"ALL INSURANCE")
     103 S @IBVAR@(START+1)="PROV TYPE: "_$$EXPAND^IBTRE(355.96,.06,IBPTYP)
     104 S @IBVAR@(START+2)="FORM TYPE: "_$$EXPAND^IBTRE(355.96,.04,IBFT)
     105 S @IBVAR@(START+3)="CARE TYPE: "_$$EXPAND^IBTRE(355.96,.05,IBCT)
     106 S END=$G(START)+3
     107 Q
     108 ;
     109CAREUOK(IBIFN,IBCU,IBTYPE,IBSEQ) ; Returns 1 if care unit is appropriate
     110 ; for bill based on provider type, care type, bill type and insurance co
     111 ; IBIFN = ien of bill (file 399)
     112 ; IBCU = the ien of the care unit (file 355.96)
     113 ; IBTYPE = type of ID being checked (1=performing, 2=EMC)
     114 ; IBSEQ = the COB seq being checked (1-3)
     115 N Z,IBOK,IBINS,IBCT,IBFT,IBPTYP,IBRX
     116 S IBOK=0
     117 S IBINS=+$$FINDINS^IBCEF1(IBIFN,+IBSEQ),IBFT=$S($$FT^IBCEF(IBIFN)=2:2,1:1)
     118 S IBPTYP=+$S(IBTYPE=1:$$PPTYP^IBCEP0(IBINS),1:$$EMCID^IBCEP())
     119 S IBRX=$$ISRX^IBCEF1(IBIFN)
     120 S IBCT=$S('IBRX:$S($$INPAT^IBCEF(IBIFN,1):1,1:2),1:3)
     121 ;Check from most general to most specific
     122 I $D(^IBA(355.96,"AD",IBINS,0,0,IBPTYP,IBCU)) S IBOK=1 G CAREOKQ
     123 I 'IBRX,$D(^IBA(355.96,"AD",IBINS,IBFT,0,IBPTYP,IBCU)) S IBOK=1 G CAREOKQ
     124 I $D(^IBA(355.96,"AD",IBINS,0,IBCT,IBPTYP,IBCU)) S IBOK=1 G CAREOKQ
     125 I $D(^IBA(355.96,"AD",IBINS,IBFT,IBCT,IBPTYP,IBCU)) S IBOK=1 G CAREOKQ
     126 ;
     127CAREOKQ Q IBOK
     128 ;

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP4A.m

    r613 r623  
    1 IBCEP4A ;ALB/TMP - EDI UTILITIES for provider ID ;29-SEP-00
    2         ;;2.0;INTEGRATED BILLING;**137,232,280,349,377**;21-MAR-94;Build 23
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5 NEW(IB) ; Add care unit
    6         ; Assumes IBINS is defined as ins co ien (file 36)
    7         ; IB = 0 or null if called from list manager, 1 if not
    8         N DIC,DIR,X,Y,Z,DA,DR,DIE,DO,DD,DLAYGO,IB95,IBADD,IBOK
    9         I '$G(IB) D FULL^VALM1
    10         ;
    11         ; Add an entry - either new care unit/ins co or a combination for
    12         ;  existing care unit/ins co
    13         S DIC("A")="SELECT CARE UNIT FOR THE INSURANCE CO: ",DIC="^IBA(355.95,",DIC("S")="I $P(^(0),U,3)=+$G(IBINS)",DIC(0)="AELMQ",DIC("DR")=".03////"_+$G(IBINS)_";.02",DLAYGO=355.95 D ^DIC K DIC,DLAYGO
    14         G:Y'>0 NEWQ
    15         S IB95=3,IB95("IBCU")=+Y
    16         D INSASS(IBINS,.IB95)
    17         I '$G(IB) D BLD^IBCEP4
    18 NEWQ    I '$G(IB) S VALMBCK="R"
    19         Q
    20         ;
    21 CHANGE(IB)      ; Edit a care unit name or combination for ins co IBINS
    22         ; Assumes IBINS is defined as ins co ien (file 36)
    23         ; IB = 0 or null if called from list manager, 1 if not
    24         N DIC,DIK,DIR,X,Y,Z,DA,DR,DIE,DO,DD,DLAYGO,IB95,IBOK,IBZ,IB0,IBEDIT,IBCK,IBDA,IBCHG,IBDELETE,Z100,DTOUT,DUOUT
    25         I '$G(IB) D FULL^VALM1 S Y=$$SEL()
    26         I $G(IB) S DIC("A")="CARE UNIT NAME: ",DIC(0)="AEMQ",DIC("S")="I $P(^(0),U,3)=+$G(IBINS)",DIC="^IBA(355.95," W ! D ^DIC K DIC
    27         I Y'>0 G CHGQ
    28         S IB95("IBCU")=+Y,IBDELETE=0,IBDELETE(0)=$G(^IBA(355.95,0)),IBDELETE(1)=$G(^(1))
    29         ; Edit fields outside of FM to assure uniqueness of combos is maintained
    30         W ! S DIR("A")="CARE UNIT NAME: ",DIR("B")=$P($G(^IBA(355.95,+IB95("IBCU"),0)),U),DIR(0)="355.95,.01AO",DIR("S")="I $P(^(0),U,3)=IBINS" D ^DIR K DIR
    31         I $D(DTOUT)!$D(DUOUT) G CHGQ
    32         I X="@" S DIR(0)="EA",DIR("A")="NOTHING DELETED - PRESS ENTER TO CONTINUE" D ^DIR K DIR G CHGQ
    33         I $P($G(^IBA(355.95,IB95("IBCU"),0)),U)'=Y S DIE="^IBA(355.95,",DR=".01///"_Y,DA=IB95("IBCU") D ^DIE ; File the name change
    34         S DR=".02",DIE="^IBA(355.95,",DA=IB95("IBCU") D ^DIE
    35         I $D(Y) G CHGQ
    36         ;
    37         I $O(^IBA(355.96,"ACARE",IB95("IBCU"),""))="" S IB95=3 D INSASS(IBINS,.IB95) G CHGQ
    38         ; only 1 combination found for ins/care unit
    39         I $O(^IBA(355.96,"ACARE",IB95("IBCU"),""),-1)=$O(^IBA(355.96,"ACARE",IB95("IBCU"),0)) D
    40         . S IBDA=$O(^IBA(355.96,"ACARE",IB95("IBCU"),0))
    41         ;
    42         ; Choose the combination to edit - more than 1 exists
    43         E  D
    44         . W !,"SELECT ONE OF THE FOLLOWING CARE UNIT COMBINATIONS:"
    45         . S DIC="^IBA(355.96,",DIC(0)="EMQ",DIC("S")="I $D(^IBA(355.96,""ACARE"","_IB95("IBCU")_",Y))",X=IBINS D ^DIC K DIC S IBDA=+Y
    46         ;
    47         I IBDA>0 D
    48         . N IBDA0,Q,Q0
    49         . S IBDA0=$G(^IBA(355.96,IBDA,0))
    50         . Q:IBDA0=""
    51         . W !!,"*** CARE UNIT COMBINATION FOR: ",$P($G(^IBA(355.95,+IB95("IBCU"),0)),U)," ***"
    52         . D DISP^IBCEP4("Q",IBINS,$P(IBDA0,U,6),$P(IBDA0,U,4),$P(IBDA0,U,5),1,.Q0)
    53         . S Z=0 F  S Z=$O(Q(Z)) Q:'Z  W !,Q(Z)
    54         . I $P(IBDA0,U,7) W !,"EXP DATE: ",$$FMTE^XLFDT($P(IBDA0,U,7),"2D")
    55         . W !,"CARE UNIT: ",$P($G(^IBA(355.95,+IBDA0,0)),U),!
    56         . W ! S DIR(0)="SA^E:EDIT;D:DELETE",DIR("B")="EDIT",DIR("A")="EDIT OR DELETE THIS CARE UNIT COMBINATION?: " D ^DIR K DIR
    57         . I $D(DTOUT)!$D(DUOUT) Q
    58         . I Y="D" D  Q
    59         .. S DIR(0)="YA",DIR("A")="ARE YOU SURE YOU WANT TO DELETE THIS CARE UNIT COMBINATION?: ",DIR("B")="NO" D ^DIR K DIR
    60         .. I Y=1 S DIK="^IBA(355.96,",DA=IBDA,IBCHG=1 D ^DIK
    61         . S (IBCK,IBCHG)=0,(IBEDIT,IBOK)=1
    62         . F  Q:'IBEDIT  S IBEDIT=0,IB0=$G(^IBA(355.96,+IBDA,0)) K IBZ F Z=.01,.03,.06,.04,.05 D  Q:'IBOK!IBEDIT
    63         .. S Z100=Z*100
    64         .. I Z100=1 W !,"CARE UNIT: ",$P($G(^IBA(355.95,IB95("IBCU"),0)),U) S IBZ(.01)=$P(IB0,U) Q
    65         .. I Z100=3 W !,"INSURANCE COMPANY: ",$$EXPAND^IBTRE(355.96,.03,$P(IB0,U,3)) S IBZ(.03)=$P(IB0,U) Q
    66         .. I Z100=5 S IBCK=1
    67         .. S IBZ(Z)=$$EDIT(Z,IB0,+IBDA,IBCK),IBCK=0
    68         .. I '$P(IBZ(Z),U,2) D  Q
    69         ... I $P(IB0,U,Z100)'=IBZ(Z) S IBCHG=1
    70         ... S $P(IB0,U,Z100)=IBZ(Z)
    71         .. S (IBOK,IBCHG)=0
    72         .. I $P(IBZ(Z),U,2)=2 D
    73         ... S DIR(0)="YA",DIR("A",1)="This entry already exists",DIR("A")="Do you want to re-edit?: " W ! D ^DIR K DIR W !
    74         ... I Y=1 S (IBOK,IBEDIT)=1
    75         . I IBOK Q:'IBCHG  S DIE="^IBA(355.96,",DR=".03////"_IBZ(.03)_";.04////"_IBZ(.04)_";.05////"_IBZ(.05)_";.06////"_IBZ(.06)_";.07",DA=+IBDA D ^DIE,BLD^IBCEP4 Q
    76         ;
    77         I '$G(IB) D BLD^IBCEP4
    78 CHGQ    I '$G(IB) S VALMBCK="R"
    79         Q
    80         ;
    81 INSASS(IBINSZ,IB95)     ; Assign care unit to or delete from an ins co
    82         ; IBINSZ = ien of ins co (file 36)
    83         ; IB95 = flag  ("IBCU")=care unit
    84         ;     can have subscripts to send in pre-entered data
    85         N DIR,DIC,DA,DR,X,Y,Z,IBFT,IBCT,IBPTYP,IBCU,IBCHG,IBINS,IBDA,IBPXDT,IBDICS
    86         S IBINS=IBINSZ
    87         S IBCHG=0,IBCU=$G(IB95("IBCU"))
    88         D FULL^VALM1
    89         I '$G(IBINSZ) K IB95 G INSQ
    90         W !
    91         F Z=.06,.04,.05,.07,.03 D  G:Z="" INSQ
    92         . ;
    93         . I $S(Z=.04:'$D(IB95("IBFT")),Z=.05:'$D(IB95("IBCT")),Z=.06:'$D(IB95("IBPTYP")),Z=.03:'$D(IB95("IBCU")),1:1) D
    94         .. N DA
    95         .. K IBDICS
    96         .. I Z=.04 D
    97         ... I $P($G(^IBE(355.97,+$G(IB95("IBPTYP")),0)),U,3)="1A" S IBDICS="I Y'=1 K X",DIR("B")="UB-04",DIR("?")="ONLY UB-04 IS VALID FOR A BLUE CROSS ID"
    98         .. S DIR(0)="355.96,"_Z_$S($G(IBDICS)="":"",1:"^^"_IBDICS) D ^DIR K DIR
    99         . I $D(DTOUT)!$D(DUOUT) S VALMBCK="R",Z="" K:$G(IB95)=2 IB95 Q
    100         . ;
    101         . I Z=.04 S IBFT=$S($G(IB95("IBFT"))="":+Y,1:IB95("IBFT")) S IB95("IBFT")=IBFT Q
    102         . ;
    103         . I Z=.05 S IBCT=$S($G(IB95("IBCT"))="":+Y,1:IB95("IBCT")) S IB95("IBCT")=IBCT Q
    104         . ;
    105         . I Z=.06 S IBPTYP=$S($G(IB95("IBPTYP"))="":+Y,1:IB95("IBPTYP")) S IB95("IBPTYP")=IBPTYP Q
    106         . ;
    107         . I Z=.07 S IBPXDT=$S('$G(IB95("IBEXPDT")):+Y,1:IB95("IBEXPDT")) S IB95("IBEXPDT")=IBPXDT Q
    108         . ;
    109         . I Z=.03,$G(IB95)=3,$G(IB95("IBCU"))'="" D  Q:Z=""
    110         .. N Q  ; Assign from add care type
    111         .. S IBCT=0
    112         .. W !,"CARE UNIT: "_$$EXPAND^IBTRE(355.96,.01,IB95("IBCU"))
    113         .. S IB95("IBINS")=+IBINSZ
    114         .. I $D(^IBA(355.96,"AUNIQ",IBINSZ,IB95("IBCU"),IB95("IBFT"),IB95("IBCT"),IB95("IBPTYP"))) D  Q
    115         ... S DIR(0)="EA",DIR("A",1)="This combination already exists - NOT ADDED",DIR("A")="Press ENTER to continue" W ! D ^DIR K DIR W !
    116         .. S IBCT=1 S Y=$$ADDCU(IBINSZ,IB95("IBCU"),IB95("IBFT"),IB95("IBCT"),IB95("IBPTYP"))
    117         .. I Y<0 W ! S DIR("A",1)="  >> Care Unit NOT completely filed",DIR("A")="PRESS ENTER TO CONTINUE ",DIR(0)="EA" D ^DIR K DIR Q
    118         .. W ! S DIR(0)="EA",DIR("A",1)="  >> CARE UNIT COMBINATION FILED FOR THE INSURANCE CO",IBCT=1,IBCHG=1,DIR("A")="PRESS ENTER TO CONTINUE ",DIR(0)="EA" D ^DIR K DIR
    119         I $G(IBCHG) D BLD^IBCEP4
    120 INSQ    S VALMBCK="R"
    121         Q
    122         ;
    123 EDIT(IBFLD,IB0,IBIEN,IBCK1)     ; Allow addition/edit of fields in file 355.96
    124         ; without direct Fileman call so uniqueness can be checked
    125         ; IBFLD = field # in file 355.96
    126         ; IB0 = current 0-node of data in the entry in file 355.96
    127         ; IBIEN = ien of entry being edited in file 355.96
    128         ; IBCK1 = flag ... if 1, checks for uniqueness after field changed
    129         ;
    130         ; FUNCTION RETURNS: value of field if field is OK, second piece is null
    131         ;                   If not good, 2nd piece = 1 : no data or ^ entered
    132         ;                                          = 2 : record not unique
    133         N DIR,DA,Y,X,IBNEW,IBINS,IBVAL
    134         S IBINS=+IB0,IBNEW="",IBVAL=$$EXPAND^IBTRE(355.96,IBFLD,$P(IB0,U,(IBFLD*100)))
    135         S DIR(0)="355.96,"_IBFLD
    136         S:IBVAL'="" DIR("B")=IBVAL
    137         D ^DIR K DIR
    138         I Y=""!$D(DTOUT)!$D(DUOUT) S IBNEW="^1" G EDITQ
    139         S IBNEW=$P(Y,U)
    140         I $G(IBCK1) D
    141         . N X1,X2,X3,X4,X5
    142         . S X1=$S(IBFLD'=.03:IBINS,1:IBNEW),X2=$S(IBFLD'=.01:$P(IB0,U),1:IBNEW),X3=$S(IBFLD'=.04:$P(IB0,U,4),1:IBNEW),X4=$S(IBFLD'=.05:$P(IB0,U,5),1:IBNEW),X5=$S(IBFLD'=.06:$P(IB0,U,6),1:IBNEW)
    143         . I $S(X1=""!(X2="")!(X3="")!(X4="")!(X5=""):1,$O(^IBA(355.96,"AUNIQ",X1,X2,X3,X4,X5,0)):$O(^(0))'=IBIEN,1:0) S IBNEW=IBNEW_"^2"
    144         ;
    145 EDITQ   Q IBNEW
    146         ;
    147 ADDCU(IBINSZ,IBCU,IBFT,IBCT,IBPTYP)     ;  Add a new care unit record to file 355.96
    148         ; Same parameter definitions as EDIT
    149         N DIC,DA,X,Y,DLAYGO
    150         S DIC(0)="L",DLAYGO=355.96,DIC="^IBA(355.96,",DIC("DR")=".03////"_IBINSZ_";.04////"_IBFT_";.05////"_IBCT_";.06////"_IBPTYP,X=IBCU
    151         D FILE^DICN
    152         Q Y
    153         ;
    154 DELETE(IB)      ; delete a care unit name
    155         ; IB = 0 or null if called from list manager, 1 if not
    156         N DIR,X,Y
    157         I '$G(IB) D FULL^VALM1 S Y=$$SEL() I Y'>0 G DELETEQ
    158         S:'$G(IB) IB95("IBCU")=+Y
    159         S DIR("A",1)="THIS WILL DELETE THE CARE UNIT NAME AND ALL ITS COMBINATIONS",DIR("A")="ARE YOU SURE THIS IS WHAT YOU WANT TO DO?: ",DIR(0)="YA",DIR("B")="NO" D ^DIR K DIR
    160         I Y'=1 S IB95("IBCU")="" Q  ; Changed their mind - don't delete
    161         S Z=0 F  S Z=$O(^IBA(355.96,"B",IB95("IBCU"),Z)) Q:'Z  S DIK="^IBA(355.96,",DA=Z D ^DIK
    162         S DA=IB95("IBCU"),DIK="^IBA(355.95," D ^DIK
    163         W ! S DIR(0)="EA",DIR("A",1)="CARE UNIT AND ALL ITS COMBINATIONS WERE DELETED",DIR("A")="PRESS ENTER TO CONTINUE " D ^DIR K DIR D BLD^IBCEP4
    164 DELETEQ ;
    165         S:'$G(IB) VALMBCK="R"
    166         Q
    167         ;
    168 SEL()   ; Select entry from list
    169         ; returns ien in file 355.95 for selected entry
    170         N VALMY,SEL
    171         D EN^VALM2($G(XQORNOD(0)),"S")
    172         S SEL=+$O(VALMY(""))
    173         I SEL'>0 Q 0
    174         Q +$G(^TMP("IBPRV_CU",$J,"ZIDX",SEL))
    175         ;
     1IBCEP4A ;ALB/TMP - EDI UTILITIES for provider ID ;29-SEP-00
     2 ;;2.0;INTEGRATED BILLING;**137,232,280,349**;21-MAR-94;Build 46
     3 ;;Per VHA Directive 2004-038, this routine should not be modified.
     4 ;
     5NEW(IB) ; Add care unit
     6 ; Assumes IBINS is defined as ins co ien (file 36)
     7 ; IB = 0 or null if called from list manager, 1 if not
     8 N DIC,DIR,X,Y,Z,DA,DR,DIE,DO,DD,DLAYGO,IB95,IBADD,IBOK
     9 I '$G(IB) D FULL^VALM1
     10 ;
     11 ; Add an entry - either new care unit/ins co or a combination for
     12 ;  existing care unit/ins co
     13 S DIC("A")="SELECT CARE UNIT FOR THE INSURANCE CO: ",DIC="^IBA(355.95,",DIC("S")="I $P(^(0),U,3)=+$G(IBINS)",DIC(0)="AELMQ",DIC("DR")=".03////"_+$G(IBINS)_";.02",DLAYGO=355.95 D ^DIC K DIC,DLAYGO
     14 G:Y'>0 NEWQ
     15 S IB95=3,IB95("IBCU")=+Y
     16 D INSASS(IBINS,.IB95)
     17 I '$G(IB) D BLD^IBCEP4
     18NEWQ I '$G(IB) S VALMBCK="R"
     19 Q
     20 ;
     21CHANGE(IB) ; Edit a care unit name or combination for ins co IBINS
     22 ; Assumes IBINS is defined as ins co ien (file 36)
     23 ; IB = 0 or null if called from list manager, 1 if not
     24 N DIC,DIK,DIR,X,Y,Z,DA,DR,DIE,DO,DD,DLAYGO,IB95,IBOK,IBZ,IB0,IBEDIT,IBCK,IBDA,IBCHG,IBDELETE,Z100,DTOUT,DUOUT
     25 I '$G(IB) D FULL^VALM1
     26 S DIC("A")="CARE UNIT NAME: ",DIC(0)="AEMQ",DIC("S")="I $P(^(0),U,3)=+$G(IBINS)",DIC="^IBA(355.95," W ! D ^DIC K DIC
     27 I Y'>0 G CHGQ
     28 S IB95("IBCU")=+Y,IBDELETE=0,IBDELETE(0)=$G(^IBA(355.95,0)),IBDELETE(1)=$G(^(1))
     29 ; Edit fields outside of FM to assure uniqueness of combos is maintained
     30 W ! S DIR("A")="CARE UNIT NAME: ",DIR("B")=$P($G(^IBA(355.95,+IB95("IBCU"),0)),U),DIR(0)="355.95,.01AO",DIR("S")="I $P(^(0),U,3)=IBINS" D ^DIR K DIR
     31 I $D(DTOUT)!$D(DUOUT) G CHGQ
     32 ;
     33 ; Care unit name was deleted
     34 I X="@" D  G CHGQ
     35 . S DIR("A",1)="THIS WILL DELETE THE CARE UNIT NAME AND ALL ITS COMBINATIONS",DIR("A")="ARE YOU SURE THIS IS WHAT YOU WANT TO DO?: ",DIR(0)="YA",DIR("B")="NO" D ^DIR K DIR
     36 . I Y'=1 S IB95("IBCU")="" Q  ; Changed their mind - don't delete
     37 . S Z=0 F  S Z=$O(^IBA(355.96,"B",IB95("IBCU"),Z)) Q:'Z  S DIK="^IBA(355.96,",DA=Z D ^DIK
     38 . S DA=IB95("IBCU"),DIK="^IBA(355.95," D ^DIK
     39 . W ! S DIR(0)="EA",DIR("A",1)="CARE UNIT AND ALL ITS COMBINATIONS WERE DELETED",DIR("A")="PRESS ENTER TO CONTINUE " D ^DIR K DIR D BLD^IBCEP4
     40 ;
     41 I $P($G(^IBA(355.95,IB95("IBCU"),0)),U)'=Y S DIE="^IBA(355.95,",DR=".01///"_Y,DA=IB95("IBCU") D ^DIE ; File the name change
     42 S DR=".02",DIE="^IBA(355.95,",DA=IB95("IBCU") D ^DIE
     43 I $D(Y) G CHGQ
     44 ;
     45 I $O(^IBA(355.96,"ACARE",IB95("IBCU"),""))="" S IB95=3 D INSASS(IBINS,.IB95) G CHGQ
     46 ; only 1 combination found for ins/care unit
     47 I $O(^IBA(355.96,"ACARE",IB95("IBCU"),""),-1)=$O(^IBA(355.96,"ACARE",IB95("IBCU"),0)) D
     48 . S IBDA=$O(^IBA(355.96,"ACARE",IB95("IBCU"),0))
     49 ;
     50 ; Choose the combination to edit - more than 1 exists
     51 E  D
     52 . W !,"SELECT ONE OF THE FOLLOWING CARE UNIT COMBINATIONS:"
     53 . S DIC="^IBA(355.96,",DIC(0)="EMQ",DIC("S")="I $D(^IBA(355.96,""ACARE"","_IB95("IBCU")_",Y))",X=IBINS D ^DIC K DIC S IBDA=+Y
     54 ;
     55 I IBDA>0 D
     56 . N IBDA0,Q,Q0
     57 . S IBDA0=$G(^IBA(355.96,IBDA,0))
     58 . Q:IBDA0=""
     59 . W !!,"*** CARE UNIT COMBINATION FOR: ",$P($G(^IBA(355.95,+IB95("IBCU"),0)),U)," ***"
     60 . D DISP^IBCEP4("Q",IBINS,$P(IBDA0,U,6),$P(IBDA0,U,4),$P(IBDA0,U,5),1,.Q0)
     61 . S Z=0 F  S Z=$O(Q(Z)) Q:'Z  W !,Q(Z)
     62 . I $P(IBDA0,U,7) W !,"EXP DATE: ",$$FMTE^XLFDT($P(IBDA0,U,7),"2D")
     63 . W !,"CARE UNIT: ",$P($G(^IBA(355.95,+IBDA0,0)),U),!
     64 . W ! S DIR(0)="SA^E:EDIT;D:DELETE",DIR("B")="EDIT",DIR("A")="EDIT OR DELETE THIS CARE UNIT COMBINATION?: " D ^DIR K DIR
     65 . I $D(DTOUT)!$D(DUOUT) Q
     66 . I Y="D" D  Q
     67 .. S DIR(0)="YA",DIR("A")="ARE YOU SURE YOU WANT TO DELETE THIS CARE UNIT COMBINATION?: ",DIR("B")="NO" D ^DIR K DIR
     68 .. I Y=1 S DIK="^IBA(355.96,",DA=IBDA,IBCHG=1 D ^DIK
     69 . S (IBCK,IBCHG)=0,(IBEDIT,IBOK)=1
     70 . F  Q:'IBEDIT  S IBEDIT=0,IB0=$G(^IBA(355.96,+IBDA,0)) K IBZ F Z=.01,.03,.06,.04,.05 D  Q:'IBOK!IBEDIT
     71 .. S Z100=Z*100
     72 .. I Z100=1 W !,"CARE UNIT: ",$P($G(^IBA(355.95,IB95("IBCU"),0)),U) S IBZ(.01)=$P(IB0,U) Q
     73 .. I Z100=3 W !,"INSURANCE COMPANY: ",$$EXPAND^IBTRE(355.96,.03,$P(IB0,U,3)) S IBZ(.03)=$P(IB0,U) Q
     74 .. I Z100=5 S IBCK=1
     75 .. S IBZ(Z)=$$EDIT(Z,IB0,+IBDA,IBCK),IBCK=0
     76 .. I '$P(IBZ(Z),U,2) D  Q
     77 ... I $P(IB0,U,Z100)'=IBZ(Z) S IBCHG=1
     78 ... S $P(IB0,U,Z100)=IBZ(Z)
     79 .. S (IBOK,IBCHG)=0
     80 .. I $P(IBZ(Z),U,2)=2 D
     81 ... S DIR(0)="YA",DIR("A",1)="This entry already exists",DIR("A")="Do you want to re-edit?: " W ! D ^DIR K DIR W !
     82 ... I Y=1 S (IBOK,IBEDIT)=1
     83 . I IBOK Q:'IBCHG  S DIE="^IBA(355.96,",DR=".03////"_IBZ(.03)_";.04////"_IBZ(.04)_";.05////"_IBZ(.05)_";.06////"_IBZ(.06)_";.07",DA=+IBDA D ^DIE,BLD^IBCEP4 Q
     84 ;
     85 I '$G(IB) D BLD^IBCEP4
     86CHGQ I '$G(IB) S VALMBCK="R"
     87 Q
     88 ;
     89INSASS(IBINSZ,IB95) ; Assign care unit to or delete from an ins co
     90 ; IBINSZ = ien of ins co (file 36)
     91 ; IB95 = flag  ("IBCU")=care unit
     92 ;     can have subscripts to send in pre-entered data
     93 N DIR,DIC,DA,DR,X,Y,Z,IBFT,IBCT,IBPTYP,IBCU,IBCHG,IBINS,IBDA,IBPXDT,IBDICS
     94 S IBINS=IBINSZ
     95 S IBCHG=0,IBCU=$G(IB95("IBCU"))
     96 D FULL^VALM1
     97 I '$G(IBINSZ) K IB95 G INSQ
     98 W !
     99 F Z=.06,.04,.05,.07,.03 D  G:Z="" INSQ
     100 . ;
     101 . I $S(Z=.04:'$D(IB95("IBFT")),Z=.05:'$D(IB95("IBCT")),Z=.06:'$D(IB95("IBPTYP")),Z=.03:'$D(IB95("IBCU")),1:1) D
     102 .. N DA
     103 .. K IBDICS
     104 .. I Z=.04 D
     105 ... I $P($G(^IBE(355.97,+$G(IB95("IBPTYP")),0)),U,3)="1A" S IBDICS="I Y'=1 K X",DIR("B")="UB-04",DIR("?")="ONLY UB-04 IS VALID FOR A BLUE CROSS ID"
     106 .. S DIR(0)="355.96,"_Z_$S($G(IBDICS)="":"",1:"^^"_IBDICS) D ^DIR K DIR
     107 . I $D(DTOUT)!$D(DUOUT) S VALMBCK="R",Z="" K:$G(IB95)=2 IB95 Q
     108 . ;
     109 . I Z=.04 S IBFT=$S($G(IB95("IBFT"))="":+Y,1:IB95("IBFT")) S IB95("IBFT")=IBFT Q
     110 . ;
     111 . I Z=.05 S IBCT=$S($G(IB95("IBCT"))="":+Y,1:IB95("IBCT")) S IB95("IBCT")=IBCT Q
     112 . ;
     113 . I Z=.06 S IBPTYP=$S($G(IB95("IBPTYP"))="":+Y,1:IB95("IBPTYP")) S IB95("IBPTYP")=IBPTYP Q
     114 . ;
     115 . I Z=.07 S IBPXDT=$S('$G(IB95("IBEXPDT")):+Y,1:IB95("IBEXPDT")) S IB95("IBEXPDT")=IBPXDT Q
     116 . ;
     117 . I Z=.03,$G(IB95)=3,$G(IB95("IBCU"))'="" D  Q:Z=""
     118 .. N Q  ; Assign from add care type
     119 .. S IBCT=0
     120 .. W !,"CARE UNIT: "_$$EXPAND^IBTRE(355.96,.01,IB95("IBCU"))
     121 .. S IB95("IBINS")=+IBINSZ
     122 .. I $D(^IBA(355.96,"AUNIQ",IBINSZ,IB95("IBCU"),IB95("IBFT"),IB95("IBCT"),IB95("IBPTYP"))) D  Q
     123 ... S DIR(0)="EA",DIR("A",1)="This combination already exists - NOT ADDED",DIR("A")="Press ENTER to continue" W ! D ^DIR K DIR W !
     124 .. S IBCT=1 S Y=$$ADDCU(IBINSZ,IB95("IBCU"),IB95("IBFT"),IB95("IBCT"),IB95("IBPTYP"))
     125 .. I Y<0 W ! S DIR("A",1)="  >> Care Unit NOT completely filed",DIR("A")="PRESS ENTER TO CONTINUE ",DIR(0)="EA" D ^DIR K DIR Q
     126 .. W ! S DIR(0)="EA",DIR("A",1)="  >> CARE UNIT COMBINATION FILED FOR THE INSURANCE CO",IBCT=1,IBCHG=1,DIR("A")="PRESS ENTER TO CONTINUE ",DIR(0)="EA" D ^DIR K DIR
     127 I $G(IBCHG) D BLD^IBCEP4
     128INSQ S VALMBCK="R"
     129 Q
     130 ;
     131EDIT(IBFLD,IB0,IBIEN,IBCK1) ; Allow addition/edit of fields in file 355.96
     132 ; without direct Fileman call so uniqueness can be checked
     133 ; IBFLD = field # in file 355.96
     134 ; IB0 = current 0-node of data in the entry in file 355.96
     135 ; IBIEN = ien of entry being edited in file 355.96
     136 ; IBCK1 = flag ... if 1, checks for uniqueness after field changed
     137 ;
     138 ; FUNCTION RETURNS: value of field if field is OK, second piece is null
     139 ;                   If not good, 2nd piece = 1 : no data or ^ entered
     140 ;                                          = 2 : record not unique
     141 N DIR,DA,Y,X,IBNEW,IBINS,IBVAL
     142 S IBINS=+IB0,IBNEW="",IBVAL=$$EXPAND^IBTRE(355.96,IBFLD,$P(IB0,U,(IBFLD*100)))
     143 S DIR(0)="355.96,"_IBFLD
     144 S:IBVAL'="" DIR("B")=IBVAL
     145 D ^DIR K DIR
     146 I Y=""!$D(DTOUT)!$D(DUOUT) S IBNEW="^1" G EDITQ
     147 S IBNEW=$P(Y,U)
     148 I $G(IBCK1) D
     149 . N X1,X2,X3,X4,X5
     150 . S X1=$S(IBFLD'=.03:IBINS,1:IBNEW),X2=$S(IBFLD'=.01:$P(IB0,U),1:IBNEW),X3=$S(IBFLD'=.04:$P(IB0,U,4),1:IBNEW),X4=$S(IBFLD'=.05:$P(IB0,U,5),1:IBNEW),X5=$S(IBFLD'=.06:$P(IB0,U,6),1:IBNEW)
     151 . I $S(X1=""!(X2="")!(X3="")!(X4="")!(X5=""):1,$O(^IBA(355.96,"AUNIQ",X1,X2,X3,X4,X5,0)):$O(^(0))'=IBIEN,1:0) S IBNEW=IBNEW_"^2"
     152 ;
     153EDITQ Q IBNEW
     154 ;
     155ADDCU(IBINSZ,IBCU,IBFT,IBCT,IBPTYP) ;  Add a new care unit record to file 355.96
     156 ; Same parameter definitions as EDIT
     157 N DIC,DA,X,Y,DLAYGO
     158 S DIC(0)="L",DLAYGO=355.96,DIC="^IBA(355.96,",DIC("DR")=".03////"_IBINSZ_";.04////"_IBFT_";.05////"_IBCT_";.06////"_IBPTYP,X=IBCU
     159 D FILE^DICN
     160 Q Y
     161 ;

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP5.m

    r613 r623  
    1 IBCEP5  ;ALB/TMP - EDI UTILITIES for provider ID ;29-SEP-00
    2         ;;2.0;INTEGRATED BILLING;**137,232,320,348,349,377**;21-MAR-94;Build 23
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5 EN      ; -- main entry point for IBCE PRV MAINT
    6         N IBPRV,IBINS
    7 EN1     ; Entrypoint for non-VA provider ID maintenance hook
    8         N IBSLEV,DIR,Y,X,IBPRMPT,IBNVAFL,IBIF
    9         K IBFASTXT
    10         S IBIF="" I $G(IBPRV) S IBIF=$$GET1^DIQ(355.93,IBPRV,.02,"I")
    11         D FULL^VALM1
    12         S IBPRMPT=$S(IBIF=1:"LAB OR FACILITY",1:"PROVIDER")
    13         S DIR(0)="SA^1:"_IBPRMPT_"'S OWN IDS;2:"_IBPRMPT_" IDS FURNISHED BY AN INSURANCE COMPANY"
    14         S DIR("A")="SELECT SOURCE OF ID: ",DIR("B")=$P($P(DIR(0),":",2),";")
    15         W ! D ^DIR K DIR W !
    16         I Y'>0 Q
    17         S IBSLEV=+Y
    18         D EN^VALM("IBCE PRVPRV MAINT")
    19         Q
    20         ;
    21 HDR     ; -- header code
    22         N IBC,Z,IBIF
    23         S IBIF="" I $G(IBNPRV) S IBIF=$$GET1^DIQ(355.93,IBNPRV,.02,"I")
    24         K VALMHDR
    25         S IBC=1
    26         S IBPRMPT=$S(IBIF=1:"Lab or Facility",1:"Performing Provider")
    27         S Z="** "_$S($G(IBSLEV)=1:IBPRMPT_"'s Own IDs (No Specific Insurance Co)",1:IBPRMPT_" IDs from Insurance Co")_" **"
    28         S VALMHDR(IBC)=$J("",80-$L(Z)\2)_Z,IBC=IBC+1
    29         I $G(IBPRV),'+IBIF S VALMHDR(IBC)="PROVIDER   : "_$$EXPAND^IBTRE(355.9,.01,IBPRV)_$S(IBPRV["VA(200":" (VA PROVIDER)",1:" (NON-VA PROVIDER)"),IBC=IBC+1
    30         I $G(IBPRV),+IBIF S VALMHDR(IBC)="Provider: "_$$EXPAND^IBTRE(355.9,.01,IBPRV)_$S(IBIF=1:"(Non-VA Lab or Facility)",1:""),IBC=IBC+1
    31         I $G(IBINS) D
    32         . N PCF,PCDISP
    33         . S PCF=$P($G(^DIC(36,+IBINS,3)),"^",13)
    34         . S PCDISP=$S($G(IBSLEV)'=2!($G(IBPRV)'["VA(200,"):"",PCF="C":"(Child)",PCF="P":"(Parent)",1:"")
    35         . S VALMHDR(IBC)=$S(IBIF:"Insurance Co: ",1:"INSURANCE CO: ")_$P($G(^DIC(36,+IBINS,0)),U)_" "_PCDISP
    36         Q
    37         ;
    38 INIT    ; -- init variables and list array
    39         N IBFILE,DIR,DIC,Y,X,DTOUT,DUOUT,IBIF,AGAIN
    40         ;
    41         K ^TMP("IB_EDITED_IDS",$J)  ; This will be to keep track of ID's edited during this session
    42         S IBIF="" I $G(IBNPRV) S IBIF=$$GET1^DIQ(355.93,IBNPRV,.02,"I")
    43         ;
    44         ; Removing Care Unit under certain conditions
    45         ; This list is used for multiple purposes and not all have Care Units Associated with them
    46         ; Also, a different protocol menu is used with these
    47         ; IBNPRV is a non VA provider
    48         ; IBIF = 1 means this is a group or facility, not an individual.
    49         ;
    50         I $G(IBNPRV),$G(IBIF)=1 D
    51         . S VALM("TITLE")="Secondary Provider ID"
    52         . K VALMDDF("CAREUNIT")
    53         . I VALMCAP["Care Unit" S VALMCAP=$P(VALMCAP,"Care Unit")_"         "_$P(VALMCAP,"Care Unit",2)
    54         . K VALM("PROTOCOL")
    55         . S Y=$$FIND1^DIC(101,,,"IBCE PRVNVA LOF MAINT")
    56         . I Y S VALM("PROTOCOL")=+Y_";ORD(101,"
    57         ;
    58         I $G(IBPRV) S IBFILE="IBA(355.93,",IBPRV=+IBPRV_";"_IBFILE
    59         I '$G(IBPRV) D  G:$G(VALMQUIT) INITQ
    60         . S DIR(0)="SAO^V:VA PROVIDER;N:NON-VA PROVIDER",DIR("A")="(V)A or (N)on-VA provider: ",DIR("B")="V"
    61         . D ^DIR K DIR
    62         . I "NV"'[Y!(Y="") S VALMQUIT=1 Q
    63         . S IBFILE=$S(Y="V":"VA(200,",1:"IBA(355.93,")
    64         . S DIC=U_IBFILE,DIC(0)="AEMQ"_$S(IBFILE["355.93":"L",1:"")
    65         . S DIC("A")="Select "_$S(IBFILE["355.93":"NON-",1:"")_"V.A. PROVIDER NAME: "
    66         . S:IBFILE["355.93" DIC("DR")=".02////2;.03;.04"
    67         . F  D  I $G(IBPRV)!$G(VALMQUIT) K DIC Q
    68         .. D ^DIC
    69         .. I $D(DTOUT)!$D(DUOUT) S VALMQUIT=1 Q
    70         .. I Y'>0 W !,*7,"This is a required response. Enter '^' to exit" Q
    71         .. S IBPRV=+Y_";"_IBFILE
    72         ;
    73 AGAIN   I $G(IBSLEV)=2 D  G:$G(AGAIN) AGAIN G:$G(VALMQUIT) INITQ
    74         . S AGAIN=0
    75         . S DIR(0)="PA^DIC(36,:AEMQ",DIR("A")="Select INSURANCE CO: ",DIR("?",1)="Select an INSURANCE CO to display its provider ID's"
    76         . D ^DIR K DIR
    77         . I $D(DTOUT)!$D(DUOUT) S VALMQUIT=1 Q
    78         . S IBINS=$S(Y>0:+Y,1:"NO")
    79         . I $G(IBPRV)'["VA(200," Q    ; Only VA providers
    80         . I $P($G(^DIC(36,+IBINS,3)),"^",13)="C" D  S AGAIN=1 Q
    81         .. W !,*7,"This is a Child Insurance Company.  Editing IDs is not permitted."
    82         ;
    83         E  D
    84         . S IBINS="NO"
    85         D BLD
    86 INITQ   Q
    87         ;
    88 BLD     ;  Build initial display
    89         ; Assumes IBPRV = the variable ptr for prov id file (355.9)
    90         ;         IBINS = the ien of the ins co or if null, ALL is assumed
    91         ;         IBSLEV = 1 to display only provider default ids
    92         ;                = 2 to display all provider/insurance co ids
    93         N IB,IBLCT,IBCT,CT,PT,CU,INS,FT,Z,IBENT,IB1,IBIF
    94         ;
    95         S IBIF="" I $G(IBPRV)[355.93 S IBIF=$$GET1^DIQ(355.93,+IBPRV,.02,"I")
    96         ;
    97         K ^TMP("IBPRV_",$J),^TMP("IBPRV_SORT",$J)
    98         K Z0
    99         S (IBENT,IBCT,IBLCT)=0,INS="",IB1=1
    100         F  S INS=$S($G(IBINS):IBINS,IBSLEV=1:"*ALL*",1:$O(^IBA(355.9,"AUNIQ",IBPRV,INS))) Q:$S(INS="":1,$G(IBINS)!(IBSLEV=1):$D(CU),1:0)  S CU="",IB1=0 F  S CU=$O(^IBA(355.9,"AUNIQ",IBPRV,INS,CU)) Q:CU=""  D
    101         . S FT="" F  S FT=$O(^IBA(355.9,"AUNIQ",IBPRV,INS,CU,FT)) Q:FT=""  S CT="" F  S CT=$O(^IBA(355.9,"AUNIQ",IBPRV,INS,CU,FT,CT)) Q:CT=""  S PT=0 F  S PT=$O(^IBA(355.9,"AUNIQ",IBPRV,INS,CU,FT,CT,PT)) Q:'PT  D
    102         .. S Z=0 F  S Z=$O(^IBA(355.9,"AUNIQ",IBPRV,INS,CU,FT,CT,PT,Z)) Q:'Z  S IB=$G(^IBA(355.9,Z,0)) D
    103         ... S ^TMP("IBPRV_SORT",$J,$S(INS:$P($G(^DIC(36,+INS,0)),U)_" ",1:" ALL"),PT,FT,CT,CU,Z)=$P(IB,U,7)
    104         ;
    105         I IBSLEV=1,IBPRV["IBA(355.93",$P($G(^IBA(355.93,+IBPRV,0)),U,12)'="" S ^TMP("IBPRV_SORT",$J," ALL",+$$STLIC^IBCEP8(),0,0,"*N/A*",0)=$P(^IBA(355.93,+IBPRV,0),U,12)
    106         S INS="" F  S INS=$O(^TMP("IBPRV_SORT",$J,INS)) Q:INS=""  D
    107         . I '$G(IBINS),'IBIF D:IBLCT SET^VALM10(IBLCT+1," ",IBCT) S IBLCT=$S(IBLCT:IBLCT+2,1:1) D SET^VALM10(IBLCT,"INSURANCE CO: "_$S($E(INS)=" ":"ALL INSURANCE",1:INS),$S(IBCT:IBCT,1:1))
    108         . S PT=""
    109         . F  S PT=$O(^TMP("IBPRV_SORT",$J,INS,PT)) Q:PT=""  S FT="" F  S FT=$O(^TMP("IBPRV_SORT",$J,INS,PT,FT)) Q:FT=""  S CT="" F  S CT=$O(^TMP("IBPRV_SORT",$J,INS,PT,FT,CT)) Q:CT=""  D
    110         .. S CU="" F  S CU=$O(^TMP("IBPRV_SORT",$J,INS,PT,FT,CT,CU)) Q:CU=""  S Z="" F  S Z=$O(^TMP("IBPRV_SORT",$J,INS,PT,FT,CT,CU,Z)) Q:Z=""  S IB=$G(^(Z)) D
    111         ... S IBLCT=IBLCT+1,IBCT=IBCT+1
    112         ... S Z0=$E(IBCT_"     ",1,4)_" "_$E($$EXPAND^IBTRE(355.9,.06,PT)_$S(PT=$$STLIC^IBCEP8():"("_$P($G(^DIC(5,+$P($G(^IBA(355.93,+IBPRV,0)),U,7),0)),U,2)_")",1:"")_$J("",20),1,20)_"  "_$S(FT=1:"UB-04",FT=2:"1500 ",1:"BOTH ")
    113         ... S Z0=Z0_"  "_$E($S(CT=3:"RX",CT=1:"INPT",CT=2:"OUTPT",1:"INPT/OUTPT")_$J("",11),1,11)
    114         ... S Z0=Z0_"  "_$E($S(CU'="*N/A*":$P($G(^IBA(355.95,+$G(^IBA(355.96,CU,0)),0)),U),1:"")_$J("",15),1,15) I Z0["MEDICINE" X "*"
    115         ... D SET^VALM10(IBLCT,Z0_" "_IB,IBCT)
    116         ... S ^TMP("IBPRV_",$J,"ZIDX",IBCT)=$S(Z'=0:Z,1:"LIC^"_IBPRV)
    117         I IBSLEV=1,IBPRV["VA(200" D
    118         . N IBP
    119         . S IBP=+IBPRV
    120         . Q:'$$GETLIC^IBCEP5D(.IBP)
    121         . I IBCT S IBLCT=IBLCT+1 D SET^VALM10(IBLCT," ",IBCT)
    122         . S Z=0 F  S Z=$O(IBP(Z)) Q:'Z  D
    123         .. S IBLCT=IBLCT+1,IBCT=IBCT+1
    124         .. D SET^VALM10(IBLCT,$E(IBCT_"     ",1,4)_$E($P($G(^DIC(5,+Z,0)),U,2)_" STATE LICENSE #"_$J("",20),1,20)_$J("",39)_IBP(Z),IBCT)
    125         .. S ^TMP("IBPRV_",$J,"ZIDX",IBCT)="LIC^"_+IBPRV
    126         K ^TMP("IBPRV_SORT",$J)
    127         ;
    128         I IBLCT=0 D  G BLDQ ; No entries for ins co selected
    129         . D SET^VALM10(1," ")
    130         . D SET^VALM10(2,"  No ID's found for provider "_$S('$G(IBINS):"",1:"and selected insurance co"))
    131         . S IBLCT=2
    132         ;
    133 BLDQ    K VALMCNT,VALMBG
    134         S VALMCNT=IBLCT,VALMBG=1
    135         Q
    136         ;
    137 HELP    ; -- help code
    138         S X="?" D DISP^XQORM1 W !!
    139         Q
    140         ;
    141 EXIT    ; -- exit code
    142         D COPYPROV^IBCEP5A(IBINS)
    143         K IBPRV
    144         D CLEAN^VALM10
    145         K ^TMP("IBPRV_",$J),^TMP("IBPRV_SORT",$J),IBINS,IBALL
    146         Q
    147         ;
    148 EXPND   ; -- expand code
    149         Q
    150         ;
    151 SEL(IBDA,MANY)  ; Select from provider id list
    152         ; IBDA is passed by reference and IBDA(1) returned containing
    153         ;  ien's of the provider id records selected (file 355.9).
    154         ; If > 1 entry can be selected, MANY is set to 1
    155         N Z
    156         S IBDA=0
    157         D EN^VALM2($G(XQORNOD(0)),$S($G(MANY):"",1:"S"))
    158         S Z=0 F  S Z=$O(VALMY(Z)) Q:'Z  S IBDA=IBDA+1,IBDA(IBDA)=$G(^TMP("IBPRV_",$J,"ZIDX",Z))
    159         Q
    160         ;
     1IBCEP5 ;ALB/TMP - EDI UTILITIES for provider ID ;29-SEP-00
     2 ;;2.0;INTEGRATED BILLING;**137,232,320,348,349**;21-MAR-94;Build 46
     3 ;;Per VHA Directive 2004-038, this routine should not be modified.
     4 ;
     5EN ; -- main entry point for IBCE PRV MAINT
     6 N IBPRV,IBINS
     7EN1 ; Entrypoint for non-VA provider ID maintenance hook
     8 N IBSLEV,DIR,Y,X,IBPRMPT,IBNVAFL,IBIF
     9 K IBFASTXT
     10 S IBIF="" I $G(IBPRV) S IBIF=$$GET1^DIQ(355.93,IBPRV,.02,"I")
     11 D FULL^VALM1
     12 S IBPRMPT=$S(IBIF=1:"LAB OR FACILITY",1:"PROVIDER")
     13 S DIR(0)="SA^1:"_IBPRMPT_"'S OWN IDS;2:"_IBPRMPT_" IDS FURNISHED BY AN INSURANCE COMPANY"
     14 S DIR("A")="SELECT SOURCE OF ID: ",DIR("B")=$P($P(DIR(0),":",2),";")
     15 W ! D ^DIR K DIR W !
     16 I Y'>0 Q
     17 S IBSLEV=+Y
     18 D EN^VALM("IBCE PRVPRV MAINT")
     19 Q
     20 ;
     21HDR ; -- header code
     22 N IBC,Z,IBIF
     23 S IBIF="" I $G(IBNPRV) S IBIF=$$GET1^DIQ(355.93,IBNPRV,.02,"I")
     24 K VALMHDR
     25 S IBC=1
     26 S IBPRMPT=$S(IBIF=1:"Lab or Facility",1:"Performing Provider")
     27 S Z="** "_$S($G(IBSLEV)=1:IBPRMPT_"'s Own IDs (No Specific Insurance Co)",1:IBPRMPT_" IDs from Insurance Co")_" **"
     28 S VALMHDR(IBC)=$J("",80-$L(Z)\2)_Z,IBC=IBC+1
     29 I $G(IBPRV),'+IBIF S VALMHDR(IBC)="PROVIDER   : "_$$EXPAND^IBTRE(355.9,.01,IBPRV)_$S(IBPRV["VA(200":" (VA PROVIDER)",1:" (NON-VA PROVIDER)"),IBC=IBC+1
     30 I $G(IBPRV),+IBIF S VALMHDR(IBC)="Provider: "_$$EXPAND^IBTRE(355.9,.01,IBPRV)_$S(IBIF=1:"(Non-VA Lab or Facility)",1:""),IBC=IBC+1
     31 I $G(IBINS) D
     32 . N PCF,PCDISP
     33 . S PCF=$P($G(^DIC(36,+IBINS,3)),"^",13)
     34 . S PCDISP=$S($G(IBSLEV)'=2!($G(IBPRV)'["VA(200,"):"",PCF="C":"(Child)",PCF="P":"(Parent)",1:"")
     35 . S VALMHDR(IBC)=$S(IBIF:"Insurance Co: ",1:"INSURANCE CO: ")_$P($G(^DIC(36,+IBINS,0)),U)_" "_PCDISP
     36 Q
     37 ;
     38INIT ; -- init variables and list array
     39 N IBFILE,DIR,DIC,Y,X,DTOUT,DUOUT,IBIF,AGAIN
     40 ;
     41 K ^TMP("IB_EDITED_IDS",$J)  ; This will be to keep track of ID's edited during this session
     42 S IBIF="" I $G(IBNPRV) S IBIF=$$GET1^DIQ(355.93,IBNPRV,.02,"I")
     43 ;
     44 ; Removing Care Unit under certain conditions
     45 ; This list is used for multiple purposes and not all have Care Units Associated with them
     46 ; Also, a different protocol menu is used with these
     47 ; IBNPRV is a non VA provider
     48 ; IBIF = 1 means this is a group or facility, not an individual.
     49 ;
     50 I $G(IBNPRV),$G(IBIF)=1 D
     51 . S VALM("TITLE")="Secondary Provider ID"
     52 . K VALMDDF("CAREUNIT")
     53 . I VALMCAP["Care Unit" S VALMCAP=$P(VALMCAP,"Care Unit")_"         "_$P(VALMCAP,"Care Unit",2)
     54 . K VALM("PROTOCOL")
     55 . S Y=$$FIND1^DIC(101,,,"IBCE PRVNVA LOF MAINT")
     56 . I Y S VALM("PROTOCOL")=+Y_";ORD(101,"
     57 ;
     58 I $G(IBPRV) S IBFILE="IBA(355.93,",IBPRV=+IBPRV_";"_IBFILE
     59 I '$G(IBPRV) D  G:$G(VALMQUIT) INITQ
     60 . S DIR(0)="SAO^V:VA PROVIDER;N:NON-VA PROVIDER",DIR("A")="(V)A or (N)on-VA provider: ",DIR("B")="V"
     61 . D ^DIR K DIR
     62 . I "NV"'[Y!(Y="") S VALMQUIT=1 Q
     63 . S IBFILE=$S(Y="V":"VA(200,",1:"IBA(355.93,")
     64 . S DIC=U_IBFILE,DIC(0)="AEMQ"_$S(IBFILE["355.93":"L",1:"")
     65 . S DIC("A")="Select "_$S(IBFILE["355.93":"NON-",1:"")_"V.A. PROVIDER NAME: "
     66 . S:IBFILE["355.93" DIC("DR")=".02////2;.03;.04"
     67 . F  D  I $G(IBPRV)!$G(VALMQUIT) K DIC Q
     68 .. D ^DIC
     69 .. I $D(DTOUT)!$D(DUOUT) S VALMQUIT=1 Q
     70 .. I Y'>0 W !,*7,"This is a required response. Enter '^' to exit" Q
     71 .. S IBPRV=+Y_";"_IBFILE
     72 ;
     73AGAIN I $G(IBSLEV)=2 D  G:$G(AGAIN) AGAIN G:$G(VALMQUIT) INITQ
     74 . S AGAIN=0
     75 . S DIR(0)="PA^DIC(36,:AEMQ",DIR("A")="Select INSURANCE CO: ",DIR("?",1)="Select an INSURANCE CO to display its provider ID's"
     76 . D ^DIR K DIR
     77 . I $D(DTOUT)!$D(DUOUT) S VALMQUIT=1 Q
     78 . S IBINS=$S(Y>0:+Y,1:"NO")
     79 . I $G(IBPRV)'["VA(200," Q    ; Only VA providers
     80 . I $P($G(^DIC(36,+IBINS,3)),"^",13)="C" D  S AGAIN=1 Q
     81 .. W !,*7,"This is a Child Insurance Company.  Editing IDs is not permitted."
     82 ;
     83 E  D
     84 . S IBINS="NO"
     85 D BLD
     86INITQ Q
     87 ;
     88BLD ;  Build initial display
     89 ; Assumes IBPRV = the variable ptr for prov id file (355.9)
     90 ;         IBINS = the ien of the ins co or if null, ALL is assumed
     91 ;         IBSLEV = 1 to display only provider default ids
     92 ;                = 2 to display all provider/insurance co ids
     93 N IB,IBLCT,IBCT,CT,PT,CU,INS,FT,Z,IBENT,IB1,IBIF
     94 ;
     95 S IBIF="" I $G(IBPRV)[355.93 S IBIF=$$GET1^DIQ(355.93,+IBPRV,.02,"I")
     96 ;
     97 K ^TMP("IBPRV_",$J),^TMP("IBPRV_SORT",$J)
     98 K Z0
     99 S (IBENT,IBCT,IBLCT)=0,INS="",IB1=1
     100 F  S INS=$S($G(IBINS):IBINS,IBSLEV=1:"*ALL*",1:$O(^IBA(355.9,"AUNIQ",IBPRV,INS))) Q:$S(INS="":1,$G(IBINS)!(IBSLEV=1):$D(CU),1:0)  S CU="",IB1=0 F  S CU=$O(^IBA(355.9,"AUNIQ",IBPRV,INS,CU)) Q:CU=""  D
     101 . S FT="" F  S FT=$O(^IBA(355.9,"AUNIQ",IBPRV,INS,CU,FT)) Q:FT=""  S CT="" F  S CT=$O(^IBA(355.9,"AUNIQ",IBPRV,INS,CU,FT,CT)) Q:CT=""  S PT=0 F  S PT=$O(^IBA(355.9,"AUNIQ",IBPRV,INS,CU,FT,CT,PT)) Q:'PT  D
     102 .. S Z=0 F  S Z=$O(^IBA(355.9,"AUNIQ",IBPRV,INS,CU,FT,CT,PT,Z)) Q:'Z  S IB=$G(^IBA(355.9,Z,0)) D
     103 ... S ^TMP("IBPRV_SORT",$J,$S(INS:$P($G(^DIC(36,+INS,0)),U)_" ",1:" ALL"),PT,FT,CT,CU,Z)=$P(IB,U,7)
     104 ;
     105 I IBSLEV=1,IBPRV["IBA(355.93",$P($G(^IBA(355.93,+IBPRV,0)),U,12)'="" S ^TMP("IBPRV_SORT",$J," ALL",+$$STLIC^IBCEP8(),0,0,"*N/A*",0)=$P(^IBA(355.93,+IBPRV,0),U,12)
     106 S INS="" F  S INS=$O(^TMP("IBPRV_SORT",$J,INS)) Q:INS=""  D
     107 . I '$G(IBINS),'IBIF D:IBLCT SET^VALM10(IBLCT+1," ",IBCT) S IBLCT=$S(IBLCT:IBLCT+2,1:1) D SET^VALM10(IBLCT,"INSURANCE CO: "_$S($E(INS)=" ":"ALL INSURANCE",1:INS),$S(IBCT:IBCT,1:1))
     108 . S PT=""
     109 . F  S PT=$O(^TMP("IBPRV_SORT",$J,INS,PT)) Q:PT=""  S FT="" F  S FT=$O(^TMP("IBPRV_SORT",$J,INS,PT,FT)) Q:FT=""  S CT="" F  S CT=$O(^TMP("IBPRV_SORT",$J,INS,PT,FT,CT)) Q:CT=""  D
     110 .. S CU="" F  S CU=$O(^TMP("IBPRV_SORT",$J,INS,PT,FT,CT,CU)) Q:CU=""  S Z="" F  S Z=$O(^TMP("IBPRV_SORT",$J,INS,PT,FT,CT,CU,Z)) Q:Z=""  S IB=$G(^(Z)) D
     111 ... S IBLCT=IBLCT+1,IBCT=IBCT+1
     112 ... S Z0=$E(IBCT_"     ",1,4)_" "_$E($$EXPAND^IBTRE(355.9,.06,PT)_$S(PT=$$STLIC^IBCEP8():"("_$P($G(^DIC(5,+$P($G(^IBA(355.93,+IBPRV,0)),U,7),0)),U,2)_")",1:"")_$J("",20),1,20)_"  "_$S(FT=1:"UB-04",FT=2:"1500 ",1:"BOTH ")
     113 ... S Z0=Z0_"  "_$E($S(CT=3:"RX",CT=1:"INPT",CT=2:"OUTPT",1:"INPT/OUTPT")_$J("",11),1,11)
     114 ... S Z0=Z0_"  "_$E($S(CU'="*N/A*":$P($G(^IBA(355.95,+$G(^IBA(355.96,CU,0)),0)),U),1:"")_$J("",15),1,15) I Z0["MEDICINE" X "*"
     115 ... D SET^VALM10(IBLCT,Z0_" "_IB,IBCT)
     116 ... S ^TMP("IBPRV_",$J,"ZIDX",IBCT)=$S(Z'=0:Z,1:"LIC^"_IBPRV)
     117 I IBSLEV=1,IBPRV["VA(200" D
     118 . N IBP
     119 . S IBP=+IBPRV
     120 . Q:'$$GETLIC^IBCEP5D(.IBP)
     121 . I IBCT S IBLCT=IBLCT+1 D SET^VALM10(IBLCT," ",IBCT)
     122 . S Z=0 F  S Z=$O(IBP(Z)) Q:'Z  D
     123 .. S IBLCT=IBLCT+1,IBCT=IBCT+1
     124 .. D SET^VALM10(IBLCT,$E(IBCT_"     ",1,4)_$E($P($G(^DIC(5,+Z,0)),U,2)_" STATE LICENSE #"_$J("",20),1,20)_$J("",39)_IBP(Z),IBCT)
     125 .. S ^TMP("IBPRV_",$J,"ZIDX",IBCT)="LIC^"_+IBPRV
     126 K ^TMP("IBPRV_SORT",$J)
     127 ;
     128 I IBLCT=0 D  G BLDQ ; No entries for ins co selected
     129 . D SET^VALM10(1," ")
     130 . D SET^VALM10(2,"  No ID's found for provider "_$S('$G(IBINS):"",1:"and selected insurance co"))
     131 . S IBLCT=2
     132 ;
     133BLDQ K VALMCNT,VALMBG
     134 S VALMCNT=IBLCT,VALMBG=1
     135 Q
     136 ;
     137HELP ; -- help code
     138 S X="?" D DISP^XQORM1 W !!
     139 Q
     140 ;
     141EXIT ; -- exit code
     142 K IBFASTXT
     143 D COPYPROV^IBCEP5A(IBINS)
     144 K IBPRV
     145 D CLEAN^VALM10
     146 K ^TMP("IBPRV_",$J),^TMP("IBPRV_SORT",$J),IBINS,IBALL
     147 Q
     148 ;
     149EXPND ; -- expand code
     150 Q
     151 ;
     152SEL(IBDA,MANY) ; Select from provider id list
     153 ; IBDA is passed by reference and IBDA(1) returned containing
     154 ;  ien's of the provider id records selected (file 355.9).
     155 ; If > 1 entry can be selected, MANY is set to 1
     156 N Z
     157 S IBDA=0
     158 D EN^VALM2($G(XQORNOD(0)),$S($G(MANY):"",1:"S"))
     159 S Z=0 F  S Z=$O(VALMY(Z)) Q:'Z  S IBDA=IBDA+1,IBDA(IBDA)=$G(^TMP("IBPRV_",$J,"ZIDX",Z))
     160 Q
     161 ;

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP6.m

    r613 r623  
    1 IBCEP6  ;ALB/TMP - PROVIDER ID MAINT menu and INS CO EDIT hook ;11-02-00
    2         ;;2.0;INTEGRATED BILLING;**137,232,320,377**;21-MAR-94;Build 23
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5 EN      ; -- main entry point
    6         N IBRESP
    7         D FULL^VALM1
    8         F  Q:'$$MENU(.IBRESP)  D @IBRESP
    9 ENQ     ;
    10         Q
    11         ;
    12 EN1     ; Provider maintenance from the billing screen 8
    13         N DIR,X,Y,IBEDIT
    14         W !
    15         I '$D(^XUSEC("IB PROVIDER EDIT",DUZ)) S DIR(0)="EA",DIR("A")="Press ENTER to continue: ",DIR("A",1)="YOU LACK THE SECURITY KEY FOR THIS ACTION" D ^DIR K DIR Q
    16         D EN
    17         Q
    18         ;
    19 PO      ; provider's own IDs
    20         N IBPRV,IBINS
    21         N IBSLEV,DIR,Y,X,IBPRMPT,IBNVAFL,IBIF
    22         K IBFASTXT
    23         S IBIF=""
    24         S IBPRMPT="PROVIDER"
    25         D FULL^VALM1
    26         S IBSLEV=1
    27         D EN^VALM("IBCE PRVPRV MAINT")
    28 POX     ;
    29         Q
    30         ;
    31 PI      ; provider's IDs provided by an insurance company
    32         N IBPRV,IBINS
    33         N IBSLEV,DIR,Y,X,IBPRMPT,IBNVAFL,IBIF
    34         K IBFASTXT
    35         S IBIF=""
    36         S IBPRMPT="PROVIDER"
    37         D FULL^VALM1
    38         S IBSLEV=2
    39         D EN^VALM("IBCE PRVPRV MAINT")
    40 PIX     ;
    41         Q
    42         ;
    43 BI      ; Insurance company batch ID entry
    44         D EN^IBCEP9
    45 BIX     ;
    46         Q
    47         ;
    48 II      ; Insurance company IDs
    49         D EN^IBCEP0
    50 IIX     ;
    51         Q
    52         ;
    53 CP      ; Care Unit maintenance - performing providers
    54         N IBINS,IBALL,IB95
    55         N IBSLEV,DIR,Y
    56         K IBFASTXT
    57         D FULL^VALM1
    58         S IBSLEV=1
    59         D EN^VALM("IBCE PRVCARE UNIT MAINT")
    60 CPX     ;
    61         Q
    62         ;
    63 CB      ; Care Unit maintenance - billing provider
    64         N IBINS,IBALL,IB95
    65         N IBSLEV,DIR,Y
    66         K IBFASTXT
    67         D FULL^VALM1
    68         S IBSLEV=2
    69         D EN^VALM("IBCE 2ND PRVID CARE UNIT MAINT")
    70 CBX     ;
    71         Q
    72         ;
    73 NP      ; non-VA individual provider information
    74         N IBNVPMIF
    75         S IBNVPMIF="I"
    76         D EN^IBCEP8
    77 NPX     ;
    78         Q
    79         ;
    80 NF      ; non-VA facility provider information
    81         N IBNVPMIF
    82         S IBNVPMIF="F"
    83         D EN^IBCEP8
    84 NFX     ;
    85         Q
    86         ;
    87 MENU(IBSEL)     ; display main provider ID maintenance menu and receive response from user
    88         ; function value returns 0 if user exits from menu or "^" out
    89         ; function value returns 1 otherwise
    90         ; IBSEL is the internal value of the user's selection if any (pass by reference)
    91         N IBQ,DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT,C,Z
    92         N IORESET,IORVON,IORVOFF,IOUON,IOUOFF,IOINHI,IOINLOW,IOINORM
    93         S IBQ=1,IBSEL=""
    94         S X="IORESET;IORVON;IORVOFF;IOUON;IOUOFF;IOINHI;IOINLOW;IOINORM"
    95         D ENDR^%ZISS
    96         ;
    97         S $P(DIR(0),U,1)="SOA"
    98         S $P(Z,";",1)="PO:Provider Own IDs"
    99         S $P(Z,";",2)="PI:Provider Insurance IDs"
    100         S $P(Z,";",3)="BI:Batch ID Entry"
    101         S $P(Z,";",4)="II:Insurance Co IDs"
    102         S $P(Z,";",5)="CP:Care Units for Providers"
    103         S $P(Z,";",6)="CB:Care Units for Billing Provider"
    104         S $P(Z,";",7)="NP:Non-VA Provider"
    105         S $P(Z,";",8)="NF:Non-VA Facility"
    106         ;
    107         S $P(DIR(0),U,2)=Z
    108         ;
    109         S DIR("L",1)="                "_IOINHI_"Provider IDs"_IOINORM
    110         S DIR("L",2)="          "_$P($P(Z,";",1),":",1)_"  "_$P($P(Z,";",1),":",2)
    111         S DIR("L",3)="          "_$P($P(Z,";",2),":",1)_"  "_$P($P(Z,";",2),":",2)
    112         S DIR("L",4)=""
    113         S DIR("L",5)="                "_IOINHI_"Insurance IDs"_IOINORM
    114         S DIR("L",6)="          "_$P($P(Z,";",3),":",1)_"  "_$P($P(Z,";",3),":",2)
    115         S DIR("L",7)="          "_$P($P(Z,";",4),":",1)_"  "_$P($P(Z,";",4),":",2)
    116         S DIR("L",8)=""
    117         S DIR("L",9)="                "_IOINHI_"Care Units"_IOINORM
    118         S DIR("L",10)="          "_$P($P(Z,";",5),":",1)_"  "_$P($P(Z,";",5),":",2)
    119         S DIR("L",11)="          "_$P($P(Z,";",6),":",1)_"  "_$P($P(Z,";",6),":",2)
    120         S DIR("L",12)=""
    121         S DIR("L",13)="                "_IOINHI_"Non-VA Items"_IOINORM
    122         S DIR("L",14)="          "_$P($P(Z,";",7),":",1)_"  "_$P($P(Z,";",7),":",2)
    123         S DIR("L")="          "_$P($P(Z,";",8),":",1)_"  "_$P($P(Z,";",8),":",2)
    124         ;
    125         S DIR("?")="^D MENH^IBCEP6"
    126         S DIR("A")="    Select Provider ID Maintenance Option: "
    127         ;
    128         ; paint the screen and display menu first time in
    129         D MENH
    130         W !
    131         S C=0 F  S C=$O(DIR("L",C)) Q:'C  W !,DIR("L",C)
    132         W !,DIR("L"),!
    133         D ^DIR K DIR W !
    134         I $D(DIRUT) S IBQ=0 G MENUX
    135         S IBSEL=Y
    136         I IBSEL="" S IBQ=0
    137 MENUX   ;
    138         Q IBQ
    139         ;
    140 MENH    ; menu help
    141         W @IOF,!?4,"Provider ID Maintenance Main Menu"
    142         W !!?4,"Enter a code from the list."
    143 MENHX   ;
    144         Q
    145         ;
     1IBCEP6 ;ALB/TMP - PROVIDER ID MAINT menu and INS CO EDIT hook ;11-02-00
     2 ;;2.0;INTEGRATED BILLING;**137,232,320**;21-MAR-94
     3 ;
     4EN ; -- main entry point for IBCE PRV INS PARAMS
     5 D FULL^VALM1
     6 D EN^VALM("IBCE PRVMAINT")
     7ENQ Q
     8 ;
     9HDR ; -- header code
     10 K VALMHDR
     11 Q
     12 ;
     13INIT ; Initialization
     14 N IBLCT,IBCT,Z,Z0
     15 S (IBLCT,IBCT)=0,XQORM("B")="Select"
     16 K ^TMP("IBCE_PRVMAINT_MENU",$J)
     17 F Z=1:1:2 S Z0=$J("",10) D SET1(.IBLCT,Z0,1)
     18 S Z0=$J("",17)_"-- PROVIDER ID EDITS --" D SET1(.IBLCT,Z0,1),CNTRL^VALM10(IBLCT,18,23,IORVON,IORVOFF)
     19 S Z0=$J("",10)_"1 > PROVIDER SPECIFIC IDS" D SET1(.IBLCT,Z0,1)
     20 S Z0=$J("",14)_"o PROVIDER'S OWN IDS" D SET1(.IBLCT,Z0,1)
     21 S Z0=$J("",14)_"o PROVIDER IDS FURNISHED BY INSURANCE CO" D SET1(.IBLCT,Z0,1)
     22 S Z0=$J("",10)_"2 > INSURANCE CO IDS" D SET1(.IBLCT,Z0,2)
     23 ;S Z0=$J("",10)_"3 > FACILITY IDS" D SET1(.IBLCT,Z0,3)  ;WCJ removed
     24 S Z0=$J("",10)_"4 > CARE UNIT MAINTENANCE" D SET1(.IBLCT,Z0,4)
     25 S Z0=$J("",14)_"o Care Units for Performing Provider IDs" D SET1(.IBLCT,Z0,1)
     26 S Z0=$J("",14)_"o Care Units for Billing Provider Secondary IDs" D SET1(.IBLCT,Z0,1)
     27 S Z0=$J("",10)_"5 > INS CO BATCH ID ENTRY" D SET1(.IBLCT,Z0,5)
     28 F Z=1:1:2 S Z0=$J("",10) D SET1(.IBLCT,Z0,6)
     29 S Z0=$J("",14)_"-- NON/OTHER VA ENTITY EDITS --" D SET1(.IBLCT,Z0,6),CNTRL^VALM10(IBLCT,15,31,IORVON,IORVOFF)
     30 S Z0=$J("",10)_"6 > NON/OTHER VA PROVIDER ID INFORMATION" D SET1(.IBLCT,Z0,6)
     31 K VALMBG,VALMCNT
     32 S VALMBG=1,VALMCNT=IBLCT
     33 Q
     34 ;
     35SET1(IBLCT,Z0,IBCT) ;
     36 S IBLCT=IBLCT+1 D SET^VALM10(IBLCT,Z0,$G(IBCT))
     37 Q
     38 ;
     39EXPND ;
     40 Q
     41 ;
     42HELP ;
     43 Q
     44 ;
     45EXIT ;
     46 K ^TMP("IBCE_PRVMAINT_MENU",$J)
     47 D CLEAN^VALM10
     48 Q
     49 ;
     50SEL ;
     51 N Z,Z1,DIR
     52 D FULL^VALM1
     53 D EN^VALM2($G(XQORNOD(0)),"OS")
     54 S Z=+$O(VALMY(0))
     55 I Z,Z<6,'$D(^XUSEC("IB PROVIDER EDIT",DUZ)) S DIR(0)="EA",DIR("A",1)="YOU ARE NOT AUTHORIZED TO EDIT PROVIDER IDS",DIR("A")="Press ENTER to continue" W ! D ^DIR K DIR W ! G SELQ
     56 I Z=3 D  G SELQ
     57 . S DIR(0)="EA",DIR("A",1)="This Action is no longer available",DIR("A")="Press ENTER to continue"
     58 . D ^DIR K DIR
     59 I Z S Z1=$P($T(ACT+Z),U,2,3) I Z1'="" D @Z1
     60SELQ K VALMBCK,XQORM("B")
     61 S VALMBCK="R",XQORM("B")="Quit"
     62 Q
     63 ;
     64EN1 ; Provider maintenance from the billing screen 8
     65 N DIR,X,Y,IBEDIT
     66 ;S IBEDIT=1
     67 W !
     68 ;S DIR(0)="YA",DIR("B")="NO",DIR("A",1)="WANT TO ATTEMPT TO RESET ALL PROVIDER IDS TO THE CALCULATED",DIR("A")="DEFAULTS FOR THIS BILL?: " D ^DIR K DIR
     69 ;Q:$D(DTOUT)!$D(DUOUT)
     70 ;I Y=1 S IBEDIT=0 D RECALCA^IBCEP2A(IBIFN) W !
     71 ;
     72 I '$D(^XUSEC("IB PROVIDER EDIT",DUZ)) S DIR(0)="EA",DIR("A")="Press ENTER to continue: ",DIR("A",1)="YOU LACK THE SECURITY KEY FOR THIS ACTION" D ^DIR K DIR Q
     73 ;I 'IBEDIT D
     74 ;. S DIR(0)="YA",DIR("A")="WANT TO CONTINUE WITH GENERAL PROVIDER ID MAINTENANCE?: ",DIR("B")="NO" D ^DIR K DIR
     75 ;. I $D(DTOUT)!$D(DUOUT)!'Y Q
     76 ;. S IBEDIT=1
     77 D EN
     78 Q
     79 ;
     80ACT ; Actions available
     81 ;;PROVIDER LEVEL ID EDIT^EN^IBCEP5
     82 ;;INS CO LEVEL ID EDIT^EN^IBCEP0
     83 ;;
     84 ;;CARE UNIT EDIT^EN^IBCEP4
     85 ;;BATCH ID ENTRY BY INS CO^EN^IBCEP9
     86 ;;NON-VA PROVIDER EDIT^EN^IBCEP8
     87 ;
     88 ;
     89 ;
     90 ;;SITE LEVEL ID EDIT^EN^IBCEP7

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP8.m

    r613 r623  
    1 IBCEP8  ;ALB/TMP - Functions for NON-VA PROVIDER ;11-07-00
    2         ;;2.0;INTEGRATED BILLING;**51,137,232,288,320,343,374,377,391**;21-MAR-94;Build 39
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5 EN      ; -- main entry point
    6         N IBNPRV
    7         K IBFASTXT
    8         D FULL^VALM1
    9         D EN^VALM("IBCE PRVNVA MAINT")
    10         Q
    11         ;
    12 HDR     ; -- header code
    13         K VALMHDR
    14         Q
    15         ;
    16 INIT    ; Initialization
    17         N DIC,DA,X,Y,DLAYGO,IBIF,DIR,DTOUT,DUOUT
    18         K ^TMP("IBCE_PRVNVA_MAINT",$J)
    19         ;
    20         ; if coming in from main routine ^IBCEP6 this special variable IBNVPMIF is set already
    21         I $G(IBNVPMIF)'="" S IBIF=IBNVPMIF G INIT1
    22         ;
    23         S DIR("A")="(I)NDIVIDUAL OR (F)ACILITY?: ",DIR(0)="SA^I:INDIVIDUAL;F:FACILITY" D ^DIR K DIR
    24         I $D(DUOUT)!$D(DTOUT) S VALMQUIT=1 G INITQ
    25         S IBIF=Y
    26         ;
    27 INIT1   ;
    28         ;
    29         I IBIF="F" D
    30         . S VALM("TITLE")="Non-VA Lab or Facility Info"
    31         . K VALM("PROTOCOL")
    32         . S Y=$$FIND1^DIC(101,,,"IBCE PRVNVA NONIND MAINT")
    33         . I Y S VALM("PROTOCOL")=+Y_";ORD(101,"
    34         ;
    35         S DIC="^IBA(355.93,",DIC("DR")=".02///"_$S(IBIF'="F":2,1:1)
    36         S DIC("S")="I $P(^(0),U,2)="_$S(IBIF'="F":2,1:1)
    37         S DLAYGO=355.93,DIC(0)="AELMQ",DIC("A")="Select a NON"_$S(IBIF="I":"-",1:"/OTHER ")_"VA PROVIDER: "
    38         D ^DIC K DIC,DLAYGO
    39         I Y'>0 S VALMQUIT=1 G INITQ
    40         S IBNPRV=+Y
    41         D BLD^IBCEP8B(IBNPRV)
    42 INITQ   Q
    43         ;
    44 EXPND   ;
    45         Q
    46         ;
    47 HELP    ;
    48         Q
    49         ;
    50 EXIT    ;
    51         K ^TMP("IBCE_PRVNVA_MAINT",$J)
    52         D CLEAN^VALM10
    53         K IBFASTXT
    54         Q
    55         ;
    56 EDIT1(IBNPRV,IBNOLM)    ; Edit non-VA provider/facility demographics
    57         ; IBNPRV = ien of entry in file 355.93
    58         ; IBNOLM = 1 if not called from list manager
    59         ;
    60         N DA,X,Y,DIE,DR,IBP
    61         I '$G(IBNOLM) D FULL^VALM1
    62         I IBNPRV D
    63         . I '$G(IBNOLM) D CLEAR^VALM1
    64         . S DIE="^IBA(355.93,",DA=IBNPRV,IBP=($P($G(^IBA(355.93,IBNPRV,0)),U,2)=2)
    65         . ; PRXM/KJH - Added NPI and Taxonomy to the list of fields to be edited. Put a "NO^" around the Taxonomy multiple (#42) since some of the sub-field entries are 'required'.
    66         . S DR=".01;"_$S(IBP:".03;.04",1:".05;.1;.06;.07;.08;.13///24;W !,""ID Qualifier: 24 - EMPLOYER'S IDENTIFICATION #"";.09Lab or Facility Primary ID;.11;.15")_";D PRENPI^IBCEP81(IBNPRV);D EN^IBCEP82(IBNPRV);S DIE(""NO^"")="""";42;K DIE(""NO^"")"
    67         . D ^DIE
    68         . Q:$G(IBNOLM)
    69         . D BLD^IBCEP8B(IBNPRV)
    70         I '$G(IBNOLM) K VALMBCK S VALMBCK="R"
    71         Q
    72         ;
    73 EDITID(IBNPRV,IBSLEV)   ; Link from this list template to maintain provider-specific ids
    74         ; This entry point is called by 4 action protocols.
    75         ; IBNPRV = ien of entry in file 355.93 (can be either an individual or a facility) (required)
    76         ; IBSLEV = 1 for facility/provider own ID's
    77         ; IBSLEV = 2 for facility/provider ID's furnished by an insurance company
    78         ;
    79         Q:'$G(IBNPRV)
    80         Q:'$G(IBSLEV)
    81         N IBPRV,IBIF
    82         D FULL^VALM1    ; set full scrolling region
    83         D CLEAR^VALM1   ; clear screen
    84         S IBPRV=IBNPRV
    85         ;
    86         K IBFASTXT
    87         S IBIF=$$GET1^DIQ(355.93,IBPRV,.02,"I")    ; 1=facility/group      2=individual
    88         D EN^VALM("IBCE PRVPRV MAINT")
    89         ;
    90         K VALMQUIT
    91         S VALMBCK=$S($G(IBFASTXT)'="":"Q",1:"R")
    92         Q
    93         ;
    94 NVAFAC  ; Enter/edit Non-VA facility information
    95         ; This entry point is called by the menu system for option IBCE PRVNVA FAC EDIT
    96         N X,Y,DA,DIC,IBNPRV,DLAYGO
    97         S DIC="^IBA(355.93,",DIC("S")="I $P(^(0),U,2)=1",DIC("DR")=".02///1"
    98         S DLAYGO=355.93,DIC(0)="AELMQ",DIC("A")="Select a NON/Other VA FACILITY: "
    99         D ^DIC K DIC,DLAYGO
    100         I Y'>0 S VALMQUIT=1 G NVAFACQ
    101         S IBNPRV=+Y
    102         D EDIT1(IBNPRV,1)
    103         ;
    104 NVAFACQ Q
    105         ;
    106 GETFAC(IB,IBFILE,IBELE,IBSFD)   ; Returns facility name,address lines or city-state-zip
    107         ; IB = ien of entry in file
    108         ; IBFILE = 0 for retrieval from file 4, 1 for retrieval from file 355.93
    109         ; If IBELE=0, returns name
    110         ;         =1, returns address line 1
    111         ;         =2, returns address line 2
    112         ;         =3, returns city, state zip
    113         ;         = "3C", returns city  = "3S", state    = "3Z", zip
    114         ; IBSFD (optional) = Output formatter segment name if the output needs
    115         ;       to be screened thru the VAMCFD^IBCEF75 procedure for the flag
    116         ;       in the insurance company file
    117         ;
    118         N Z,IBX,IBZ
    119         S IBX=""
    120         ;
    121         I $G(IBSFD)="SUB" D VAMCFD^IBCEF75(+$G(IBXIEN),.IBZ) I $D(IBZ),'$G(IBZ("C",1)) G GETFACX
    122         ;
    123         S Z=$S('IBFILE:$G(^DIC(4,+IB,1)),1:$G(^IBA(355.93,+IB,0)))
    124         I +IBELE=0 S IBX=$S('IBFILE:$P($G(^DIC(4,+IB,0)),U),1:$P($G(^IBA(355.93,+IB,0)),U))
    125         I IBELE=1!(IBELE=12) S IBX=$S('IBFILE:$P(Z,U),1:$P(Z,U,5))
    126         I IBELE=2!(IBELE=12) S IBX=$S(IBELE=12:IBX_" ",1:"")_$S('IBFILE:$P(Z,U,2),1:$P(Z,U,10))
    127         ;
    128         I +IBELE=3,'IBFILE D
    129         . S:IBELE=3!(IBELE["C") IBX=$P(Z,U,3) Q:IBELE["C"
    130         . S:IBELE=3 IBX=IBX_$S(IBX'="":", ",1:"") S:IBELE=3!(IBELE["S") IBX=IBX_$$STATE^IBCEFG1($P($G(^DIC(4,+IB,0)),U,2)) Q:IBELE["S"
    131         . S:IBELE=3 IBX=IBX_" " S:IBELE=3!(IBELE["Z") IBX=IBX_$P(Z,U,4)
    132         . Q
    133         ;
    134         I +IBELE=3,IBFILE D
    135         . S:IBELE=3!(IBELE["C") IBX=$P(Z,U,6) Q:IBELE["C"
    136         . S:IBELE=3 IBX=IBX_$S(IBX'="":", ",1:"") S:IBELE=3!(IBELE["S") IBX=IBX_$$STATE^IBCEFG1($P(Z,U,7))
    137         . S:IBELE=3 IBX=IBX_" " S:IBELE=3!(IBELE["Z") IBX=IBX_$P(Z,U,8)
    138         . Q
    139 GETFACX ;
    140         Q IBX
    141         ;
    142 ALLID(IBPRV,IBPTYP,IBZ) ; Returns array IBZ for all ids for provider IBPRV
    143         ; for all provider id types or for id type in IBPTYP
    144         ; IBPRV = vp ien of provider
    145         ; IBPTYP = ien of provider id type to return or "" for all
    146         ; IBZ = array returned with internal data:
    147         ;  IBZ(file 355.9 ien)=ID type^ID#^ins co^form type^bill care type^care un^X12 code for id type
    148         N Z,Z0
    149         K IBZ
    150         G:'$G(IBPRV) ALLIDQ
    151         S IBPTYP=$G(IBPTYP)
    152         S Z=0 F  S Z=$O(^IBA(355.9,"B",IBPRV,Z)) Q:'Z  S Z0=$G(^IBA(355.9,Z,0)) D
    153         . I $S(IBPTYP="":1,1:($P(Z0,U,6)=IBPTYP)) S IBZ(Z)=($P(Z0,U,6)_U_$P(Z0,U,7)_U_$P(Z0,U,2)_U_$P(Z0,U,4)_U_$P(Z0,U,5)_U_$P(Z0,U,3))_U_$P($G(^IBE(355.97,+$P(Z0,U,6),0)),U,3)
    154         ;
    155 ALLIDQ  Q
    156         ;
    157 CLIA()  ; Returns ien of CLIA # provider id type
    158         N Z,IBZ
    159         S (IBZ,Z)=0 F  S Z=$O(^IBE(355.97,Z)) Q:'Z  I $P($G(^(Z,0)),U,3)="X4",$P(^(0),U)["CLIA" S IBZ=Z Q
    160         Q IBZ
    161         ;
    162 STLIC() ; Returns ien of STLIC# provider id type
    163         N Z,IBZ
    164         S (IBZ,Z)=0 F  S Z=$O(^IBE(355.97,Z)) Q:'Z  I $P($G(^(Z,1)),U,3) S IBZ=Z Q
    165         Q IBZ
    166         ;
    167 TAXID() ; Returns ien of Fed tax id provider id type
    168         N Z,IBZ
    169         S (IBZ,Z)=0 F  S Z=$O(^IBE(355.97,Z)) Q:'Z  I $P($G(^(Z,1)),U,4) S IBZ=Z Q
    170         Q IBZ
    171         ;
    172 CLIANVA(IBIFN)  ; Returns CLIA # for a non-VA facility on bill ien IBIFN
    173         N IBCLIA,IBZ,IBNVA,Z
    174         S IBCLIA="",IBZ=$$CLIA()
    175         I IBZ D
    176         . S IBNVA=$P($G(^DGCR(399,IBIFN,"U2")),U,10) Q:'IBNVA
    177         . S IBCLIA=$$IDFIND^IBCEP2(IBIFN,IBZ,IBNVA_";IBA(355.93,","",1)
    178         Q IBCLIA
    179         ;
    180 VALFAC(X)       ; Function returns 1 if format is valid for X12 facility name
    181         ; Alpha/numeric/certain punctuation valid.  Must start with an Alpha
    182         N OK,VAL
    183         S OK=1
    184         S VAL("A")="",VAL("N")="",VAL=",.- "
    185         I $E(X)'?1A!'$$VALFMT(X,.VAL) S OK=0
    186         Q OK
    187         ;
    188 VALFMT(X,VAL)   ; Returns 1 if format of X is valid, 0 if not
    189         ; X = data to be examined
    190         ; VAL = a 'string' of valid characters AND/OR (passed by reference)
    191         ;    if VAL("A") defined ==> Alpha
    192         ;    if VAL("A") defined ==> Numeric valid
    193         ;    if VAL("A") defined ==> Punctuation valid
    194         ;   any other character included in the string is checked individually
    195         N Z
    196         I $D(VAL("A")) D
    197         . N Z0
    198         . F Z=1:1:$L(X) I $E(X,Z)?1A S Z0(Z)=""
    199         . S Z0="" F  S Z0=$O(Z0(Z0),-1) Q:'Z0  S $E(X,Z0)=""
    200         I $D(VAL("N")) D
    201         . N Z0
    202         . F Z=1:1:$L(X) I $E(X,Z)?1N S Z0(Z)=""
    203         . S Z0="" F  S Z0=$O(Z0(Z0),-1) Q:'Z0  S $E(X,Z0)=""
    204         I $D(VAL("P")) D
    205         . N Z0
    206         . F Z=1:1:$L(X) I $E(X,Z)?1P S Z0(Z)=""
    207         . S Z0="" F  S Z0=$O(Z0(Z0),-1) Q:'Z0  S $E(X,Z0)=""
    208         I $G(VAL)'="" S X=$TR(X,VAL,"")
    209         Q (X="")
    210         ;
    211 PS(IBXSAVE)     ; Returns 1 if IBXSAVE("PSVC") indicates the svc was non-lab
    212         ;
    213         Q $S($G(IBXSAVE("PSVC"))="":0,1:"13"[IBXSAVE("PSVC"))
    214         ;
    215         ; Pass in the Internal Entry number to File 355.93
    216         ; Return the Primary ID and Qualifier (ID Type) from 355.9
    217 PRIMID(IEN35593)        ; Return External Primary ID and ID Quailier
    218         N INDXVAL,LIST,MSG,IDCODE
    219         S INDXVAL=IEN35593_";IBA(355.93,"
    220         N SCREEN S SCREEN="I $P(^(0),U,8)"
    221         D FIND^DIC(355.9,,"@;.06EI;.07","Q",INDXVAL,,,SCREEN,,"LIST","MSG")
    222         I '+$G(LIST("DILIST",0)) Q ""   ; No Primary ID
    223         I +$G(LIST("DILIST",0))>1 Q "***ERROR***^***ERROR***"  ; Bad.  More than one.
    224         ; Found just one
    225         S IDCODE=$$GET1^DIQ(355.97,LIST("DILIST","ID",1,.06,"I"),.03)
    226         Q $G(LIST("DILIST","ID",1,.07))_U_IDCODE_" - "_$G(LIST("DILIST","ID",1,.06,"E"))
     1IBCEP8 ;ALB/TMP - Functions for NON-VA PROVIDER ;11-07-00
     2 ;;2.0;INTEGRATED BILLING;**51,137,232,288,320,343,374**;21-MAR-94;Build 16
     3 ;
     4EN ; -- main entry point
     5 N IBNPRV
     6 K IBFASTXT
     7 D FULL^VALM1
     8 D EN^VALM("IBCE PRVNVA MAINT")
     9 Q
     10 ;
     11HDR ; -- header code
     12 K VALMHDR
     13 Q
     14 ;
     15INIT ; Initialization
     16 N DIC,DA,X,Y,DLAYGO,IBIF,DIR,DTOUT,DUOUT
     17 K ^TMP("IBCE_PRVNVA_MAINT",$J)
     18 S DIR("A")="(I)NDIVIDUAL OR (F)ACILITY?: ",DIR(0)="SA^I:INDIVIDUAL;F:FACILITY" D ^DIR K DIR
     19 I $D(DUOUT)!$D(DTOUT) S VALMQUIT=1 G INITQ
     20 S IBIF=Y
     21 ;
     22 I IBIF="F" D
     23 . S VALM("TITLE")="Non-VA Lab or Facility Info"
     24 . K VALM("PROTOCOL")
     25 . S Y=$$FIND1^DIC(101,,,"IBCE PRVNVA NONIND MAINT")
     26 . I Y S VALM("PROTOCOL")=+Y_";ORD(101,"
     27 ;
     28 S DIC="^IBA(355.93,",DIC("DR")=".02////"_$S(IBIF'="F":2,1:1)
     29 S DIC("S")="I $P(^(0),U,2)="_$S(IBIF'="F":2,1:1)
     30 S DLAYGO=355.93,DIC(0)="AELMQ",DIC("A")="Select a NON"_$S(IBIF="I":"-",1:"/OTHER ")_"VA PROVIDER: "
     31 D ^DIC K DIC,DLAYGO
     32 I Y'>0 S VALMQUIT=1 G INITQ
     33 S IBNPRV=+Y
     34 D BLD
     35INITQ Q
     36 ;
     37BLD ; Build/Rebuild display
     38 N IBLCT,IBCT,IBLST,IBPRI,IBIEN,Z,Z1,Z2
     39 K @VALMAR
     40 S (IBLCT,IBCT)=0,Z=$G(^IBA(355.93,IBNPRV,0))
     41 S IBCT=IBCT+1
     42 S Z1=$J("Name: ",15)_$P(Z,U) D SET1(.IBLCT,Z1,IBCT)
     43 I $P(Z,U,2)=2 D
     44 . S IBCT=IBCT+1
     45 . S Z1=$J("Type: ",15)_$S($P(Z,U,2)=2:"INDIVIDUAL PROVIDER",1:"OUTSIDE OR OTHER VA FACILITY") D SET1(.IBLCT,Z1,IBCT)
     46 . S IBCT=IBCT+1
     47 . S Z1=$J("Credentials: ",15)_$P(Z,U,3) D SET1(.IBLCT,Z1,IBCT)
     48 . S IBCT=IBCT+1
     49 . S Z1=$J("Specialty: ",15)_$P(Z,U,4) D SET1(.IBLCT,Z1,IBCT)
     50 . S IBCT=IBCT+1
     51 . S Z1=$J("NPI: ",15)_$$NPIGET^IBCEP81(IBNPRV) D SET1(.IBLCT,Z1,IBCT)
     52 . S IBCT=IBCT+1
     53 . S IBPRI=$$TAXGET^IBCEP81(IBNPRV,.IBLST)
     54 . S Z1=$J("Taxonomy Code: ",15)_$P(IBPRI,U)
     55 . I $D(IBLST) S Z1=Z1_" ("_$S($P(IBLST(IBLST),U,3)=1:"Primary",1:"Secondary")_")"
     56 . D SET1(.IBLCT,Z1,IBCT)
     57 . S IBIEN=""
     58 . F  S IBIEN=$O(IBLST(IBIEN)) Q:IBIEN=""  D
     59 .. I IBIEN=IBLST Q
     60 .. S IBCT=IBCT+1
     61 .. S Z1=$J("",15)_$P(IBLST(IBIEN),U)_" ("_$S($P(IBLST(IBIEN),U,3)=1:"Primary",1:"Secondary")_")"
     62 .. D SET1(.IBLCT,Z1,IBCT)
     63 E  D
     64 . S IBCT=IBCT+1
     65 . S Z1=$J("Address: ",15)_$P(Z,U,5) D SET1(.IBLCT,Z1,IBCT)
     66 . I $P(Z,U,10) D
     67 .. S IBCT=IBCT+1
     68 .. S Z1=$J("",15)_$P(Z,U,10)
     69 . S IBCT=IBCT+1
     70 . S Z1=$J("",15)_$P(Z,U,6)_$S($P(Z,U,6)'="":", ",1:"")_$S($P(Z,U,7):$$EXTERNAL^DILFD(355.93,.07,"",$P(Z,U,7))_"  ",1:"")_$P(Z,U,8)
     71 . D SET1(.IBLCT,Z1,IBCT)
     72 . S IBCT=IBCT+1
     73 . S Z1=" " D SET1(.IBLCT,Z1,IBCT)
     74 . S IBCT=IBCT+1
     75 . S Z1=$J("Type of Facility: ",30)_$$EXTERNAL^DILFD(355.93,.11,,$P(Z,U,11))
     76 . D SET1(.IBLCT,Z1,IBCT)
     77 . S IBCT=IBCT+1
     78 . S Z1=$J("Primary ID: ",30)_$P(Z,U,9)
     79 . D SET1(.IBLCT,Z1,IBCT)
     80 . S IBCT=IBCT+1
     81 . S Z1=$J("ID Qualifier: ",30)_$$GET1^DIQ(355.97,$P(Z,U,13),.03) I $P(Z,U,13)]"" S Z1=Z1_" - "_$$GET1^DIQ(355.97,$P(Z,U,13),.01)
     82 . D SET1(.IBLCT,Z1,IBCT)
     83 . S IBCT=IBCT+1
     84 . S Z1=$J("Mammography Certification #: ",30)_$P(Z,U,15)
     85 . D SET1(.IBLCT,Z1,IBCT)
     86 . S IBCT=IBCT+1
     87 . S Z1=$J("NPI: ",30)_$$NPIGET^IBCEP81(IBNPRV) D SET1(.IBLCT,Z1,IBCT)
     88 . S IBCT=IBCT+1
     89 . S IBPRI=$$TAXGET^IBCEP81(IBNPRV,.IBLST)
     90 . S Z1=$J("Taxonomy Code: ",30)_$P(IBPRI,U)
     91 . I $D(IBLST) S Z1=Z1_" ("_$S($P(IBLST(IBLST),U,3)=1:"Primary",1:"Secondary")_")"
     92 . D SET1(.IBLCT,Z1,IBCT)
     93 . S IBIEN=""
     94 . F  S IBIEN=$O(IBLST(IBIEN)) Q:IBIEN=""  D
     95 .. I IBIEN=IBLST Q
     96 .. S IBCT=IBCT+1
     97 .. S Z1=$J("",30)_$P(IBLST(IBIEN),U)_" ("_$S($P(IBLST(IBIEN),U,3)=1:"Primary",1:"Secondary")_")"
     98 .. D SET1(.IBLCT,Z1,IBCT)
     99 K VALMBG,VALMCNT
     100 S VALMBG=1,VALMCNT=IBLCT
     101 Q
     102 ;
     103SET1(IBLCT,TEXT,IBCT) ;
     104 S IBLCT=IBLCT+1 D SET^VALM10(IBLCT,TEXT,$G(IBCT))
     105 Q
     106EXPND ;
     107 Q
     108 ;
     109HELP ;
     110 Q
     111 ;
     112EXIT ;
     113 K ^TMP("IBCE_PRVNVA_MAINT",$J)
     114 D CLEAN^VALM10
     115 K IBFASTXT
     116 Q
     117 ;
     118EDIT1(IBNPRV,IBNOLM) ; Edit non-VA provider/facility demographics
     119 ; IBNPRV = ien of entry in file 355.93
     120 ; IBNOLM = 1 if not called from list manager
     121 ;
     122 N DA,X,Y,DIE,DR,IBP
     123 I '$G(IBNOLM) D FULL^VALM1
     124 I IBNPRV D
     125 . I '$G(IBNOLM) D CLEAR^VALM1
     126 . S DIE="^IBA(355.93,",DA=IBNPRV,IBP=($P($G(^IBA(355.93,IBNPRV,0)),U,2)=2)
     127 . ; PRXM/KJH - Added NPI and Taxonomy to the list of fields to be edited. Put a "NO^" around the Taxonomy multiple (#42) since some of the sub-field entries are 'required'.
     128 . S DR=".01;"_$S(IBP:".03;.04",1:".05;.1;.06;.07;.08;.13///24;W !,""ID Qualifier: 24 - EMPLOYER'S IDENTIFICATION #"";.09Lab or Facility Primary ID;.11;.15")_";D EN^IBCEP82;S DIE(""NO^"")="""";42;K DIE(""NO^"")"
     129 . D ^DIE
     130 . Q:$G(IBNOLM)
     131 . D BLD
     132 I '$G(IBNOLM) K VALMBCK S VALMBCK="R"
     133 Q
     134 ;
     135EDITID(IBNPRV) ; Link from this list template to maintain provider-specific ids
     136 ; IBNPRV = ien of entry in file 355.93
     137 N IBPRV
     138 D FULL^VALM1
     139 D CLEAR^VALM1
     140 S IBPRV=IBNPRV
     141 D EN1^IBCEP5
     142 K VALMQUIT
     143 S VALMBCK="R"
     144 Q
     145 ;
     146NVAFAC ; Enter/edit Non-VA facility information
     147 N X,Y,DA,DIC,IBNPRV,DLAYGO
     148 S DIC="^IBA(355.93,",DIC("S")="I $P(^(0),U,2)=1",DIC("DR")=".02////1"
     149 S DLAYGO=355.93,DIC(0)="AELMQ",DIC("A")="Select a NON/Other VA FACILITY: "
     150 D ^DIC K DIC,DLAYGO
     151 I Y'>0 S VALMQUIT=1 G NVAFACQ
     152 S IBNPRV=+Y
     153 D EDIT1(IBNPRV,1)
     154 ;
     155NVAFACQ Q
     156 ;
     157GETFAC(IB,IBFILE,IBELE,IBSFD) ; Returns facility name,address lines or city-state-zip
     158 ; IB = ien of entry in file
     159 ; IBFILE = 0 for retrieval from file 4, 1 for retrieval from file 355.93
     160 ; If IBELE=0, returns name
     161 ;         =1, returns address line 1
     162 ;         =2, returns address line 2
     163 ;         =3, returns city, state zip
     164 ;         = "3C", returns city  = "3S", state    = "3Z", zip
     165 ; IBSFD (optional) = Output formatter segment name if the output needs
     166 ;       to be screened thru the VAMCFD^IBCEF75 procedure for the flag
     167 ;       in the insurance company file
     168 ;
     169 N Z,IBX,IBZ
     170 S IBX=""
     171 ;
     172 I $G(IBSFD)="SUB" D VAMCFD^IBCEF75(+$G(IBXIEN),.IBZ) I $D(IBZ),'$G(IBZ("C",1)) G GETFACX
     173 ;
     174 S Z=$S('IBFILE:$G(^DIC(4,+IB,1)),1:$G(^IBA(355.93,+IB,0)))
     175 I +IBELE=0 S IBX=$S('IBFILE:$P($G(^DIC(4,+IB,0)),U),1:$P($G(^IBA(355.93,+IB,0)),U))
     176 I IBELE=1!(IBELE=12) S IBX=$S('IBFILE:$P(Z,U),1:$P(Z,U,5))
     177 I IBELE=2!(IBELE=12) S IBX=$S(IBELE=12:IBX_" ",1:"")_$S('IBFILE:$P(Z,U,2),1:$P(Z,U,10))
     178 ;
     179 I +IBELE=3,'IBFILE D
     180 . S:IBELE=3!(IBELE["C") IBX=$P(Z,U,3) Q:IBELE["C"
     181 . S:IBELE=3 IBX=IBX_$S(IBX'="":", ",1:"") S:IBELE=3!(IBELE["S") IBX=IBX_$$STATE^IBCEFG1($P($G(^DIC(4,+IB,0)),U,2)) Q:IBELE["S"
     182 . S:IBELE=3 IBX=IBX_" " S:IBELE=3!(IBELE["Z") IBX=IBX_$P(Z,U,4)
     183 . Q
     184 ;
     185 I +IBELE=3,IBFILE D
     186 . S:IBELE=3!(IBELE["C") IBX=$P(Z,U,6) Q:IBELE["C"
     187 . S:IBELE=3 IBX=IBX_$S(IBX'="":", ",1:"") S:IBELE=3!(IBELE["S") IBX=IBX_$$STATE^IBCEFG1($P(Z,U,7))
     188 . S:IBELE=3 IBX=IBX_" " S:IBELE=3!(IBELE["Z") IBX=IBX_$P(Z,U,8)
     189 . Q
     190GETFACX ;
     191 Q IBX
     192 ;
     193ALLID(IBPRV,IBPTYP,IBZ) ; Returns array IBZ for all ids for provider IBPRV
     194 ; for all provider id types or for id type in IBPTYP
     195 ; IBPRV = vp ien of provider
     196 ; IBPTYP = ien of provider id type to return or "" for all
     197 ; IBZ = array returned with internal data:
     198 ;  IBZ(file 355.9 ien)=ID type^ID#^ins co^form type^bill care type^care un^X12 code for id type
     199 N Z,Z0
     200 K IBZ
     201 G:'$G(IBPRV) ALLIDQ
     202 S IBPTYP=$G(IBPTYP)
     203 S Z=0 F  S Z=$O(^IBA(355.9,"B",IBPRV,Z)) Q:'Z  S Z0=$G(^IBA(355.9,Z,0)) D
     204 . I $S(IBPTYP="":1,1:($P(Z0,U,6)=IBPTYP)) S IBZ(Z)=($P(Z0,U,6)_U_$P(Z0,U,7)_U_$P(Z0,U,2)_U_$P(Z0,U,4)_U_$P(Z0,U,5)_U_$P(Z0,U,3))_U_$P($G(^IBE(355.97,+$P(Z0,U,6),0)),U,3)
     205 ;
     206ALLIDQ Q
     207 ;
     208CLIA() ; Returns ien of CLIA # provider id type
     209 N Z,IBZ
     210 S (IBZ,Z)=0 F  S Z=$O(^IBE(355.97,Z)) Q:'Z  I $P($G(^(Z,0)),U,3)="X4",$P(^(0),U)["CLIA" S IBZ=Z Q
     211 Q IBZ
     212 ;
     213STLIC() ; Returns ien of STLIC# provider id type
     214 N Z,IBZ
     215 S (IBZ,Z)=0 F  S Z=$O(^IBE(355.97,Z)) Q:'Z  I $P($G(^(Z,1)),U,3) S IBZ=Z Q
     216 Q IBZ
     217 ;
     218TAXID() ; Returns ien of Fed tax id provider id type
     219 N Z,IBZ
     220 S (IBZ,Z)=0 F  S Z=$O(^IBE(355.97,Z)) Q:'Z  I $P($G(^(Z,1)),U,4) S IBZ=Z Q
     221 Q IBZ
     222 ;
     223CLIANVA(IBIFN) ; Returns CLIA # for a non-VA facility on bill ien IBIFN
     224 N IBCLIA,IBZ,IBNVA,Z
     225 S IBCLIA="",IBZ=$$CLIA()
     226 I IBZ D
     227 . S IBNVA=$P($G(^DGCR(399,IBIFN,"U2")),U,10) Q:'IBNVA
     228 . S IBCLIA=$$IDFIND^IBCEP2(IBIFN,IBZ,IBNVA_";IBA(355.93,","",1)
     229 Q IBCLIA
     230 ;
     231VALFAC(X) ; Function returns 1 if format is valid for X12 facility name
     232 ; Alpha/numeric/certain punctuation valid.  Must start with an Alpha
     233 N OK,VAL
     234 S OK=1
     235 S VAL("A")="",VAL("N")="",VAL=",.- "
     236 I $E(X)'?1A!'$$VALFMT(X,.VAL) S OK=0
     237 Q OK
     238 ;
     239VALFMT(X,VAL) ; Returns 1 if format of X is valid, 0 if not
     240 ; X = data to be examined
     241 ; VAL = a 'string' of valid characters AND/OR (passed by reference)
     242 ;    if VAL("A") defined ==> Alpha
     243 ;    if VAL("A") defined ==> Numeric valid
     244 ;    if VAL("A") defined ==> Punctuation valid
     245 ;   any other character included in the string is checked individually
     246 N Z
     247 I $D(VAL("A")) D
     248 . N Z0
     249 . F Z=1:1:$L(X) I $E(X,Z)?1A S Z0(Z)=""
     250 . S Z0="" F  S Z0=$O(Z0(Z0),-1) Q:'Z0  S $E(X,Z0)=""
     251 I $D(VAL("N")) D
     252 . N Z0
     253 . F Z=1:1:$L(X) I $E(X,Z)?1N S Z0(Z)=""
     254 . S Z0="" F  S Z0=$O(Z0(Z0),-1) Q:'Z0  S $E(X,Z0)=""
     255 I $D(VAL("P")) D
     256 . N Z0
     257 . F Z=1:1:$L(X) I $E(X,Z)?1P S Z0(Z)=""
     258 . S Z0="" F  S Z0=$O(Z0(Z0),-1) Q:'Z0  S $E(X,Z0)=""
     259 I $G(VAL)'="" S X=$TR(X,VAL,"")
     260 Q (X="")
     261 ;
     262PS(IBXSAVE) ; Returns 1 if IBXSAVE("PSVC") indicates the svc was non-lab
     263 ;
     264 Q $S($G(IBXSAVE("PSVC"))="":0,1:"13"[IBXSAVE("PSVC"))
     265 ;
     266 ; Pass in the Internal Entry number to File 355.93
     267 ; Return the Primary ID and Qualifier (ID Type) from 355.9
     268PRIMID(IEN35593) ; Return External Primary ID and ID Quailier
     269 N INDXVAL,LIST,MSG,IDCODE
     270 S INDXVAL=IEN35593_";IBA(355.93,"
     271 N SCREEN S SCREEN="I $P(^(0),U,8)"
     272 D FIND^DIC(355.9,,"@;.06EI;.07","Q",INDXVAL,,,SCREEN,,"LIST","MSG")
     273 I '+$G(LIST("DILIST",0)) Q ""   ; No Primary ID
     274 I +$G(LIST("DILIST",0))>1 Q "***ERROR***^***ERROR***"  ; Bad.  More than one.
     275 ; Found just one
     276 S IDCODE=$$GET1^DIQ(355.97,LIST("DILIST","ID",1,.06,"I"),.03)
     277 Q $G(LIST("DILIST","ID",1,.07))_U_IDCODE_" - "_$G(LIST("DILIST","ID",1,.06,"E"))

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP81.m

    r613 r623  
    1 IBCEP81 ;ALB/KJH - NPI and Taxonomy Functions ;19 Apr 2008  5:17 PM
    2         ;;2.0;INTEGRATED BILLING;**343,391**;21-MAR-94;Build 39
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5         ; Must call at an entry point 
    6         Q
    7         ;
    8         ; NPIREQ - Extrinsic function that will return a flag indicating
    9         ;          if the NPI 'drop dead date' has passed.
    10         ; Input
    11         ;    IBDT - Date to check (internal Fileman format)
    12         ; Output
    13         ;    1 - On or after the May 23, 2008 drop dead date
    14         ;    0 - Prior to the May 23, 2008 drop dead date
    15 NPIREQ(IBDT)    ; Check NPI drop dead date
    16         N IBCHKDT
    17         S IBCHKDT=3080523
    18         Q $S(IBDT<IBCHKDT:0,1:1)
    19         ;
    20         ; TAXREQ - Extrinsic function that will return a flag indicating
    21         ;          if the Taxonomy 'drop dead date' has passed.
    22         ; Input
    23         ;    IBDT - Date to check (internal Fileman format)
    24         ; Output
    25         ;    1 - On or after the May 23, 2008 drop dead date
    26         ;    0 - Prior to the May 23, 2008 drop dead date
    27 TAXREQ(IBDT)    ; Check Taxonomy drop dead date
    28         N IBCHKDT
    29         S IBCHKDT=3080523
    30         Q $S(IBDT<IBCHKDT:0,1:1)
    31         ;
    32         ; NPIGET - Extrinsic function to retrieve the NPI of a specified
    33         ;          record from file 355.93.
    34         ; Input
    35         ;    IBIEN - IEN of the record from file 355.93
    36         ; Output
    37         ;    NPI of that record or "" if not yet defined
    38 NPIGET(IBIEN)   ; Get NPI
    39         I IBIEN="" Q ""
    40         N NPI
    41         S NPI=$$GET1^DIQ(355.93,IBIEN_",",41.01,"I")
    42         Q NPI
    43         ;
    44         ; TAXGET - Extrinsic function to retrieve the Taxonomy of a specified
    45         ;          record from file 355.93. (NOTE: Returns data for the 'active'
    46         ;          primary record from the Taxonomy multiple or the earliest
    47         ;          'active' secondary record if no primary is present.)
    48         ;
    49         ;          The 'optional' array parameter returns all Taxonomies in a
    50         ;          formatted array so they can be displayed.
    51         ; Input
    52         ;    IBIEN - IEN of the record from file 355.93
    53         ; Output
    54         ;    Piece 1 = Taxonomy (X12 value) of that record as defined in file 8932.1
    55         ;    Piece 2 = IEN from file 8932.1
    56         ;
    57         ;    IBARR = IEN of the record from the main output
    58         ;    IBARR(IEN) = 3 pieces for each Taxonomy record
    59         ;    Piece 1 = Taxonomy (X12 value) of that record as defined in file 8932.1
    60         ;    Piece 2 = IEN from file 8932.1
    61         ;    Piece 3 = Primary/Secondary (1/0)
    62         ;   
    63 TAXGET(IBIEN,IBARR)     ; Get Taxonomy
    64         I IBIEN="" Q U
    65         N TAX,IBPTR,IEN,IENS
    66         S IEN=0,IBPTR=""
    67         F  S IEN=$O(^IBA(355.93,IBIEN,"TAXONOMY",IEN)) Q:'IEN  D
    68         . S IENS=IEN_","_IBIEN_","
    69         . I $$GET1^DIQ(355.9342,IENS,.03,"E")'="ACTIVE" Q
    70         . S IBARR(IEN)=U_$$GET1^DIQ(355.9342,IENS,.01,"I")_U_$$GET1^DIQ(355.9342,IENS,.02,"I")
    71         . S $P(IBARR(IEN),U)=$$GET1^DIQ(8932.1,$P(IBARR(IEN),U,2),"X12 CODE")
    72         . I $$GET1^DIQ(355.9342,IENS,.02,"E")="YES" S IBPTR=$P(IBARR(IEN),U,2),IBARR=IEN Q
    73         . I IBPTR="" S IBPTR=$P(IBARR(IEN),U,2),IBARR=IEN
    74         S TAX=$$GET1^DIQ(8932.1,IBPTR,"X12 CODE")
    75         Q TAX_U_IBPTR
    76         ;
    77         ; TAXDEF - Extrinsic function to retrieve the Taxonomy for the Default
    78         ;          Division from a record in file 399.
    79         ; Input
    80         ;    IBIEN399 - IEN of the record from file 399
    81         ; Output
    82         ;    Piece 1 = Taxonomy (X12 value) of that record as defined in file 8932.1
    83         ;    Piece 2 = IEN from file 8932.1
    84 TAXDEF(IBIEN399)        ; Get Taxonomy for Default Division
    85         I IBIEN399="" Q U
    86         N IBRETVAL,IBORG,IBEVDT,IBDIV,TAX
    87         S IBDIV=$$GET1^DIQ(399,IBIEN399_",",.22,"I")
    88         S IBEVDT=$$GET1^DIQ(399,IBIEN399_",",.03,"I")
    89         S IBORG=$P($$SITE^VASITE(IBEVDT,IBDIV),U)
    90         Q $$TAXORG^XUSTAX(IBORG)
    91         ;
    92         ; NPIUSED - Extrinsic function to determine whether a given NPI is already being used in files 200, 4, or 355.93.
    93         ;
    94         ; Input
    95         ;    IBNPI - NPI number to check.
    96         ;    IBOLDNPI - NPI that is being replaced or deleted
    97         ;    IBIEN - entry number for file 355.93 of entry being edited
    98         ;    IBCHECK - Is this a new NPI entry or existing
    99         ;    IBKEY - They security key XUSNPIMTL
    100         ; Output
    101         ;    1 = NPI is already being used.
    102         ;    0 = NPI is not currently being used.
    103         ;
    104 NPIUSED(IBNPI,IBOLDNPI,IBIEN,IBCHECK,IBKEY)     ; Check whether NPI is already used within files 200, 4, or 355.93.
    105         N IBNOTIFY,IBVA200,DUP,DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
    106         S (IBNOTIFY,IBVA200,DUP)=""
    107         S IBNOTIFY=$S(IBCHECK=2:1,1:$$RULES(IBNPI,IBIEN,IBOLDNPI))
    108         I IBNOTIFY=0!(IBNOTIFY="") Q ""
    109         ;Associating NPI to an entry in NEW PERSON file
    110         ;IBNOTIFY of 14 = Replacing an NPI from NEW PERSON file with an NPI from NEW PERSON file
    111         I IBNOTIFY=1!(IBNOTIFY=14) D:$G(IBOLDNPI)'=$G(IBNPI)  Q $S($G(Y)=1:0,$G(IBCHECK)=2:0,1:1)
    112         . D EN^DDIOL("The NPI of "_IBNPI_" is also associated with the INDIVIDUAL provider","","!!")
    113         . I $G(IBVA200)="" S IBVA200=$$QI^XUSNPI(IBNPI)
    114         . D EN^DDIOL($$GET1^DIQ(200,$P(IBVA200,U,2),.01))
    115         . D EN^DDIOL(" in the NEW PERSON file.  You are trying to associate","","?0")
    116         . D EN^DDIOL("it with "_$S($$GET1^DIQ(355.93,IBIEN,.02,"I")=1:"a FACILITY/GROUP",$$GET1^DIQ(355.93,IBIEN,.02,"I")=2:"an INDIVIDUAL",1:"a")_" provider")
    117         . D EN^DDIOL(" in the IB NON/OTHER VA BILLING PROVIDER file.","","?0"),EN^DDIOL("")
    118         . S DIR(0)="Y",DIR("A")="Do you still want to add this NPI to provider "_$$GET1^DIQ(355.93,IBIEN,.01),DIR("B")="NO"
    119         . S DIR("?")="Answer YES if you wish to associate the NPI from the IB NON/OTHER VA PROVIDER file with the entry in the NEW PERSON file."
    120         . D ^DIR,EN^DDIOL("") Q
    121         ; NPI is now or was in the past in use in File 4
    122         I IBNOTIFY=9 D EN^DDIOL("The NPI of "_IBNPI_" is now, or was in the past, associated with "_$$GET1^DIQ(4,$O(^DIC(4,"ANPI",IBNPI,"")),.01),"","!!"),EN^DDIOL(" in the INSTITUTION file.") Q 1
    123         ; NPI is now or was in the past in use in 355.93
    124         I IBNOTIFY=11 D EN^DDIOL("The NPI of "_IBNPI_" is now, or was in the past, associated with "_$$GET1^DIQ(355.93,$$DUP(IBNPI),.01),"","!!"),EN^DDIOL(" in the IB NON/OTHER VA BILLING PROVIDER file.") Q 1
    125         ;Inactive NPI in 355.93
    126         I IBNOTIFY=12 D EN^DDIOL("The NPI of "_IBNPI_" is already associated with the provider "_$$GET1^DIQ(355.93,$$DUP(IBNPI),.01)_" as","","!!") D  Q 1
    127         . D EN^DDIOL("INACTIVE in the IB NON/OTHER VA BILLING PROVIDER file.")
    128         . D EN^DDIOL("You are updating "_$S($$GET1^DIQ(355.93,IBIEN,.02,"I")=1:"a FACILITY/GROUP",$$GET1^DIQ(355.93,IBIEN,.02,"I")=2:"an INDIVIDUAL",1:""),"","!!")
    129         . D EN^DDIOL("in the IB NON/OTHER VA BILLING PROVIDER file.")
    130         ;Inactive NPI in NEW PERSON file
    131         I IBNOTIFY=13 D  Q 1
    132         .D EN^DDIOL("The NPI of "_IBNPI_" is also associated with the INDIVIDUAL provider","","!!"),EN^DDIOL($$GET1^DIQ(200,$P(IBVA200,U,2),.01)_" in the NEW PERSON file."),EN^DDIOL("The NPI is INACTIVE and may not be used."),EN^DDIOL("")
    133         Q ""
    134         ;
    135         ; DUP - Extrinsic function to determine whether a given NPI is already being used in file# 355.93.
    136         ;
    137         ; Input
    138         ;    IBNPI - NPI number to check.
    139         ; Output
    140         ;    NULL - NPI is not currently being used.
    141         ;    Otherwise, the IEN of the entry in file# 355.93 associated with that NPI.
    142         ;
    143 DUP(IBNPI)      ; Check whether this is a duplicate NPI within file# 355.93
    144         I IBNPI="" Q ""
    145         Q $O(^IBA(355.93,"NPIHISTORY",IBNPI,""))
    146         ;
    147         ; DISPTAX - Function to display extra Taxonomy info in the input templates in screens 6, 7, and 8 in IB EDIT BILLING INFO
    148         ;
    149         ; Input
    150         ;    IBIEN - IEN of the entry in file 8932.1 to be displayed
    151         ;    IBTXT - (optional) extra text to be displayed before the entry (i.e. "Default Division" or "Non-VA Facility")
    152         ;   
    153 DISPTAX(IBIEN,IBTXT)    ; Display extra Taxonomy info (when available)
    154         N IBX
    155         I $G(IBIEN)="" Q
    156         S IBX=$$GET1^DIQ(8932.1,IBIEN,1) I IBX]"" W !,"    ",$G(IBTXT)," Classification: ",IBX
    157         S IBX=$$GET1^DIQ(8932.1,IBIEN,2) I IBX]"" W !,"    ",$G(IBTXT)," Area of Specialization: ",IBX
    158         S IBX=$$GET1^DIQ(8932.1,IBIEN,8) I IBX]"" W !,"    ",$G(IBTXT)," Specialty Code: ",IBX
    159         S IBX=$$GET1^DIQ(8932.1,IBIEN,6) W !,"    ",$G(IBTXT)," Taxonomy X12 Code: ",IBX
    160         Q
    161 RULES(IBNPI,IBIEN,IBOLDNPI)     ;Verify that the NPI meets all rules for usage
    162         N IBIEN1,IBIEN2,DUP
    163         I $G(IBOLDNPI)>0,IBNPI=IBOLDNPI,$D(^VA(200,"ANPI",IBOLDNPI)) Q 1
    164         I IBNPI="" Q ""
    165         S DUP=$$DUP(IBNPI)
    166         ;Duplicate in 355.93
    167         I DUP'="",DUP'=IBIEN Q 11
    168         ;Replacing an NPI that is associated to NEW PERSON file with another NPI that is associated with the NEW PERSON file
    169         I $G(IBOLDNPI)>0,$D(^VA(200,"ANPI",IBOLDNPI)),$D(^VA(200,"ANPI",IBNPI)) Q 14
    170         ;Already an inactive NPI
    171         S IBIEN2=$O(^IBA(355.93,"NPIHISTORY",IBNPI,"")) D:$G(IBIEN2)'=""
    172         . S IBIEN1=$O(^IBA(355.93,IBIEN2,"NPISTATUS","C",IBNPI,""),-1)
    173         I $G(IBIEN1)'="",$D(^IBA(355.93,IBIEN2,"NPISTATUS","NPISTATUS",0,IBIEN1)) Q 12
    174         ;Check for existence in New Person
    175         ;file (#200) and/or Institution file (#4)
    176         S IBVA200=$$QI^XUSNPI(IBNPI)
    177         I $E($P(IBVA200,U,4),1,8)="Inactive" Q 13
    178         I $P(IBVA200,U)="Individual_ID",$P(IBVA200,U,4)["Active" Q 1
    179         I $P(IBVA200,U)="Organization_ID",$P(IBVA200,U,4)["Active" Q 9
    180         I $D(^DIC(4,"ANPI",IBNPI)) Q 9
    181         Q 0
    182         ;
    183 PRENPI(IBIEN)   ;Pre-NPI edit messages
    184         N IBNPI,IBVA200
    185         Q:$G(IBIEN)=""
    186         S IBNPI=$P($G(^IBA(355.93,IBIEN,0)),U,14)
    187         Q:$G(IBNPI)=""
    188         S IBVA200=$$QI^XUSNPI(IBNPI)
    189         ;NPI that exists in 355.93 also is used in 200
    190         I $P(IBVA200,U,1)="Individual_ID",$P(IBVA200,U,4)["Active" D
    191         . W !!,"The NPI of ",IBNPI," is also associated with the INDIVIDUAL provider ",!,$$GET1^DIQ(200,$P(IBVA200,U,2),.01)," in the NEW PERSON file."
    192         . W !!,"You are updating ",$S($$GET1^DIQ(355.93,IBIEN,.02,"I")=1:"a FACILITY/GROUP",$$GET1^DIQ(355.93,IBIEN,.02,"I")=2:"an INDIVIDUAL",1:"a")," provider in the"
    193         . W !,"IB NON/OTHER VA BILLING PROVIDER file.",!
    194         ;The NPI used in 355.93 is inactive in 200
    195         I $P(IBVA200,U,1)="Individual_ID",$P(IBVA200,U,4)["Inactive" D
    196         . W !!,"The NPI of ",IBNPI," is also associated with the INDIVIDUAL provider ",!,$$GET1^DIQ(200,$P(IBVA200,U,2),.01)," as INACTIVE in the NEW PERSON file."
    197         . W !!,"You are updating ",$S($$GET1^DIQ(355.93,IBIEN,.02,"I")=1:"a FACILITY/GROUP",$$GET1^DIQ(355.93,IBIEN,.02,"I")=2:"an INDIVIDUAL",1:"a")," provider in the"
    198         . W !,"IB NON/OTHER VA BILLING PROVIDER file.",!
    199         Q
     1IBCEP81 ;ALB/KJH - NPI and Taxonomy Functions ; 12 Jul 2006  6:56 PM
     2 ;;2.0;INTEGRATED BILLING;**343**;21-MAR-94;Build 16
     3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
     4 ;
     5 ; Must call at an entry point 
     6 Q
     7 ;
     8 ; NPIREQ - Extrinsic function that will return a flag indicating
     9 ;          if the NPI 'drop dead date' has passed.
     10 ; Input
     11 ;    IBDT - Date to check (internal Fileman format)
     12 ; Output
     13 ;    1 - On or after the May 23, 2008 drop dead date
     14 ;    0 - Prior to the May 23, 2008 drop dead date
     15NPIREQ(IBDT) ; Check NPI drop dead date
     16 N IBCHKDT
     17 S IBCHKDT=3080523
     18 Q $S(IBDT<IBCHKDT:0,1:1)
     19 ;
     20 ; TAXREQ - Extrinsic function that will return a flag indicating
     21 ;          if the Taxonomy 'drop dead date' has passed.
     22 ; Input
     23 ;    IBDT - Date to check (internal Fileman format)
     24 ; Output
     25 ;    1 - On or after the May 23, 2008 drop dead date
     26 ;    0 - Prior to the May 23, 2008 drop dead date
     27TAXREQ(IBDT) ; Check Taxonomy drop dead date
     28 N IBCHKDT
     29 S IBCHKDT=3080523
     30 Q $S(IBDT<IBCHKDT:0,1:1)
     31 ;
     32 ; NPIGET - Extrinsic function to retrieve the NPI of a specified
     33 ;          record from file 355.93.
     34 ; Input
     35 ;    IBIEN - IEN of the record from file 355.93
     36 ; Output
     37 ;    NPI of that record or "" if not yet defined
     38NPIGET(IBIEN) ; Get NPI
     39 I IBIEN="" Q ""
     40 N NPI
     41 S NPI=$$GET1^DIQ(355.93,IBIEN_",",41.01,"I")
     42 Q NPI
     43 ;
     44 ; TAXGET - Extrinsic function to retrieve the Taxonomy of a specified
     45 ;          record from file 355.93. (NOTE: Returns data for the 'active'
     46 ;          primary record from the Taxonomy multiple or the earliest
     47 ;          'active' secondary record if no primary is present.)
     48 ;
     49 ;          The 'optional' array parameter returns all Taxonomies in a
     50 ;          formatted array so they can be displayed.
     51 ; Input
     52 ;    IBIEN - IEN of the record from file 355.93
     53 ; Output
     54 ;    Piece 1 = Taxonomy (X12 value) of that record as defined in file 8932.1
     55 ;    Piece 2 = IEN from file 8932.1
     56 ;
     57 ;    IBARR = IEN of the record from the main output
     58 ;    IBARR(IEN) = 3 pieces for each Taxonomy record
     59 ;    Piece 1 = Taxonomy (X12 value) of that record as defined in file 8932.1
     60 ;    Piece 2 = IEN from file 8932.1
     61 ;    Piece 3 = Primary/Secondary (1/0)
     62 ;   
     63TAXGET(IBIEN,IBARR) ; Get Taxonomy
     64 I IBIEN="" Q U
     65 N TAX,IBPTR,IEN,IENS
     66 S IEN=0,IBPTR=""
     67 F  S IEN=$O(^IBA(355.93,IBIEN,"TAXONOMY",IEN)) Q:'IEN  D
     68 . S IENS=IEN_","_IBIEN_","
     69 . I $$GET1^DIQ(355.9342,IENS,.03,"E")'="ACTIVE" Q
     70 . S IBARR(IEN)=U_$$GET1^DIQ(355.9342,IENS,.01,"I")_U_$$GET1^DIQ(355.9342,IENS,.02,"I")
     71 . S $P(IBARR(IEN),U)=$$GET1^DIQ(8932.1,$P(IBARR(IEN),U,2),"X12 CODE")
     72 . I $$GET1^DIQ(355.9342,IENS,.02,"E")="YES" S IBPTR=$P(IBARR(IEN),U,2),IBARR=IEN Q
     73 . I IBPTR="" S IBPTR=$P(IBARR(IEN),U,2),IBARR=IEN
     74 S TAX=$$GET1^DIQ(8932.1,IBPTR,"X12 CODE")
     75 Q TAX_U_IBPTR
     76 ;
     77 ; TAXDEF - Extrinsic function to retrieve the Taxonomy for the Default
     78 ;          Division from a record in file 399.
     79 ; Input
     80 ;    IBIEN399 - IEN of the record from file 399
     81 ; Output
     82 ;    Piece 1 = Taxonomy (X12 value) of that record as defined in file 8932.1
     83 ;    Piece 2 = IEN from file 8932.1
     84TAXDEF(IBIEN399) ; Get Taxonomy for Default Division
     85 I IBIEN399="" Q U
     86 N IBRETVAL,IBORG,IBEVDT,IBDIV,TAX
     87 S IBDIV=$$GET1^DIQ(399,IBIEN399_",",.22,"I")
     88 S IBEVDT=$$GET1^DIQ(399,IBIEN399_",",.03,"I")
     89 S IBORG=$P($$SITE^VASITE(IBEVDT,IBDIV),U)
     90 Q $$TAXORG^XUSTAX(IBORG)
     91 ;
     92 ; NPIUSED - Extrinsic function to determine whether a given NPI is already being used in files 200, 4, or 355.93.
     93 ;
     94 ; Input
     95 ;    IBNPI - NPI number to check.
     96 ; Output
     97 ;    1 = NPI is already being used.
     98 ;    0 = NPI is not currently being used.
     99 ;
     100NPIUSED(IBNPI) ; Check whether NPI is already used within files 200, 4, or 355.93.
     101 N DUP
     102 I IBNPI="" Q ""
     103 S DUP=$$DUP(IBNPI)
     104 I DUP'="" D  Q 1
     105 . W !,"The NPI of ",IBNPI," in file IB NON/OTHER VA BILLING PROVIDER is now, or was in the past, assigned to: ",$$GET1^DIQ(355.93,DUP,.01),!
     106 . Q
     107 S DUP=$$QI^XUSNPI(IBNPI)
     108 I $P(DUP,U)'=0 D  Q 1
     109 . I $P(DUP,U)="Individual_ID" W !,"The NPI of ",IBNPI," in file NEW PERSON is now, or was in the past, assigned to: ",$$GET1^DIQ(200,$P(DUP,U,2),.01),!
     110 . I $P(DUP,U)="Organization_ID" W !,"The NPI of ",IBNPI," in file INSTITUTION is now, or was in the past, assigned to: ",$$GET1^DIQ(4,$P(DUP,U,2),.01),!
     111 . I $P(DUP,U)="Non_VA_Provider_ID" W !,"The NPI of ",IBNPI," in file IB NON/OTHER VA BILLING PROVIDER is now, or was in the past, assigned to: ",$$GET1^DIQ(355.93,$P(DUP,U,2),.01),!
     112 . Q
     113 Q 0
     114 ;
     115 ; DUP - Extrinsic function to determine whether a given NPI is already being used in file# 355.93.
     116 ;
     117 ; Input
     118 ;    IBNPI - NPI number to check.
     119 ; Output
     120 ;    NULL - NPI is not currently being used.
     121 ;    Otherwise, the IEN of the entry in file# 355.93 associated with that NPI.
     122 ;
     123DUP(IBNPI) ; Check whether this is a duplicate NPI within file# 355.93
     124 I IBNPI="" Q ""
     125 Q $O(^IBA(355.93,"NPIHISTORY",IBNPI,""))
     126 ;
     127 ; DISPTAX - Function to display extra Taxonomy info in the input templates in screens 6, 7, and 8 in IB EDIT BILLING INFO
     128 ;
     129 ; Input
     130 ;    IBIEN - IEN of the entry in file 8932.1 to be displayed
     131 ;    IBTXT - (optional) extra text to be displayed before the entry (i.e. "Default Division" or "Non-VA Facility")
     132 ;   
     133DISPTAX(IBIEN,IBTXT) ; Display extra Taxonomy info (when available)
     134 N IBX
     135 I $G(IBIEN)="" Q
     136 S IBX=$$GET1^DIQ(8932.1,IBIEN,1) I IBX]"" W !,"    ",$G(IBTXT)," Classification: ",IBX
     137 S IBX=$$GET1^DIQ(8932.1,IBIEN,2) I IBX]"" W !,"    ",$G(IBTXT)," Area of Specialization: ",IBX
     138 S IBX=$$GET1^DIQ(8932.1,IBIEN,8) I IBX]"" W !,"    ",$G(IBTXT)," Specialty Code: ",IBX
     139 S IBX=$$GET1^DIQ(8932.1,IBIEN,6) W !,"    ",$G(IBTXT)," Taxonomy X12 Code: ",IBX
     140 Q

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP82.m

    r613 r623  
    1 IBCEP82 ;ALB/CLT - Special cross references and data entry for fields in file 355.93 ;18 Apr 2008  3:46 PM
    2         ;;2.0;INTEGRATED BILLING;**343,374,377,391**;21-MAR-94;Build 39
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5         ; Call at tags only
    6         Q
    7         ;This routine will ask for the NPI, check for duplicate entries, and check for proper
    8         ;format using the double-add-double formula.  If the NPI is being deleted it will ask
    9         ;the user why it is being deleted.
    10         ;If it is being deleted because of an erroneous entry it will be completely deleted.
    11         ;If it is a valid NPI being deleted because of possible inappropriate usage it will be
    12         ;maintained in the history cross reference to preclude anyone from using this NPI again.
    13         ;
    14 EN(IBNPRV)      ;Routine primary entry point
    15         N DTOUT,DUOUT,DA,DIR,DIE,DIC,DR,X,Y,IBKEY
    16         N IBIEN,IBNPI,IBCHECK,IBOLDNPI,IBRBNPI,IBRB
    17         S IBOLDNPI="",IBNPI="",IBKEY="XUSNPIMTL"
    18 EN1     ;
    19         S (DA,IBIEN)=IBNPRV
    20         K DIR
    21         S DIR(0)="FO^10:10",DIR("A")="NPI",DIR("?")="Enter a 10 digit National Provider Identifier"
    22         I $G(DA) S:$P($G(^IBA(355.93,DA,0)),U,14)'="" (DIR("B"),IBOLDNPI,IBNPI)=$P($G(^IBA(355.93,DA,0)),U,14)
    23         D ^DIR S IBCHECK=$S(Y=IBOLDNPI:2,1:0)
    24         I X="^" W *7,!,"   EXIT NOT ALLOWED ??" G EN1
    25         I $E(X)="^" W *7,!,"   JUMPING NOT ALLOWED ??" G EN1
    26         I X="@" G:IBOLDNPI'="" DEL W *7,"??" G EN1
    27         I $G(DUOUT)!$G(DTOUT) G XIT
    28         I $G(IBOLDNPI)="",$G(X)="" G XIT
    29         S IBNPI=$S(X="":$G(IBOLDNPI),1:X)
    30         I '$$PROC(IBNPI,IBOLDNPI,IBIEN) G EN1
    31         G XIT
    32         ;
    33 EN2(IBNPRV,INDENT)      ; entry point from input templates IB SCREEN82 and IB SCREEN8H
    34         N DTOUT,DUOUT,DA,DIR,DIE,DIC,DR,X,Y,IBKEY
    35         N IBIEN,IBNPI,IBCHECK,IBOLDNPI,IBRBNPI,IBRB,SPACES
    36         S IBNPI="",IBKEY="XUSNPIMTL",IBOLDNPI="",SPACES="          "
    37 EN21    ;
    38         S (DA,IBIEN)=IBNPRV
    39         K DIR
    40         S DIR(0)="FO^10:10",DIR("A")=$E(SPACES,1,INDENT)_"NPI",DIR("?")=$E(SPACES,1,INDENT)_"Enter a 10 digit National Provider Identifier"
    41         I $G(DA) S:$P($G(^IBA(355.93,DA,0)),U,14)'="" (DIR("B"),IBOLDNPI,IBNPI)=$P($G(^IBA(355.93,DA,0)),U,14)
    42         D ^DIR S IBCHECK=$S(Y=IBOLDNPI:2,1:0)
    43         I X="@" G:IBOLDNPI'="" DEL W *7,"??" G EN21
    44         I $G(DUOUT)!$G(DTOUT) G XIT
    45         I $G(IBOLDNPI)="",$G(X)="" G XIT
    46         S IBNPI=$S(X="":$G(IBOLDNPI),1:X)
    47         I '$$PROC(IBNPI,IBOLDNPI,IBIEN) G EN21
    48         G XIT
    49         ;
    50 PROC(IBNPI,IBOLDNPI,IBIEN)      ; process new NPI
    51         I '$$CHKDGT^XUSNPI(IBNPI) W !,*7,$E($G(SPACES),1,+$G(INDENT))_"Not a valid NPI.  Please try again.",! Q 0
    52         I $$NPIUSED^IBCEP81(IBNPI,IBOLDNPI,IBIEN,IBCHECK,IBKEY)=1 Q 0
    53         S IBCHECK=1
    54         I IBOLDNPI="" D ACTI
    55         I IBOLDNPI'="" D:IBNPI'=IBOLDNPI INACT
    56         S $P(^IBA(355.93,IBIEN,0),U,14)=IBNPI,^IBA(355.93,"NPI",IBNPI,IBIEN)="",^IBA(355.93,"NPIHISTORY",IBNPI,IBIEN)=""
    57         Q 1
    58         ;
    59 ACTI    ;CREATE AN ACTIVATED ENTRY IN MULTIPLE NPISTATUS FIELD
    60         S DA(1)=IBIEN,DIC="^IBA(355.93,"_DA(1)_",""NPISTATUS"",",DIC(0)="L",X=$$NOW^XLFDT()
    61         S DIC("DR")=".02////^S X=1;.03////^S X=IBNPI;.04////^S X=DUZ"
    62         D FILE^DICN
    63         S $P(^IBA(355.93,IBIEN,0),U,14)=IBNPI
    64         Q
    65         ;
    66 DEL     ;NPI HAS BEEN DELETED
    67         ;If the user deletes the NPI this subroutine will determine why it was deleted and, if it was because it was found
    68         ;in a false identity situation, will mark it in history to never be used again.
    69         S IBNPI=$G(DIR("B"))
    70         K DIR
    71         S DIR(0)="Y"
    72         S DIR("A")="Are you sure you wish to delete this NPI"
    73         S DIR("?")="You have indicated you wish to delete the NPI.  This is a second chance check."
    74         D ^DIR
    75         G:Y(0)="NO" XIT
    76         S DIR(0)="S^E:ERROR;V:VALID",DIR("A")="Was this a Valid NPI or an NPI entered in Error"
    77         S DIR("?",1)="An example of an NPI entered in error is if the entry person transposed numbers,"
    78         S DIR("?",2)="or if the NPI for one provider is accidentally assigned to a different provider."
    79         S DIR("?")="Enter an 'E' for Error or a 'V' for Valid."
    80         D ^DIR
    81         I Y="E" D COMP W !,"The NPI has been deleted.",!
    82         I Y="V" S IBCHECK=2 D INACT W !,"The NPI is now inactive.",!
    83         Q:$D(DTOUT)!($D(DUOUT))
    84         S IBOLDNPI=IBNPI D WARND(IBIEN,IBOLDNPI,IBKEY)
    85         Q
    86         ;
    87 COMP    ;COMPLETELY DELETE THE NPI
    88         ;This subroutine will delete the NPI from the file 355.93.
    89         S OIEN=$O(^IBA(355.93,IBIEN,"NPISTATUS","C",IBOLDNPI,"A"),-1)
    90         D DELNPI(IBIEN,OIEN)
    91         K ^IBA(355.93,"NPI",IBOLDNPI,DA),^IBA(355.93,"NPIHISTORY",IBOLDNPI,DA)
    92         S IBRB=0
    93         D  ; Find the most recent status '0' (inactive) NPI entry in the list.
    94         . N IBRBLST,IBRBTMP
    95         . ; Don't want to roll back to the same number you are deleting.
    96         . S IBRBLST(IBOLDNPI)=""
    97         . S IBRBTMP="A"
    98         . ; Go through each entry in reverse order
    99         . F  S IBRBTMP=$O(^IBA(355.93,IBIEN,"NPISTATUS",IBRBTMP),-1) Q:'IBRBTMP  D  Q:IBRB'=0
    100         .. S IBRBLST=^IBA(355.93,IBIEN,"NPISTATUS",IBRBTMP,0)
    101         .. ; If this is an 'active' entry then ignore it.
    102         .. I $P(IBRBLST,U,2)=1 Q
    103         .. ; If this entry does not have an NPI then ignore it.
    104         .. I $P(IBRBLST,U,3)="" Q
    105         .. ;If this is an inactive entry then report it.
    106         .. I $P(IBRBLST,U,2)=0 S IBRB=IBRBTMP Q
    107         .. Q
    108         . Q
    109         I IBRB>0 D ROLLBACK
    110         Q
    111         ;
    112 DELNPI(IEN,OIEN)        ;DELETE-INVALID removes NPI from file.
    113         NEW DIE,DIK,DIC,DA,DR,D,D0,DI,DIC,DQ,X
    114         NEW DP,DM,DK,DL,DIEL
    115         S DIE="^IBA(355.93,",DA=IEN,DR="41.01////@"
    116         D ^DIE
    117         S DA(1)=IEN,DIK="^IBA(355.93,"_DA(1)_",""NPISTATUS"",",DA=OIEN
    118         D ^DIK
    119         Q
    120         ;
    121 INACT   ;INACTIVATE AN ENTRY
    122         ;This subroutine makes two entries in the NPI multiple field:
    123         ;one for the deactivation of the old NPI and the second
    124         ;for the activation of a new NPI.
    125         S DA(1)=IBIEN,DIC="^IBA(355.93,"_DA(1)_",""NPISTATUS"",",DIC(0)="L",X=$$NOW^XLFDT()
    126         S DIC("DR")=".02////^S X=0;.03////^S X=IBOLDNPI;.04////^S X=DUZ"
    127         D FILE^DICN
    128         S ^IBA(355.93,"NPIHISTORY",IBOLDNPI,DA(1))=""
    129         K ^IBA(355.93,"NPI",IBOLDNPI,DA(1))
    130         S $P(^IBA(355.93,IBIEN,0),U,14)=""
    131         I $G(IBCHECK)<2 D
    132         .D ACTI
    133         .S ^IBA(355.93,"NPIHISTORY",IBNPI,DA(1))=""
    134         .D WARNR(IBIEN,IBOLDNPI,IBKEY)
    135         Q
    136         ;
    137 ROLLBACK        ;Rollback or delete NPI
    138         S IBRBNPI=$P(^IBA(355.93,IBIEN,"NPISTATUS",IBRB,0),U,3)
    139         NEW DIE,DIK,DIC,DA,DR,D,D0,DI,DIC,DQ,X
    140         NEW DP,DM,DK,DL,DIEL
    141         S DA(1)=IBIEN,DIK="^IBA(355.93,"_DA(1)_",""NPISTATUS"",",DA=IBRB
    142         D ^DIK
    143         S $P(^IBA(355.93,IBIEN,0),U,14)=IBRBNPI,^IBA(355.93,"NPI",IBRBNPI,IBIEN)=""
    144         Q
    145         ;
    146 XIT     ;CLEAN AND EXIT
    147         Q
    148         ;
    149 XR      ;Set the primary taxonomy code cross reference for field 42
    150         N ATAX S ATAX=""
    151         I $D(^IBA(355.93,DA(1),"TAXONOMY","D")) D:X=1
    152         . F  S ATAX=$O(^IBA(355.93,DA(1),"TAXONOMY","D",1,ATAX)) Q:ATAX=""  D
    153         .. K ^IBA(355.93,DA(1),"TAXONOMY","D",1,ATAX)
    154         .. I ATAX'=DA S $P(^IBA(355.93,DA(1),"TAXONOMY",ATAX,0),U,2)=0,^IBA(355.93,DA(1),"TAXONOMY","D",0,ATAX)=""
    155         S ^IBA(355.93,DA(1),"TAXONOMY","D",X,DA)=""
    156         Q
    157         ;
    158 KXR     ;Kill primary taxonomy code cross reference for field 42
    159         N K
    160         F K=0,1 K ^IBA(355.93,DA(1),"TAXONOMY","D",K,DA)
    161         Q
    162         ;
    163 WARNR(IBIEN,IBOLDNPI,IBKEY)     ;Warn user that the old NPI that was replaced is currently used by an entry in the New Person file (#200)
    164         N IBIEN200
    165         Q:$G(IBOLDNPI)=""
    166         S IBIEN200=$O(^VA(200,"ANPI",IBOLDNPI,""))
    167         Q:IBIEN200=""
    168         W !!,"WARNING: NPI ",IBOLDNPI," is also associated with Provider ",$$GET1^DIQ(200,IBIEN200,.01),".",!
    169         I $O(^XUSEC(IBKEY,""))="" W !!,"There are no holders of the ",IBKEY," security key on the VistA system.  Contact your IRM department for further direction." Q
    170         W !,"A MailMan message has been sent to holders of the "_""""_IBKEY_""""_" security key."
    171         D MAILR(IBIEN,IBKEY,IBIEN200,IBOLDNPI)
    172         Q
    173         ;
    174 WARND(IBIEN,IBOLDNPI,IBKEY)     ;Warn user that the old NPI that was deleted is currently used by an entry in the New Person file (#200)
    175         N IBIEN200
    176         Q:$G(IBOLDNPI)=""
    177         S IBIEN200=$O(^VA(200,"ANPI",IBOLDNPI,""))
    178         Q:IBIEN200=""
    179         W !!,"WARNING: NPI ",IBOLDNPI," is also associated with VA Provider ",$$GET1^DIQ(200,IBIEN200,.01),".",!
    180         I $O(^XUSEC(IBKEY,""))="" W !!,"There are no holders of the ",IBKEY," security key on the VistA system.  Contact your IRM department for further direction." Q
    181         W !,"A MailMan message has been sent to holders of the "_""""_IBKEY_""""_" security key."
    182         D MAILD(IBIEN,IBKEY,IBIEN200,IBOLDNPI)
    183         Q
    184         ;
    185 MAILR(IBIEN,IBKEY,IBIEN200,IBOLDNPI)    ;Send mailman message for replacement of NPI
    186         ;This subroutine is supported by IA# 10070
    187         ;Lookups in NEW PERSON file (#200) are supported by IA#10076
    188         N IBIEN2,XMDUZ,XMSUB,XMTEXT,XMY,IBMSG,XMZ,XMMG
    189         S IBIEN2=0 F  S IBIEN2=$O(^XUSEC(IBKEY,IBIEN2)) Q:IBIEN2=""  S XMY(IBIEN2)=""
    190         S XMDUZ=$S($G(DUZ):DUZ,1:.5),XMSUB="NPI Replacement"
    191         S IBMSG(1)="The NPI "_IBOLDNPI_" was changed to "_IBNPI_" for"
    192         S IBMSG(2)=$$GET1^DIQ(355.93,IBIEN,.01)_" in the IB NON/OTHER VA BILLING PROVIDER"
    193         S IBMSG(3)="file.  The NPI "_IBOLDNPI_" is also associated with"
    194         S IBMSG(4)=$$GET1^DIQ(200,IBIEN200,.01)_" in the NEW PERSON file."
    195         S IBMSG(5)=""
    196         S IBMSG(6)="The same change may need to be made to the NEW PERSON file using the"
    197         S IBMSG(7)="Add/Edit NPI values for Providers option."
    198         S XMTEXT="IBMSG(" D ^XMD
    199         Q
    200         ;
    201 MAILD(IBIEN,IBKEY,IBIEN200,IBOLDNPI)    ;Send mailman message for deletion of an NPI
    202         ;This subroutine is supported by IA# 10070
    203         ;Lookups in NEW PERSON file (#200) are supported by IA#10076
    204         N IBIEN2,XMDUZ,XMSUB,XMTEXT,XMY,IBMSG,XMZ,XMMG
    205         S IBIEN2=0 F  S IBIEN2=$O(^XUSEC(IBKEY,IBIEN2)) Q:IBIEN2=""  S XMY(IBIEN2)=""
    206         S XMDUZ=$S($G(DUZ):DUZ,1:.5),XMSUB="NPI Deletion"
    207         S IBMSG(1)="The NPI "_IBOLDNPI_" was deleted for "_$$GET1^DIQ(355.93,IBIEN,.01)
    208         S IBMSG(2)="in the IB NON/OTHER VA BILLING PROVIDER file.  The NPI "_IBOLDNPI_" is also"
    209         S IBMSG(3)="associated with "_$$GET1^DIQ(200,IBIEN200,.01)_" in the NEW PERSON file."
    210         S IBMSG(4)=""
    211         S IBMSG(5)="The same change may need to be made to the NEW PERSON file using the"
    212         S IBMSG(6)="Add/Edit NPI values for Providers option."
    213         S XMTEXT="IBMSG(" D ^XMD
    214         Q
     1IBCEP82 ;ALB/CLT, Special cross references and data entry for fields in file 355.93 ; 14 Apr 2006  9:41 AM
     2 ;;2.0;INTEGRATED BILLING;**343,374**;21-MAR-94;Build 16
     3 ;
     4 ; Call at tags only
     5 Q
     6 ;This routine will ask for the NPI, check for duplicate entries, and check for proper
     7 ;format using the double-add-double formula.  If the NPI is being deleted it will ask
     8 ;the user why it is being deleted.
     9 ;If it is being deleted because of an erroneous entry it will be completely deleted.
     10 ;If it is a valid NPI being deleted because of possible inappropriate usage it will be
     11 ;maintained in the history cross reference to preclude anyone from using this NPI again.
     12 ;
     13EN ;Routine primary entry point
     14 N DTOUT,DUOUT,DIR,DIE,DIC,DR,X,Y
     15 N IBIEN,IBNPI,IBCHECK,IBOLDNPI,IBRBNPI,IBRB
     16 S IBIEN=DA,IBOLDNPI=""
     17EN1 ;
     18 K DIR
     19 S DIR(0)="FO^10:10",DIR("A")="NPI",DIR("?")="Enter a 10 digit National Provider Identifier"
     20 I $G(DA) S:$P($G(^IBA(355.93,DA,0)),U,14)'="" (DIR("B"),IBOLDNPI)=$P($G(^IBA(355.93,DA,0)),U,14)
     21 D ^DIR S IBCHECK=0
     22 I X="^" W *7,!,"   EXIT NOT ALLOWED ??" G EN1
     23 I $E(X)="^" W *7,!,"   JUMPING NOT ALLOWED ??" G EN1
     24 I X="@" G:IBOLDNPI'="" DEL W *7,"??" G EN1
     25 I $G(DUOUT)!$G(DTOUT)!(X="")!(Y=IBOLDNPI) G XIT
     26 S IBNPI=Y
     27 I '$$CHKDGT^XUSNPI(IBNPI) W !,*7,"Not a valid NPI.  Please try again.",! G EN1
     28 I $$NPIUSED^IBCEP81(IBNPI) G EN1
     29 S IBCHECK=1
     30 I IBOLDNPI="" D ACTI
     31 I IBOLDNPI'="" D:IBNPI'=IBOLDNPI INACT
     32 S $P(^IBA(355.93,IBIEN,0),U,14)=IBNPI,^IBA(355.93,"NPI",IBNPI,IBIEN)="",^IBA(355.93,"NPIHISTORY",IBNPI,IBIEN)=""
     33 G XIT
     34 ;
     35ACTI ;CREATE AN ACTIVATED ENTRY IN MULTIPLE NPISTATUS FIELD
     36 S DA(1)=IBIEN,DIC="^IBA(355.93,"_DA(1)_",""NPISTATUS"",",DIC(0)="L",X=$$NOW^XLFDT()
     37 S DIC("DR")=".02////^S X=1;.03////^S X=IBNPI;.04////^S X=DUZ"
     38 D FILE^DICN
     39 S $P(^IBA(355.93,IBIEN,0),U,14)=IBNPI
     40 Q
     41 ;
     42DEL ;NPI HAS BEEN DELETED
     43 ;If the user deletes the NPI this subroutine will determine why it was deleted and if it was because it was found
     44 ;in a false identity situation will mark it in history to never be used again.
     45 S IBNPI=DIR("B")
     46 K DIR
     47 S DIR(0)="Y"
     48 S DIR("A")="Are you sure you wish to delete this NPI"
     49 S DIR("?")="You have indicated you wish to delete the NPI.  This is a second chance check."
     50 D ^DIR
     51 G:Y(0)="NO" XIT
     52 S DIR(0)="S^E:ERROR;V:VALID",DIR("A")="Was this a Valid NPI or an NPI entered in Error"
     53 S DIR("?",1)="An example of an NPI entered in error is if the entry person transposed numbers,"
     54 S DIR("?",2)="or if the NPI for one provider is accidentally assigned to a different provider."
     55 S DIR("?")="Enter an 'E' for Error or a 'V' for Valid."
     56 D ^DIR
     57 I Y="E" D COMP W !,"The NPI has been deleted.",!
     58 I Y="V" S IBCHECK=2 D INACT W !,"The NPI is now inactive.",!
     59 Q
     60 ;
     61COMP ;COMPLETELY DELETE THE NPI
     62 ;This subroutine will delete the NPI from the file 355.93.
     63 S OIEN=$O(^IBA(355.93,IBIEN,"NPISTATUS","C",IBOLDNPI,"A"),-1)
     64 D DELNPI(IBIEN,OIEN)
     65 K ^IBA(355.93,"NPI",IBOLDNPI,DA),^IBA(355.93,"NPIHISTORY",IBOLDNPI,DA)
     66 S IBRB=0
     67 D  ; Find the most recent status '0' (inactive) NPI entry in the list.
     68 . N IBRBLST,IBRBTMP
     69 . ; Don't want to roll back to the same number you are deleting.
     70 . S IBRBLST(IBOLDNPI)=""
     71 . S IBRBTMP="A"
     72 . ; Go through each entry in reverse order
     73 . F  S IBRBTMP=$O(^IBA(355.93,IBIEN,"NPISTATUS",IBRBTMP),-1) Q:'IBRBTMP  D  Q:IBRB'=0
     74 .. S IBRBLST=^IBA(355.93,IBIEN,"NPISTATUS",IBRBTMP,0)
     75 .. ; If this is an 'active' entry then ignore it.
     76 .. I $P(IBRBLST,U,2)=1 Q
     77 .. ; If this entry does not have an NPI then ignore it.
     78 .. I $P(IBRBLST,U,3)="" Q
     79 .. ;If this is an inactive entry then report it.
     80 .. I $P(IBRBLST,U,2)=0 S IBRB=IBRBTMP Q
     81 .. Q
     82 . Q
     83 I IBRB>0 D ROLLBACK
     84 Q
     85 ;
     86DELNPI(IEN,OIEN) ;DELETE-INVALID removes NPI from file.
     87 NEW DIE,DIK,DIC,DA,DR,D,D0,DI,DIC,DQ,X
     88 NEW DP,DM,DK,DL,DIEL
     89 S DIE="^IBA(355.93,",DA=IEN,DR="41.01////@"
     90 D ^DIE
     91 S DA(1)=IEN,DIK="^IBA(355.93,"_DA(1)_",""NPISTATUS"",",DA=OIEN
     92 D ^DIK
     93 Q
     94 ;
     95INACT ;INACTIVATE AN ENTRY
     96 ;This subroutine makes two entries in the NPI multiple field.
     97 ;One for the deactivation of the old NPI and the second
     98 ;for the activation of a new NPI.
     99 S DA(1)=IBIEN,DIC="^IBA(355.93,"_DA(1)_",""NPISTATUS"",",DIC(0)="L",X=$$NOW^XLFDT()
     100 S DIC("DR")=".02////^S X=0;.03////^S X=IBOLDNPI;.04////^S X=DUZ"
     101 D FILE^DICN
     102 S ^IBA(355.93,"NPIHISTORY",IBOLDNPI,DA(1))=""
     103 K ^IBA(355.93,"NPI",IBOLDNPI,DA(1))
     104 S $P(^IBA(355.93,IBIEN,0),U,14)=""
     105 I $G(IBCHECK)<2 D ACTI
     106 S ^IBA(355.93,"NPIHISTORY",IBNPI,DA(1))=""
     107 Q
     108 ;
     109ROLLBACK ;Rollback or delete NPI
     110 S IBRBNPI=$P(^IBA(355.93,IBIEN,"NPISTATUS",IBRB,0),U,3)
     111 NEW DIE,DIK,DIC,DA,DR,D,D0,DI,DIC,DQ,X
     112 NEW DP,DM,DK,DL,DIEL
     113 S DA(1)=IBIEN,DIK="^IBA(355.93,"_DA(1)_",""NPISTATUS"",",DA=IBRB
     114 D ^DIK
     115 S $P(^IBA(355.93,IBIEN,0),U,14)=IBRBNPI,^IBA(355.93,"NPI",IBRBNPI,IBIEN)=""
     116 Q
     117 ;
     118XIT ;CLEAN AND EXIT
     119 Q
     120 ;
     121XR ;Set the primary taxonomy code cross reference for field 42
     122 N ATAX S ATAX=""
     123 I $D(^IBA(355.93,DA(1),"TAXONOMY","D")) D:X=1
     124 . F  S ATAX=$O(^IBA(355.93,DA(1),"TAXONOMY","D",1,ATAX)) Q:ATAX=""  D
     125 .. K ^IBA(355.93,DA(1),"TAXONOMY","D",1,ATAX)
     126 .. I ATAX'=DA S $P(^IBA(355.93,DA(1),"TAXONOMY",ATAX,0),U,2)=0,^IBA(355.93,DA(1),"TAXONOMY","D",0,ATAX)=""
     127 S ^IBA(355.93,DA(1),"TAXONOMY","D",X,DA)=""
     128 Q
     129 ;
     130KXR ;Kill primary taxonomy code cross reference for field 42
     131 N K
     132 F K=0,1 K ^IBA(355.93,DA(1),"TAXONOMY","D",K,DA)
     133 Q

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEPA.m

    r613 r623  
    1 IBCEPA  ;ALB/WCJ - Provider ID functions - Care Units ;21-OCT-2005
    2         ;;2.0;INTEGRATED BILLING;**320,348,377**;21-MAR-94;Build 23
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5 EN      ; -- main entry point for IBCE 2ND PRVID CARE UNIT MAINT
    6         D EN^VALM("IBCE 2ND PRVID CARE UNIT MAINT")
    7         Q
    8         ;
    9 HDR     ; -- header code
    10         K VALMHDR
    11         S VALMHDR(1)=" "
    12         S VALMHDR(2)="Insurance Co: "_$S('$G(IBALL)&$G(IBINS):$P($G(^DIC(36,+IBINS,0)),U),1:"ALL")
    13         Q
    14         ;
    15 INIT    ; -- init variables and list array
    16         N DIR,Y
    17         I '$G(IBINS) D  I +Y<0 S VALMQUIT=1 Q
    18         . S DIR(0)="PA^DIC(36,:AEMQ",DIR("A")="Select INSURANCE CO: ",DIR("?")="Select an INSURANCE CO to display its care units"
    19         . D ^DIR K DIR
    20         . I $D(DTOUT)!$D(DUOUT) S Y=-2 Q
    21         . I Y>0 S IBINS=+Y Q
    22         ;
    23         D BLD
    24         Q
    25         ;
    26 BLD     ;
    27         D CLEAN^VALM10
    28         K ^TMP("IBPRV_CU",$J)
    29         N TAR,MSG,I,D0,IBCT,Z,DIV,SCREEN
    30         ;
    31         S VALMBG=1
    32         ;
    33         ; Get all care units for this insurance company that have a division
    34         ; If there is no division, then it is part of the other care units code (IBCEP4)
    35         ;
    36         S SCREEN="I $P(^(0),U,4)'="""",$P(^(0),U,3)=IBINS"
    37         D LIST^DIC(355.95,,"@;.01;.02;.04",,,,,,SCREEN,,"TAR")
    38         ;
    39         I '+TAR("DILIST",0) D
    40         . D SET^VALM10(1,"No CARE UNITs found for this Insurance Company")
    41         ;
    42         I +TAR("DILIST",0) D
    43         . S IBCT=0
    44         . F VALMCNT=1:1:+TAR("DILIST",0) D
    45         .. S ^TMP("IBPRV_CU",$J,"SORT",TAR("DILIST","ID",VALMCNT,.04),TAR("DILIST",2,VALMCNT))=VALMCNT
    46         . S DIV="" F  S DIV=$O(^TMP("IBPRV_CU",$J,"SORT",DIV)) Q:DIV=""  D
    47         .. S Z="Division: "_DIV
    48         .. S IBCT=IBCT+1
    49         .. D SET^VALM10(IBCT,Z)
    50         .. S D0=0 F  S D0=$O(^TMP("IBPRV_CU",$J,"SORT",DIV,D0)) Q:'D0  D
    51         ... S IN=^TMP("IBPRV_CU",$J,"SORT",DIV,D0)
    52         ... S Z=$J("",2)
    53         ... S Z=Z_$E(IN_"    ",1,4)_$E(TAR("DILIST","ID",IN,.01),1,36)
    54         ... S Z=Z_$J("",40-$L(Z))
    55         ... S Z=Z_$E(TAR("DILIST","ID",IN,.02),1,38)
    56         ... S IBCT=IBCT+1
    57         ... D SET^VALM10(IBCT,Z)
    58         ;
    59         ; correct the VALMCNT variable - number of lines in the list (not entries)
    60         S VALMCNT=+$O(@VALMAR@(""),-1)
    61         Q
    62         ;
    63 HELP    ; -- help code
    64         S X="?" D DISP^XQORM1 W !!
    65         Q
    66         ;
    67 EXIT    ; -- exit code
    68         D CLEAN^VALM10
    69         K ^TMP("IBPRV_CU",$J)
    70         Q
    71         ;
    72 EXPND   ; -- expand code
    73         Q
    74         ;
    75 NEW     ; Add care unit
    76         ; Assumes IBINS is defined as ins co ien (file 36)
    77         ; IB = 0 or null if called from list manager, 1 if not
    78         N DIC,DIR,X,Y,Z,D,DA,DR,DIE,DO,DD,DLAYGO,IB95,IBADD,IBOK,IBDIV,MAIN,IBDIVNM
    79         ;
    80         D FULL^VALM1
    81         ; Add an entry - either new care unit/ins co or a combination for
    82         ; existing care unit/ins co
    83         ;
    84         S MAIN=$$MAIN^IBCEP2B()
    85         S MAIN=$$EXTERNAL^DILFD(355.92,.05,"",MAIN)
    86         S DIC=40.8,DIC("A")="Enter the Division for this Care Unit: ",DIC("B")=MAIN,DIC(0)="AEMQ"
    87         S D="B^C"
    88         D MIX^DIC1
    89         I Y'>0 G NEWQ
    90         S IBDIV=+Y
    91         S IBDIVNM=$$EXTERNAL^DILFD(355.92,.05,"",IBDIV)
    92         ;
    93         N SCREEN,TAR,MESS,I
    94         S SCREEN="I $P(^(0),U,3)=+$G(IBINS),$P(^(0),U,4)=+$G(IBDIV)"
    95         D LIST^DIC(355.95,,.01,,,,,,SCREEN,,"TAR")
    96         ;
    97 ACU     K DIR
    98         S I=0
    99         I $G(TAR("DILIST",0)) D
    100         . S DIR("?",1)="Current Entries are:"
    101         . F I=2:1 Q:'$D(TAR("DILIST",1,I-1))  S DIR("?",I)="     "_TAR("DILIST",1,I-1)
    102         . S DIR("?",I)=" "
    103         ;
    104         S DIR("?",I+1)="You may enter the name of a new Care Unit for this Insurance Company."
    105         S DIR("?",I+2)="You can then define a Billing Provider Secondary ID - Billing Screen 3 - for"
    106         S DIR("?")="this Care Unit and Insurance Company using the Insurance Company Editor."
    107         S DIR("A")="Enter the Care Unit name"
    108         S DIR(0)="FO^1:30"
    109         D ^DIR
    110         I X=""!$G(DUOUT)!$G(DTOUT)!$G(DIROUT) G NEWQ
    111         S CAREUNIT=X
    112         ;
    113         ; At this point, we have X and it'a not a ? or ^
    114         ;
    115         K DIC
    116         S DIC="^IBA(355.95,",DIC("S")="I $P(^(0),U,3)=+$G(IBINS),$P(^(0),U,4)=+$G(IBDIV)",DIC(0)="EX"
    117         D ^DIC
    118         ;
    119         ; Check if we have an exisitng entry and if so, get out of Dodge (This option was for new care units)
    120         I Y>0 D  G ACU
    121         . D DISPMESS("This action is for adding new entries, not editing existing entries.")
    122         ;
    123         ; New entry , validate field
    124         N TAR2
    125         D FIELD^DID(355.95,.01,"N","INPUT TRANSFORM","TAR2")
    126         S X=CAREUNIT
    127         X TAR2("INPUT TRANSFORM")
    128         I '$D(X) D  G ACU  ; Failed input transform
    129         . D DISPMESS("Invalid Format.")
    130         ;
    131         K DIR
    132         S DIR("A")="Are you adding '"_X_"' as a new Care Unit for '"_IBDIVNM_"'"
    133         S DIR("B")="N"
    134         S DIR(0)="Y"
    135         D ^DIR
    136         I Y=0 G ACU
    137         I Y["^" G NEWQ
    138         ;
    139         ; If it got this far, we have an exact match or a new entry.   
    140         S X=CAREUNIT
    141         S DIC="^IBA(355.95,",DIC("S")="I $P(^(0),U,3)=+$G(IBINS),$P(^(0),U,4)=+$G(IBDIV)",DIC(0)="XL",DLAYGO=355.95
    142         S DIC("DR")=".03////"_+$G(IBINS)_";.04////"_$G(IBDIV)
    143         D ^DIC
    144         I Y>0 D
    145         . S DA=+Y,DIE="^IBA(355.95,"
    146         . S DR=".02Enter the Care Unit Description"
    147         . D ^DIE
    148         D BLD
    149         ;
    150 NEWQ    S VALMBCK="R"
    151         Q
    152         ;
    153 CHANGE  ; Edit care unit
    154         ; Assumes IBINS is defined as ins co ien (file 36)
    155         ;
    156         D FULL^VALM1
    157         ;
    158         N X,Y,Z,D,DA,DD,DIC,DIK,DIR,IBDIV,CAREUNIT,SCREEN,TAR,DIVISION,I
    159         ;
    160         S SCREEN="I $P(^(0),U,3)=+$G(IBINS),$P(^(0),U,4)]"""""
    161         D LIST^DIC(355.95,,".01;.04",,,,,,SCREEN,,"TAR")
    162         ;
    163         I '+$G(TAR("DILIST",0)) D  G CHANGEQ
    164         .D DISPMESS("No Care Units Defined for this insurance company.")
    165         ;
    166         ; Store all Divisons with at least one care unit in DIVISION array
    167         F I=1:1 Q:'$D(TAR("DILIST","ID",I,.04))  D
    168         . S DIVISION(TAR("DILIST","ID",I,.04))=""
    169         ;
    170         ; Only allow divisions that have care units to be selected
    171         S DIC=40.8
    172         S DIC("A")="Enter the Division for this Care Unit: "
    173         S DIC(0)="AEMQ"
    174         S DIC("S")="I $D(DIVISION($P(^(0),U)))"
    175         S D="B^C"
    176         D MIX^DIC1
    177         I Y'>0 G CHANGEQ
    178         S IBDIV=+Y
    179         S DA=$$SEL($P(Y,U,2)) I 'DA G CHANGEQ
    180         S DIE=355.95
    181         S DR=".01Care Unit;.04Division;.02Description"
    182         D ^DIE
    183         ;
    184         D BLD
    185         ;
    186 CHANGEQ S VALMBCK="R"
    187         Q
    188         ;
    189 DEL     ; Delete a Care Unit
    190         ; Assumes IBINS is defined as ins co ien (file 36)
    191         ;
    192         D FULL^VALM1
    193         N X,Y,Z,D,DA,DD,DIC,DIK,DIR,IBDIV,CAREUNIT,SCREEN,TAR,DIVISION
    194         ;
    195         S SCREEN="I $P(^(0),U,3)=+$G(IBINS),$P(^(0),U,4)]"""""
    196         D LIST^DIC(355.95,,".01;.04",,,,,,SCREEN,,"TAR")
    197         ;
    198         I '+$G(TAR("DILIST",0)) D  G DELQ
    199         .D DISPMESS("No Care Units Defined for this insurance company.")
    200         ;
    201         ; Store all Divisons with at least one care unit in DIVISION array
    202         F I=1:1 Q:'$D(TAR("DILIST","ID",I,.04))  D
    203         . S DIVISION(TAR("DILIST","ID",I,.04))=""
    204         ;
    205         ; Only allow divisions that have care units to be selected
    206         S DIC=40.8
    207         S DIC("A")="Enter the Division for this Care Unit: "
    208         S DIC(0)="AEMQ"
    209         S DIC("S")="I $D(DIVISION($P(^(0),U)))"
    210         S D="B^C"
    211         D MIX^DIC1
    212         I Y'>0 G DELQ
    213         S IBDIV=+Y
    214         S CAREUNIT=$$SEL($P(Y,U,2)) I 'CAREUNIT G DELQ
    215         ;
    216         I $D(^IBA(355.92,"AC",+Y)) D  G DELQ
    217         . S DIR(0)="EA"
    218         . S DIR("A",1)="IDs that are assigned to the Care Unit in the Insurance Company Editor must be"
    219         . S DIR("A",2)="deleted before deleting the Care Unit."
    220         . S DIR("A")="Press return to continue "
    221         . W ! D ^DIR K DIR
    222         ;
    223         S DIR("A")="OK to Delete: "
    224         S DIR("B")="No"
    225         S DIR(0)="YAO"
    226         D ^DIR
    227         I '$G(Y) G DELQ
    228         K DIR
    229         ;
    230         S DA=CAREUNIT
    231         S DIK="^IBA("_355.95_","
    232         D ^DIK
    233         ;
    234         D BLD
    235         ;
    236 DELQ    S VALMBCK="R"
    237         Q
    238         ;
    239 DISPMESS(MESS)  ;
    240         N DIR,X,Y
    241         S DIR(0)="EA",DIR("A",1)=MESS
    242         S DIR("A")="PRESS ENTER to continue "
    243         D ^DIR
    244         Q
    245         ;
    246 SEL(DIV)        ; select care unit for a given division
    247         ; DIV - name of division
    248         ; returns ien of selected care unit, or 0 if nothing is selected
    249         N DIR,I,IEN,MIN,MAX,X,Y
    250         I $G(DIV)="" Q 0
    251         S IEN=0
    252         S I=$O(^TMP("IBPRV_CU",$J,"SORT",DIV,"")),MIN=$G(^TMP("IBPRV_CU",$J,"SORT",DIV,I))
    253         S I=$O(^TMP("IBPRV_CU",$J,"SORT",DIV,""),-1),MAX=$G(^TMP("IBPRV_CU",$J,"SORT",DIV,I))
    254         I MIN=MAX S IEN=I
    255         I MIN'=MAX D
    256         .S DIR("A")="Select CARE UNITS",DIR(0)="N^"_MIN_":"_MAX_":0" D ^DIR
    257         .Q:$D(DTOUT)!$D(DUOUT)
    258         .S I="" F  S I=$O(^TMP("IBPRV_CU",$J,"SORT",DIV,I)) Q:I=""!(IEN>0)  S:$G(^TMP("IBPRV_CU",$J,"SORT",DIV,I))=Y IEN=I
    259         .Q
    260         Q IEN
     1IBCEPA ;ALB/WCJ - Provider ID functions - Care Units ;21-OCT-2005
     2 ;;2.0;INTEGRATED BILLING;**320,348**;21-MAR-94;Build 5
     3EN ; -- main entry point for IBCE 2ND PRVID CARE UNIT MAINT
     4 D EN^VALM("IBCE 2ND PRVID CARE UNIT MAINT")
     5 Q
     6 ;
     7HDR ; -- header code
     8 K VALMHDR
     9 S VALMHDR(1)=" "
     10 S VALMHDR(2)="Insurance Co: "_$S('$G(IBALL)&$G(IBINS):$P($G(^DIC(36,+IBINS,0)),U),1:"ALL")
     11 Q
     12 ;
     13INIT ; -- init variables and list array
     14 N DIR,Y
     15 I '$G(IBINS) D  I +Y<0 S VALMQUIT=1 Q
     16 . S DIR(0)="PA^DIC(36,:AEMQ",DIR("A")="Select INSURANCE CO: ",DIR("?")="Select an INSURANCE CO to display its care units"
     17 . D ^DIR K DIR
     18 . I $D(DTOUT)!$D(DUOUT) S Y=-2 Q
     19 . I Y>0 S IBINS=+Y Q
     20 ;
     21 D BLD
     22 Q
     23 ;
     24BLD ;
     25 D CLEAN^VALM10
     26 K ^TMP("IBPRV_CU",$J)
     27 N TAR,MSG,I,D0,IBLCT,Z,DIV,SCREEN
     28 ;
     29 S VALMBG=1
     30 ;
     31 ; Get all care units for this insurance company that have a division
     32 ; If there is no division, then it is part of the other care units code (IBCEP4)
     33 ;
     34 S SCREEN="I $P(^(0),U,4)'="""",$P(^(0),U,3)=IBINS"
     35 D LIST^DIC(355.95,,"@;.01;.02;.04",,,,,,SCREEN,,"TAR")
     36 ;
     37 I '+TAR("DILIST",0) D
     38 . D SET^VALM10(1,"No CARE UNITs found for this Insurance Company")
     39 ;
     40 I +TAR("DILIST",0) D
     41 . S IBCT=0
     42 . F VALMCNT=1:1:+TAR("DILIST",0) D
     43 .. S ^TMP("IBPRV_CU",$J,"SORT",TAR("DILIST","ID",VALMCNT,.04),TAR("DILIST",2,VALMCNT))=VALMCNT
     44 . S DIV="" F  S DIV=$O(^TMP("IBPRV_CU",$J,"SORT",DIV)) Q:DIV=""  D
     45 .. S Z="Division: "_DIV
     46 .. S IBCT=IBCT+1
     47 .. D SET^VALM10(IBCT,Z)
     48 .. S D0=0 F  S D0=$O(^TMP("IBPRV_CU",$J,"SORT",DIV,D0)) Q:'D0  D
     49 ... S IN=^TMP("IBPRV_CU",$J,"SORT",DIV,D0)
     50 ... S Z=$J("",2)
     51 ... S Z=Z_$E(TAR("DILIST","ID",IN,.01),1,36)
     52 ... S Z=Z_$J("",40-$L(Z))
     53 ... S Z=Z_$E(TAR("DILIST","ID",IN,.02),1,38)
     54 ... S IBCT=IBCT+1
     55 ... D SET^VALM10(IBCT,Z)
     56 Q
     57 ;
     58HELP ; -- help code
     59 S X="?" D DISP^XQORM1 W !!
     60 Q
     61 ;
     62EXIT ; -- exit code
     63 D CLEAN^VALM10
     64 Q
     65 ;
     66EXPND ; -- expand code
     67 Q
     68 ;
     69NEW ; Add care unit
     70 ; Assumes IBINS is defined as ins co ien (file 36)
     71 ; IB = 0 or null if called from list manager, 1 if not
     72 N DIC,DIR,X,Y,Z,DA,DR,DIE,DO,DD,DLAYGO,IB95,IBADD,IBOK,IBDIV,MAIN,IBDIVNM
     73 ;
     74 D FULL^VALM1
     75 ; Add an entry - either new care unit/ins co or a combination for
     76 ; existing care unit/ins co
     77 ;
     78 S MAIN=$$MAIN^IBCEP2B()
     79 S MAIN=$$EXTERNAL^DILFD(355.92,.05,"",MAIN)
     80 S DIC=40.8,DIC("A")="Enter the Division for this Care Unit: ",DIC("B")=MAIN,DIC(0)="AEMQ"
     81 D ^DIC
     82 I Y'>0 G NEWQ
     83 S IBDIV=+Y
     84 S IBDIVNM=$$EXTERNAL^DILFD(355.92,.05,"",IBDIV)
     85 ;
     86 N SCREEN,TAR,MESS,I
     87 S SCREEN="I $P(^(0),U,3)=+$G(IBINS),$P(^(0),U,4)=+$G(IBDIV)"
     88 D LIST^DIC(355.95,,.01,,,,,,SCREEN,,"TAR")
     89 ;
     90ACU K DIR
     91 S I=0
     92 I $G(TAR("DILIST",0)) D
     93 . S DIR("?",1)="Current Entries are:"
     94 . F I=2:1 Q:'$D(TAR("DILIST",1,I-1))  S DIR("?",I)="     "_TAR("DILIST",1,I-1)
     95 . S DIR("?",I)=" "
     96 ;
     97 S DIR("?",I+1)="You may enter the name of a new Care Unit for this Insurance Company."
     98 S DIR("?",I+2)="You can then define a Billing Provider Secondary ID - Billing Screen 3 - for"
     99 S DIR("?")="this Care Unit and Insurance Company using the Insurance Company Editor."
     100 S DIR("A")="Enter the Care Unit name"
     101 S DIR(0)="FO^1:30"
     102 D ^DIR
     103 I X=""!$G(DUOUT)!$G(DTOUT)!$G(DIROUT) G NEWQ
     104 S CAREUNIT=X
     105 ;
     106 ; At this point, we have X and it'a not a ? or ^
     107 ;
     108 K DIC
     109 S DIC="^IBA(355.95,",DIC("S")="I $P(^(0),U,3)=+$G(IBINS),$P(^(0),U,4)=+$G(IBDIV)",DIC(0)="EX"
     110 D ^DIC
     111 ;
     112 ; Check if we have an exisitng entry and if so, get out of Dodge (This option was for new care units)
     113 I Y>0 D  G ACU
     114 . D DISPMESS("This action is for adding new entries, not editing existing entries.")
     115 ;
     116 ; New entry , validate field
     117 N TAR2
     118 D FIELD^DID(355.95,.01,"N","INPUT TRANSFORM","TAR2")
     119 S X=CAREUNIT
     120 X TAR2("INPUT TRANSFORM")
     121 I '$D(X) D  G ACU  ; Failed input transform
     122 . D DISPMESS("Invalid Format.")
     123 ;
     124 K DIR
     125 S DIR("A")="Are you adding '"_X_"' as a new Care Unit for '"_IBDIVNM_"'"
     126 S DIR("B")="N"
     127 S DIR(0)="Y"
     128 D ^DIR
     129 I Y=0 G ACU
     130 I Y["^" G NEWQ
     131 ;
     132 ; If it got this far, we have an exact match or a new entry.   
     133 S X=CAREUNIT
     134 S DIC="^IBA(355.95,",DIC("S")="I $P(^(0),U,3)=+$G(IBINS),$P(^(0),U,4)=+$G(IBDIV)",DIC(0)="XL",DLAYGO=355.95
     135 S DIC("DR")=".03////"_+$G(IBINS)_";.04////"_$G(IBDIV)
     136 D ^DIC
     137 I Y>0 D
     138 . S DA=+Y,DIE="^IBA(355.95,"
     139 . S DR=".02Enter the Care Unit Description"
     140 . D ^DIE
     141 D BLD
     142 ;
     143NEWQ S VALMBCK="R"
     144 Q
     145 ;
     146CHANGE ; Edit care unit
     147 ; Assumes IBINS is defined as ins co ien (file 36)
     148 ;
     149 D FULL^VALM1
     150 ;
     151 N X,Y,Z,DA,DD,DIC,DIK,DIR,IBDIV,CAREUNIT,SCREEN,TAR,DIVISION
     152 ;
     153 S SCREEN="I $P(^(0),U,3)=+$G(IBINS),$P(^(0),U,4)]"""""
     154 D LIST^DIC(355.95,,".01;.04",,,,,,SCREEN,,"TAR")
     155 ;
     156 I '+$G(TAR("DILIST",0)) D  G CHANGEQ
     157 .D DISPMESS("No Care Units Defined for this insurance company.")
     158 ;
     159 ; Store all Divisons with at least one care unit in DIVISION array
     160 F I=1:1 Q:'$D(TAR("DILIST","ID",I,.04))  D
     161 . S DIVISION(TAR("DILIST","ID",I,.04))=""
     162 ;
     163 ; Only allow divisions that have care units to be selected
     164 S DIC=40.8
     165 S DIC("A")="Enter the Division for this Care Unit: "
     166 S DIC(0)="AEMQ"
     167 S DIC("S")="I $D(DIVISION($P(^(0),U)))"
     168 D ^DIC
     169 I Y'>0 G CHANGEQ
     170 S IBDIV=+Y
     171 ;
     172 S DIC("A")="Enter the Care Unit name: "
     173 S DIC=355.95,DIC("S")="I $P(^(0),U,3)=+$G(IBINS),$P(^(0),U,4)=+$G(IBDIV)",DIC(0)="AEMQ"
     174 D ^DIC
     175 I Y<1 G CHANGEQ
     176 ;
     177 S DA=+Y,DIE=355.95
     178 S DR=".01Care Unit;.04Division;.02Description"
     179 D ^DIE
     180 ;
     181 D BLD
     182 ;
     183CHANGEQ S VALMBCK="R"
     184 Q
     185 ;
     186DEL ; Delete a Care Unit
     187 ; Assumes IBINS is defined as ins co ien (file 36)
     188 ;
     189 D FULL^VALM1
     190 N X,Y,Z,DA,DD,DIC,DIK,DIR,IBDIV,CAREUNIT,SCREEN,TAR,DIVISION
     191 ;
     192 S SCREEN="I $P(^(0),U,3)=+$G(IBINS),$P(^(0),U,4)]"""""
     193 D LIST^DIC(355.95,,".01;.04",,,,,,SCREEN,,"TAR")
     194 ;
     195 I '+$G(TAR("DILIST",0)) D  G DELQ
     196 .D DISPMESS("No Care Units Defined for this insurance company.")
     197 ;
     198 ; Store all Divisons with at least one care unit in DIVISION array
     199 F I=1:1 Q:'$D(TAR("DILIST","ID",I,.04))  D
     200 . S DIVISION(TAR("DILIST","ID",I,.04))=""
     201 ;
     202 ; Only allow divisions that have care units to be selected
     203 S DIC=40.8
     204 S DIC("A")="Enter the Division for this Care Unit: "
     205 S DIC(0)="AEMQ"
     206 S DIC("S")="I $D(DIVISION($P(^(0),U)))"
     207 D ^DIC
     208 I Y'>0 G DELQ
     209 S IBDIV=+Y
     210 ;
     211 K DIC
     212 S DIC("A")="Enter the Care Unit name: "
     213 S DIC=355.95,DIC("S")="I $P(^(0),U,3)=+$G(IBINS),$P(^(0),U,4)=+$G(IBDIV)",DIC(0)="AEMQ"
     214 D ^DIC
     215 I Y<1 G DELQ
     216 S CAREUNIT=+Y
     217 ;
     218 I $D(^IBA(355.92,"AC",+Y)) D  G DELQ
     219 . S DIR(0)="EA"
     220 . S DIR("A",1)="IDs that are assigned to the Care Unit in the Insurance Company Editor must be"
     221 . S DIR("A",2)="deleted before deleting the Care Unit."
     222 . S DIR("A")="Press return to continue "
     223 . W ! D ^DIR K DIR
     224 ;
     225 S DIR("A")="OK to Delete: "
     226 S DIR("B")="No"
     227 S DIR(0)="YAO"
     228 D ^DIR
     229 I '$G(Y) G DELQ
     230 K DIR
     231 ;
     232 S DA=CAREUNIT
     233 S DIK="^IBA("_355.95_","
     234 D ^DIK
     235 ;
     236 D BLD
     237 ;
     238DELQ S VALMBCK="R"
     239 Q
     240 ;
     241DISPMESS(MESS) ;
     242 N DIR,X,Y
     243 S DIR(0)="EA",DIR("A",1)=MESS
     244 S DIR("A")="PRESS ENTER to continue "
     245 D ^DIR
     246 Q
     247 ;

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCERP3.m

    r613 r623  
    1 IBCERP3 ;ALB/TMP - EDI BATCHES WAITING MORE THAN 1 DAY REPORT ;30-SEP-96
    2         ;;2.0;INTEGRATED BILLING;**137,296,377**;21-MAR-94;Build 23
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5         Q
    6         ;
    7 PENDING ; Report of batches not sent after the day the bills in it were extracted - report entry point
    8         ;
    9         NEW DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT,IBCLM
    10         I '$O(^IBA(364.1,"ASTAT","P",0)) W !!,"There are no batches that are Pending Austin Receipt.",! S DIR(0)="E" D ^DIR K DIR G EX
    11         ;
    12         ; Ask user if they want to include claim level detail
    13         S DIR(0)="Y",DIR("A")="Include Claims in each Batch",DIR("B")="Yes"
    14         W ! D ^DIR K DIR
    15         I $D(DIRUT) G EX
    16         S IBCLM=+Y
    17         ;
    18         D DEVICE
    19 EX      ;
    20         Q
    21         ;
    22 DEVICE  ; selection of device on which to print report
    23         NEW ZTRTN,ZTDESC,ZTSAVE,POP
    24         W !!,"This report is 80 characters wide."
    25         S ZTRTN="COMPILE^IBCERP3"
    26         S ZTDESC="REPORT OF BILL BATCHES WAITING AUSTIN RECEIPT AFTER 1 DAY"
    27         S ZTSAVE("IBCLM")=""
    28         D EN^XUTMDEVQ(ZTRTN,ZTDESC,.ZTSAVE,"QM")
    29 DEVICEX ;
    30         Q
    31         ;
    32 COMPILE ; Queued job entrypoint
    33         N IBBA,IB0,IB1,IEN,IBZ,IBIFN,IB399,CLM,BALDUE,IBSTAT,ARSTAT,IB
    34         ;
    35         K ^TMP($J,"IBSORT")
    36         S IBBA=0
    37         F  S IBBA=$O(^IBA(364.1,"ASTAT","P",IBBA)) Q:'IBBA  D
    38         . I $$BCHCHK^IBCEBUL(IBBA) Q    ; Batch check function
    39         . S IB0=$G(^IBA(364.1,IBBA,0)),IB1=$G(^(1))
    40         . S:$P(IB0,U,7)="" $P(IB0,U,7)="~"
    41         . S ^TMP($J,"IBSORT",$P(IB0,U,7),$P(IB0,U,1),IBBA)=$P(IB1,U,6)_U_$P(IB0,U,4)
    42         . ;
    43         . I 'IBCLM Q   ; include claim data flag
    44         . ;
    45         . ; gather the EDI claim data for this batch
    46         . S IEN=0 F  S IEN=$O(^IBA(364,"C",IBBA,IEN)) Q:'IEN  D
    47         .. S IBZ=$G(^IBA(364,IEN,0)),IBIFN=+IBZ,IB399=$G(^DGCR(399,IBIFN,0))
    48         .. S CLM=$P(IB399,U,1) S:CLM="" CLM="~"
    49         .. S BALDUE=$G(^DGCR(399,IBIFN,"U1")),BALDUE=$P(BALDUE,U,1)-$P(BALDUE,U,2)
    50         .. S IBSTAT=$$EXTERNAL^DILFD(399,.13,,$P(IB399,U,13))
    51         .. S ARSTAT=$$EXTERNAL^DILFD(430,8,,+$P($$BILL^RCJIBFN2(IBIFN),U,2))
    52         .. S IB=$P(IBZ,U,8)_U_BALDUE_U_$P(IBZ,U,3)_U_IBSTAT_U_ARSTAT
    53         .. S ^TMP($J,"IBSORT",$P(IB0,U,7),$P(IB0,U,1),IBBA,CLM,IEN)=IB
    54         .. Q
    55         . Q
    56         ;
    57         D PRINT                         ; print report
    58         D ^%ZISC                        ; close the device
    59         K ^TMP($J,"IBSORT")             ; clean up scratch global
    60         I $D(ZTQUEUED) S ZTREQ="@"      ; purge the task record
    61         ;
    62 COMPX   ;
    63         Q
    64         ;
    65 PRINT   ; print the report to the specified device
    66         ;
    67         NEW CRT,IBPAGE,IBSTOP,IBCT,IBTYP,IBBAT,IBBA,IBV,CLM,IEN,DIR,X,Y,Z
    68         I IOST["C-" S CRT=1
    69         E  S CRT=0
    70         ;
    71         S IBPAGE=0
    72         I '$D(^TMP($J,"IBSORT")) D HDR1 W !,?3,"No batches found Pending Austin Receipt for >1 day."
    73         S (IBSTOP,IBCT)=0
    74         ;
    75         S IBTYP=""
    76         F  S IBTYP=$O(^TMP($J,"IBSORT",IBTYP)) Q:IBTYP=""  D  Q:IBSTOP
    77         . D HDR1
    78         . S IBBAT=""
    79         . F  S IBBAT=$O(^TMP($J,"IBSORT",IBTYP,IBBAT)) Q:'IBBAT!(IBSTOP)  S IBBA=0 F  S IBBA=$O(^TMP($J,"IBSORT",IBTYP,IBBAT,IBBA)) Q:'IBBA!IBSTOP  S IBV=$G(^(IBBA)) D  Q:IBSTOP
    80         .. D:$Y>(IOSL-4) HDR1 Q:IBSTOP
    81         .. W !,?2,IBBAT,?16,$$FMTE^XLFDT($P(IBV,U,1),"5Z"),?42,$P(IBV,U,2)
    82         .. S IBCT=IBCT+1
    83         .. I 'IBCLM Q    ; no claim level detail
    84         .. I $O(^TMP($J,"IBSORT",IBTYP,IBBAT,IBBA,""))="" Q   ; no claim data
    85         .. ;
    86         .. D:$Y>(IOSL-4) HDR1 Q:IBSTOP
    87         .. W !!?5,"Claim",?14,"Seq",?22,"Bal Due",?32,"EDI Stat",?43,"IB Status",?57,"AR Status"
    88         .. S CLM="" F  S CLM=$O(^TMP($J,"IBSORT",IBTYP,IBBAT,IBBA,CLM)) Q:CLM=""!IBSTOP  S IEN=0 F  S IEN=$O(^TMP($J,"IBSORT",IBTYP,IBBAT,IBBA,CLM,IEN)) Q:'IEN!IBSTOP  D  Q:IBSTOP
    89         ... S IBV=$G(^TMP($J,"IBSORT",IBTYP,IBBAT,IBBA,CLM,IEN))
    90         ... D:$Y>(IOSL-4) HDR1 Q:IBSTOP
    91         ... W !,?5,CLM,?15,$P(IBV,U,1),?19,$J($FN($P(IBV,U,2),"",2),10),?35,$P(IBV,U,3),?43,$E($P(IBV,U,4),1,11),?57,$E($P(IBV,U,5),1,16)
    92         ... Q
    93         .. ;
    94         .. Q:IBSTOP
    95         .. D:$Y>(IOSL-4) HDR1 Q:IBSTOP
    96         .. W !
    97         .. Q
    98         . Q
    99         ;
    100         I IBSTOP G PRINTX
    101         D:$Y>(IOSL-4) HDR1 G:IBSTOP PRINTX
    102         W !!,"Total Number of Batches: ",IBCT
    103         D:$Y>(IOSL-4) HDR1 G:IBSTOP PRINTX
    104         W !!?5,"*** End of Report ***"
    105         I CRT,'$D(ZTQUEUED) S DIR(0)="E" D ^DIR K DIR
    106 PRINTX  ;
    107         Q
    108         ;
    109 HDR1    ; Report header
    110         ;
    111         ; if screen output and page# already exists, do a page break
    112         I IBPAGE,CRT D  I IBSTOP G HDR1X
    113         . S DIR(0)="E" D ^DIR K DIR
    114         . I 'Y S IBSTOP=1
    115         . Q
    116         ;
    117         ; if screen output OR page# already exists, do a form feed
    118         I IBPAGE!CRT W @IOF
    119         ;
    120         S IBPAGE=IBPAGE+1
    121         ;
    122         W !,"EDI Batches Pending Austin Receipt After 1 Day",?70,"Page: ",IBPAGE
    123         W !,"Run Date: ",$$FMTE^XLFDT($$NOW^XLFDT,"5Z")
    124         W !!?2,"Batch #",?16,"Transmission Date",?42,"Mail Message #"
    125         S Z="",$P(Z,"-",79)="" W !?1,Z
    126         ;
    127         ; check for a TaskManager stop request
    128         I $D(ZTQUEUED),$$S^%ZTLOAD() D  G HDR1X
    129         . S (ZTSTOP,IBSTOP)=1
    130         . W !!!?5,"*** Report Halted by TaskManager Request ***"
    131         . Q
    132 HDR1X   ;
    133         Q
    134         ;
     1IBCERP3 ;ALB/TMP - EDI BATCHES WAITING MORE THAN 1 DAY REPORT ;30-SEP-96
     2 ;;2.0;INTEGRATED BILLING;**137,296**;21-MAR-94
     3 Q
     4 ;
     5PENDING ;Report of batches not sent after the day the bills in it were extracted
     6 W !
     7 S %ZIS="QM" D ^%ZIS Q:POP
     8 I $D(IO("Q")) K IO("Q") S ZTRTN="EN^IBCERP3",ZTDESC="REPORT OF BILL BATCHES WAITING AUSTIN RECEIPT AFTER 1 DAY" D ^%ZTLOAD K ZTSK D HOME^%ZIS Q
     9 U IO
     10EN ; Queued job entrypoint
     11 N IBPAGE,IBHDRDT,IBLINE,IBSTOP,IBBA,IBBAT,IBCT,IBTYP,IBTYPN,IBV,DIR,Y,IB0,IB1
     12 ;
     13 K ^TMP($J,"IBSORT")
     14 S (IBPAGE,IBBA)=0
     15 ;
     16 ; esg - 5/12/05 - IB*2*296 - Additional check to make sure there are
     17 ;       bills in the batch in file 364 before including it.  Similar to
     18 ;       existing functionality in routine ^IBCEBUL.
     19 ;
     20 F  S IBBA=$O(^IBA(364.1,"ASTAT","P",IBBA)) Q:'IBBA  S IB0=$G(^IBA(364.1,IBBA,0)),IB1=$G(^(1)) I DT-($P(IB1,U,6)\1)'<1,$P(IB0,U,7)'="",$O(^IBA(364,"C",IBBA,0)) S ^TMP($J,"IBSORT",$P(IB0,U,7),$P(IB0,U),IBBA)=$P(IB1,U,6)_U_$P(IB0,U,4)
     21 ;
     22 W:$E(IOST,1,2)["C-" @IOF ;Only initial form feed for print to screen
     23 I '$D(^TMP($J,"IBSORT")) D HDR1("") W !,?3,"No data found for this report"
     24 S (IBSTOP,IBCT)=0
     25 ;
     26 S IBTYP=""
     27 F  S IBTYP=$O(^TMP($J,"IBSORT",IBTYP)) Q:IBTYP=""  D  G:IBSTOP STOP
     28 . S IBTYPN=$$EXPAND^IBTRE(364.1,.07,IBTYP)
     29 . D HDR1(IBTYPN)
     30 . S IBBAT=""
     31 . F  S IBBAT=$O(^TMP($J,"IBSORT",IBTYP,IBBAT)) Q:'IBBAT!(IBSTOP)  S IBBA=0 F  S IBBA=$O(^TMP($J,"IBSORT",IBTYP,IBBAT,IBBA)) Q:'IBBA  S IBV=$G(^(IBBA)) D  Q:IBSTOP
     32 .. D:IBLINE>(IOSL-5) HDR1(IBTYPN) Q:IBSTOP
     33 .. W !,?6,IBBAT,?20,$$FMTE^XLFDT($P(IBV,U),1),?46,$P(IBV,U,2)
     34 .. S IBCT=IBCT+1,IBLINE=IBLINE+1
     35 ;
     36 W !!,"TOTAL # OF BATCHES: ",IBCT
     37 ;
     38 I $E(IOST,1,2)["C-"  K DIR S DIR(0)="E" D ^DIR K DIR
     39STOP I '$D(ZTQUEUED) D ^%ZISC
     40 I $D(ZTQUEUED) S ZTREQ="@"
     41 K ^TMP($J,"IBSORT")
     42 Q
     43 ;
     44HDR1(IB) ; Report header
     45 ; IB = the text for the type of batch
     46 N Z,DIR,Y
     47 I 'IBPAGE S IBHDRDT=$$HTE^XLFDT($H,2)
     48 I IBPAGE D  Q:IBSTOP
     49 . I $E(IOST,1,2)["C-" K DIR S DIR(0)="E" D ^DIR K DIR S IBSTOP=('Y) Q:IBSTOP
     50 . W @IOF
     51 S IBPAGE=IBPAGE+1
     52 W !,?14,"REPORT OF BATCHES STILL WAITING AUSTIN RECEIPT AFTER 1 DAY",?70,"PAGE: ",IBPAGE,!,?((68-$L(IB))\2),"BATCH TYPE: "_IB
     53 W !,?26,"RUN DATE: ",IBHDRDT,!
     54 W !,?6,"BATCH #",?20,"WAITING SINCE",?46,"MAIL MESSAGE #",!
     55 S Z="",$P(Z,"-",76)="" W ?2,Z,!
     56 S IBLINE=6
     57 Q
     58 ;

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEST.m

    r613 r623  
    1 IBCEST  ;ALB/TMP - 837 EDI STATUS MESSAGE PROCESSING ;17-APR-96
    2         ;;2.0;INTEGRATED BILLING;**137,189,197,135,283,320,368,397**;21-MAR-94;Build 3
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ; IA 4043 for call to AUDITX^PRCAUDT
    5         Q
    6         ;
    7 UPD361(IBTDA)   ; Update IB BILL STATUS MESSAGES file
    8         ; IBTDA = ien of return message in file 364.2
    9         ;
    10         N IB,IB0,IBSEQ,IB00,IBBILL,IBBTCH,IBMNUM
    11         ;
    12         I '$$LOCK^IBCEM(IBTDA) G UPDQ ;Lock message in file 364.2
    13         ;
    14         S IB0=$G(^IBA(364.2,IBTDA,0))
    15         S IBMNUM=$P(IB0,U) ; Message number
    16         S IB00=$G(^IBA(364,+$P(IB0,U,5),0)) ; Transmit bill entry
    17         S IBBILL=+IB00 ; Actual bill ien in file 399
    18         S IBBTCH=$P(IB0,U,4) ; Batch #
    19         ;
    20         ; Auto-audit bills based on status code on '10' record of status msg
    21         ; flat file
    22         I IBBILL,$P($T(PRCAUDT+1^PRCAUDT),"**",2)[",173" D
    23         . N Z,Z0,Z1,OK
    24         . Q:+$$STA^PRCAFN(IBBILL)'=104
    25         . S (Z,OK)=0
    26         . F  S Z=$O(^IBA(364.2,IBTDA,2,Z)) Q:'Z  S Z0=$P($G(^(Z,0)),"##RAW DATA: ",2) I +Z0=10 S Z0=$P(Z0,U,5) D  Q:OK
    27         .. ; Strip leading spaces
    28         .. S Z0=$$TRIM^XLFSTR(Z0)
    29         .. Q:Z0=""
    30         .. I $$SCODE^IBCEST1(Z0),$P($G(^DGCR(399.3,+$P($G(^DGCR(399,IBBILL,0)),U,7),0)),U,11) D AUDITX^PRCAUDT(IBBILL) S OK=1 ; IA 4043
    31         ;
    32         I $S(IBMNUM="":1,1:'IBBILL&(IBBTCH="")) D DELMSG^IBCESRV2(IBTDA) G UPDQ
    33         ;
    34         ; Individual bill
    35         I IBBILL D  G UPDQ
    36         . N IBA1,IBMSG0,IBPID
    37         . S IBPID="",IBA1=0
    38         . F  S IBA1=$O(^IBA(364.2,IBTDA,2,IBA1)) Q:'IBA1  S IBMSG0=$P($G(^(IBA1,0)),"##RAW DATA: ",2) I +IBMSG0=277,$P(IBMSG0,U,5)="N" S IBPID=$P(IBMSG0,U,11) Q
    39         . S IBSEQ=$P(IB00,U,8) S:IBSEQ="" IBSEQ="P"
    40         . D STORE(IB0,IBBTCH,IBMNUM,IBTDA,IBBILL,IBSEQ,IBPID,1)
    41         ;
    42         ; Batch - update each bill separately
    43         S IBBILL=""
    44         F  S IBBILL=$O(^IBA(364,"ABABI",+IBBTCH,IBBILL)) Q:'IBBILL  D
    45         . Q:$D(^TMP("IBCONF",$J,IBBILL))  ;Bill was rejected
    46         . S IB=$O(^IBA(364,"ABABI",+IBBTCH,IBBILL,0)) Q:'IB
    47         . S IBSEQ=$P($G(^IBA(364,IB,0)),U,8) S:IBSEQ="" IBSEQ="P"
    48         . D STORE(IB0,IBBTCH,IBMNUM,IBTDA,IBBILL,IBSEQ,"",0)
    49         ;
    50         Q
    51         ;
    52 STORE(IB0,IBBTCH,IBMNUM,IBTDA,IBBILL,IBSEQ,IBPID,IB1)   ;
    53         ;
    54         ; IB0 = 0-node of message in file 364.2
    55         ; IBBTCH = ien of batch in file 364.1
    56         ; IBMNUM = actual message number
    57         ; IBTDA = ien of message in file 364.2
    58         ; IBBILL = ien of bill in 399
    59         ; IBSEQ = P/S/T/ for COB sequence related to message
    60         ; IBPID = the payer id returned from clearinghouse for the claim
    61         ; IB1 = flag that says if the message was for a single bill or a batch.
    62         ;       Batch statuses have an additional standard text entry.
    63         ;       1 = single bill 0 = batch
    64         ;
    65         N DA,DIK,DIE,DIC,X,Y,DR,DO,DD,DLAYGO,Z,Z0,Z1,Z2,Z3,IBT,IBDUP,IBFLDS,IBY,IBAUTO,IBLN
    66         ;
    67         S X=IBBILL,IBDUP=0
    68         ;
    69         I $D(^IBM(361,"AC",IBMNUM\1)) D  ; Message already there for bill
    70         . S Z=0 F  S Z=$O(^IBM(361,"AC",IBMNUM\1,Z)) Q:'Z  I +$G(^IBM(361,Z,0))=IBBILL S IBDUP=Z Q
    71         ;
    72         S IBFLDS=".02////"_$P(IB0,U,3)
    73         S IBFLDS=IBFLDS_";.03////"_$S($$EXTERNAL^DILFD(364.2,.02,"U",$P(IB0,U,2))["REJ":"R",1:"I")_";.05////"_IBBTCH_";.06////"_IBMNUM_";.04////"_+$P(IB0,U,8)_";.07////"_IBSEQ_$S($P(IB0,U,5):";.11////"_$P(IB0,U,5),1:"")
    74         S IBFLDS=IBFLDS_";.12////"_$P(IB0,U,10)_";.09////0"
    75         S IBFLDS=IBFLDS_";.15////"_$$CHKSUM^IBCEST1("^IBA(364.2,"_IBTDA_",2)")
    76         I IBPID'="" D
    77         . S IBPID("TYPE")=$S($$FT^IBCEF(IBBILL)=2:"P",1:"I")
    78         . D UPDINS(.IBPID,$$POLICY^IBCEF(IBBILL,1,$TR(IBSEQ,"PST","123")),IBBILL)
    79         ;
    80         I IBDUP D  I $D(Y) G UPDQ
    81         . ; Stuff fields into existing entry
    82         . ; (may be needed for reprocessing of aborted updates)
    83         . S DIE="^IBM(361,",DA=IBDUP,DR=IBFLDS_";1///@"
    84         . D ^DIE
    85         . I $D(Y) S IBY=-1 Q  ;Update not successful
    86         . S IBY=IBDUP
    87         ;
    88         K IBT
    89         I 'IBDUP D  ; Create new entry and stuff fields
    90         . S DIC(0)="L",DIC="^IBM(361,",DLAYGO=361
    91         . S DIC("DR")=IBFLDS
    92         . D FILE^DICN
    93         . K DO,DD,DLAYGO,DIC
    94         . S IBY=+Y
    95         . Q:IBY'>0
    96         . ;
    97         . ; IB*2*320 - Check for duplicate status message
    98         . NEW IBNEW,IBOLD,PCE,Z,DIK,DA
    99         . S IBNEW=""
    100         . F PCE=3,4,5,7,8,11,15 S IBNEW=IBNEW_$P($G(^IBM(361,IBY,0)),U,PCE)_U
    101         . S Z=0
    102         . F  S Z=$O(^IBM(361,"B",IBBILL,Z)) Q:'Z  I Z'=IBY D  Q:IBY'>0
    103         .. S IBOLD=""
    104         .. F PCE=3,4,5,7,8,11,15 S IBOLD=IBOLD_$P($G(^IBM(361,Z,0)),U,PCE)_U
    105         .. I IBNEW'=IBOLD Q   ; no duplicate so get the next one
    106         .. S DIK="^IBM(361,",DA=IBY,IBY=-1 D ^DIK D DELMSG^IBCESRV2(IBTDA)
    107         .. Q
    108         . Q
    109         ;
    110         I IBY>0 D  ;Move text over
    111         . K IBT
    112         . ;
    113         . D BLDMSG(IB1,IBTDA,.IBT,.IBAUTO)
    114         . ;
    115         . ; IB*2*368 - ymg - 2Q,RE,RP messages will be filed as informational
    116         . ; Z0 is the flag for 2Q code
    117         . ; Z1 is the flag for RE code
    118         . ; Z2 is the flag for RP code
    119         . ; Z3 is the flag for autofiling the message
    120         . I $P($G(^IBM(361,+IBY,0)),U,3)="R" D
    121         .. S Z="",(Z0,Z1,Z2,Z3)=0 F  S Z=$O(IBT(Z)) Q:Z=""!(Z3=1)  D
    122         ... S IBLN=$$UP^XLFSTR($G(IBT(Z)))
    123         ... I (Z0!Z1!Z2)=0 D
    124         .... S:IBLN?.E1"CODE:".P1"2Q".E Z0=1
    125         .... S:IBLN?.E1"CODE:".P1"RE".E Z1=1
    126         .... S:IBLN?.E1"CODE:".P1"RP".E Z2=1
    127         ... I Z0=1 S:IBLN?.P1"CLAIM".P1"REJECTED".P1"BY".P1"CLEARINGHOUSE".E Z3=1
    128         ... I Z1=1 S:IBLN?.P1"ELECTRONIC".P1"CLAIM".P1"REJECTED".P1"BY".P1"EMDEON".E Z3=1
    129         ... I Z2=1 S:IBLN?.P1"PAPER".P1"CLAIM".P1"REJECTED".P1"BY".P1"EMDEON".E Z3=1
    130         .. I Z3=1 S IBAUTO=1,DIE=361,DA=+IBY,DR=".03////I" D ^DIE
    131         .. Q
    132         . ;
    133         . ; if info msg, ck for no review needed based on first line of text
    134         . I $G(IBAUTO),$P($G(^IBM(361,+IBY,0)),U,3)="I" D
    135         .. S DIE="^IBM(361,",DR=".09////2;.14////1;.1////F",DA=+IBY D ^DIE
    136         .. I IB1,$P($G(^IBM(361,+IBY,0)),U,11) S Z="",Z0=0 F  S Z=$O(IBT(Z)) Q:Z=""!(Z0=1)  D
    137         ... S Z0=$$PRINTUPD^IBCEU0($$UP^XLFSTR($G(IBT(Z))),$P($G(^IBM(361,+IBY,0)),U,11))
    138         . ;
    139         . D MSGLNSZ(.IBT) ; Convert Message Lines in IBT to be no longer than 70 chars
    140         . D WP^DIE(361,+IBY_",",1,"A","IBT")    ; file message text
    141         . ;
    142         . ; Delete message after it successfully updates the database.
    143         . D DELMSG^IBCESRV2(IBTDA)
    144         . Q
    145         ;
    146 UPDQ    L -^IBA(364.2,IBTDA,0)
    147         Q
    148         ;
    149 BLDMSG(IB1,IBTDA,IBT,IBAUTO)    ; Builds message text
    150         ; IB1 = flag for batch message
    151         ; IBTDA = ien of entry in file 364.2
    152         ; IBT = array returned with message text
    153         ; IBAUTO = if passed by reference, returns 1 if text indicates review
    154         ;          not needed
    155         N IBDATA,IBCK,IBZ,IBZ0,IBZ1,Z
    156         S (IBZ,IBZ0,IBDATA,IBAUTO,IBCK)=0
    157         I 'IB1 S IBT(1)="Status message received for batch "_$P($G(^IBA(364.1,IBBTCH,0)),U)_" dated "_$$FMTE^XLFDT($P($G(^IBA(364.2,IBTDA,0)),U,10),2),IBZ0=1
    158         ; Don't move the raw data over, just move the text of the message
    159         F  S IBZ=$O(^IBA(364.2,IBTDA,2,IBZ)) Q:'IBZ  S IBZ1=$G(^(IBZ,0)) S IBDATA=($E(IBZ1,1,2)="##") Q:IBDATA  S IBZ0=IBZ0+1,IBT(IBZ0)=IBZ1 I 'IBCK S Z=$$CKREVU^IBCEM4(IBZ1,,,.IBCK),IBAUTO=$S(IBCK:0,Z:1,1:IBAUTO)
    160         Q
    161         ;
    162 UPDINS(IBPID,IBINS,IBIFN)       ; Update the insurance id or the bill printed at
    163         ;    the EDI contractor's print shop and mailed to the ins co.
    164         ; IBPID = the id returned from the EDI contractor for the ins co
    165         ;      ("TYPE") = P if professional id or I if institutional id
    166         ; IBINS = the ien of the insurance co it was sent to (file 36)
    167         ; IBIFN = the ien of the claim (file 399)
    168         ;
    169         N IBID,IBIDFLD,IBPRT,IBLOOK,DA,DR,DIE,X,Y,Z
    170         ;
    171         Q:'$G(IBINS)!($G(IBPID)="")
    172         ;
    173         ; Strip spaces off the end of data
    174         S IBLOOK=""
    175         I $L(IBPID) F Z=$L(IBPID):-1:1 I $E(IBPID,Z)'=" " S IBLOOK=$E(IBPID,1,Z) Q
    176         ;
    177         S IBPRT=($E(IBLOOK,2,5)="PRNT")
    178         I IBPRT D  ; Set printed via EDI field on bill
    179         . S DA=IBIFN,DIE="^DGCR(399,",DR="26////1" D ^DIE
    180         ;
    181         S IBLOOK=$E($S('IBPRT:$P(IBLOOK,"PAYID=",2),1:""),1,5)
    182         Q:IBLOOK=""!($E(IBLOOK,2,5)="PRNT")
    183         S IBIDFLD="3.0"_$S($G(IBPID("TYPE"))="I":4,1:2)
    184         S IBID=$P($G(^DIC(36,+IBINS,3)),U,IBIDFLD*100#100)
    185         Q:IBID=IBLOOK
    186         I IBID="" D  G UPDINSQ ; Update insurance co electronic id # if blank
    187         . S DIE="^DIC(36,",DR=IBIDFLD_"////"_IBLOOK,DA=IBINS D ^DIE
    188         I IBID'="",IBLOOK'="" D  ; Bulletin that the id on file and id returned
    189         . ; are different
    190         . N XMTO,XMDUZ,XMBODY,IBXM,XMSUBJ,XMZ
    191         . S XMTO("I:G.IB EDI")=""
    192         . S XMDUZ="",XMBODY="IBXM",XMSUBJ="PAYER ID RETURNED IS DIFFERENT THAN PAYER ID ON FILE"
    193         . S IBXM(1)="BILL #     : "_$P($G(^DGCR(399,IBIFN,0)),U)
    194         . S IBXM(2)="PAYER      : "_$P($G(^DIC(36,+IBINS,0)),U)
    195         . S IBXM(3)="BILL TYPE  : "_$S($G(IBPID("TYPE"))="I":"INSTITUT",1:"PROFESS")_"IONAL"
    196         . S IBXM(4)="ID ON FILE : "_IBID
    197         . S IBXM(5)="ID RETURNED: "_IBLOOK
    198         . S IBXM(6)=" ",IBXM(7)="   Please determine which id number is correct and correct the id in the",IBXM(8)="insurance file for this payer, if needed"
    199         . D SENDMSG^XMXAPI(XMDUZ,XMSUBJ,XMBODY,.XMTO,,.XMZ)
    200         ;
    201 UPDINSQ Q
    202         ;
    203 MSGLNSZ(MSG)    ; Change Input Message Lines to be no more than 70 characters long each
    204         ;
    205         ; Input/Output:   MSG  - array of Input Message Lines; this is also the Output Message
    206         ; which is an array of Converted Message Lines (with lines no more than 70 chars each)
    207         ;
    208         N LN,XARY,XARYLN,CNT,OUTMSG,TMPMSG,LDNGSP,LDNGSPN
    209         S LN="",CNT=0 F  S LN=$O(MSG(LN)) Q:LN=""  D  ;
    210         . ; Find any leading spaces in original message line,
    211         . ; to be used if line got split below
    212         . S TMPMSG=$$TRIM^XLFSTR(MSG(LN),"L"," ")  ;Trim Leading Spaces
    213         . S LDNGSP=$P(MSG(LN),TMPMSG,1)  ;get leading spaces if any
    214         . S LDNGSPN=$L(LDNGSP) S:LDNGSPN>30 LDNGSP=$E(LDNGSP,1,30) ;make sure there are no more than 30 leading spaces
    215         . ; Converts a single line to multiple lines with a maximum width of 70 each
    216         . ; If line is 70 chars or less, this call returns the exact line
    217         . K XARY D FSTRNG^IBJU1(TMPMSG,70-LDNGSPN,.XARY)
    218         . ; Scan lines and merge them into the final output array (OUTMSG)
    219         . ; On lines 2 and higher, add Leading Spaces found above, if any.
    220         . S XARYLN="" F  S XARYLN=$O(XARY(XARYLN)) Q:XARYLN=""  S CNT=CNT+1,OUTMSG(CNT)=LDNGSP_XARY(XARYLN)
    221         ;
    222         ; Move the final Message Lines (OUTMSG) into MSG array to be returned
    223         K MSG M MSG=OUTMSG
    224         Q
    225         ;
     1IBCEST ;ALB/TMP - 837 EDI STATUS MESSAGE PROCESSING ;17-APR-96
     2 ;;2.0;INTEGRATED BILLING;**137,189,197,135,283,320**;21-MAR-94
     3 ; IA 4042 for call to AUDITX^PRCAUDT
     4 Q
     5 ;
     6UPD361(IBTDA) ; Update IB BILL STATUS MESSAGES file
     7 ; IBTDA = ien of return message in file 364.2
     8 ;
     9 N IB,IB0,IBSEQ,IB00,IBBILL,IBBTCH,IBMNUM
     10 ;
     11 I '$$LOCK^IBCEM(IBTDA) G UPDQ ;Lock message in file 364.2
     12 ;
     13 S IB0=$G(^IBA(364.2,IBTDA,0))
     14 S IBMNUM=$P(IB0,U) ; Message number
     15 S IB00=$G(^IBA(364,+$P(IB0,U,5),0)) ; Transmit bill entry
     16 S IBBILL=+IB00 ; Actual bill ien in file 399
     17 S IBBTCH=$P(IB0,U,4) ; Batch #
     18 ;
     19 ; Auto-audit bills based on status code on '10' record of status msg
     20 ; flat file
     21 I IBBILL,$P($T(PRCAUDT+1^PRCAUDT),"**",2)[",173" D
     22 . N Z,Z0,Z1,OK
     23 . Q:+$$STA^PRCAFN(IBBILL)'=104
     24 . S (Z,OK)=0
     25 . F  S Z=$O(^IBA(364.2,IBTDA,2,Z)) Q:'Z  S Z0=$P($G(^(Z,0)),"##RAW DATA: ",2) I +Z0=10 S Z0=$P(Z0,U,5) D  Q:OK
     26 .. ; Strip leading spaces
     27 .. F  S Z0=$P(Z0," ",2,99) Q:$E(Z0)'=" "
     28 .. Q:Z0=""
     29 .. I "A3^AC^A7^A8^AA^2P^10^11"[Z0,$P($G(^DGCR(399.3,+$P($G(^DGCR(399,IBBILL,0)),U,7),0)),U,11) D AUDITX^PRCAUDT(IBBILL) S OK=1 ; IA 4042
     30 ;
     31 I $S(IBMNUM="":1,1:'IBBILL&(IBBTCH="")) D DELMSG^IBCESRV2(IBTDA) G UPDQ
     32 ;
     33 ; Individual bill
     34 I IBBILL D  G UPDQ
     35 . N IBA1,IBMSG0,IBPID
     36 . S IBPID="",IBA1=0
     37 . F  S IBA1=$O(^IBA(364.2,IBTDA,2,IBA1)) Q:'IBA1  S IBMSG0=$P($G(^(IBA1,0)),"##RAW DATA: ",2) I +IBMSG0=277,$P(IBMSG0,U,5)="N" S IBPID=$P(IBMSG0,U,11) Q
     38 . S IBSEQ=$P(IB00,U,8) S:IBSEQ="" IBSEQ="P"
     39 . D STORE(IB0,IBBTCH,IBMNUM,IBTDA,IBBILL,IBSEQ,IBPID,1)
     40 ;
     41 ; Batch - update each bill separately
     42 S IBBILL=""
     43 F  S IBBILL=$O(^IBA(364,"ABABI",+IBBTCH,IBBILL)) Q:'IBBILL  D
     44 . Q:$D(^TMP("IBCONF",$J,IBBILL))  ;Bill was rejected
     45 . S IB=$O(^IBA(364,"ABABI",+IBBTCH,IBBILL,0)) Q:'IB
     46 . S IBSEQ=$P($G(^IBA(364,IB,0)),U,8) S:IBSEQ="" IBSEQ="P"
     47 . D STORE(IB0,IBBTCH,IBMNUM,IBTDA,IBBILL,IBSEQ,"",0)
     48 ;
     49 Q
     50 ;
     51STORE(IB0,IBBTCH,IBMNUM,IBTDA,IBBILL,IBSEQ,IBPID,IB1) ;
     52 ;
     53 ; IB0 = 0-node of message in file 364.2
     54 ; IBBTCH = ien of batch in file 364.1
     55 ; IBMNUM = actual message number
     56 ; IBTDA = ien of message in file 364.2
     57 ; IBBILL = ien of bill in 399
     58 ; IBSEQ = P/S/T/ for COB sequence related to message
     59 ; IBPID = the payer id returned from clearinghouse for the claim
     60 ; IB1 = flag that says if the message was for a single bill or a batch.
     61 ;       Batch statuses have an additional standard text entry.
     62 ;       1 = single bill 0 = batch
     63 ;
     64 N DA,DIK,DIE,DIC,X,Y,DR,DO,DD,DLAYGO,Z,Z0,Z1,IBT,IBDUP,IBFLDS,IBY,IBAUTO
     65 ;
     66 S X=IBBILL,IBDUP=0
     67 ;
     68 I $D(^IBM(361,"AC",IBMNUM\1)) D  ; Message already there for bill
     69 . S Z=0 F  S Z=$O(^IBM(361,"AC",IBMNUM\1,Z)) Q:'Z  I +$G(^IBM(361,Z,0))=IBBILL S IBDUP=Z Q
     70 ;
     71 S IBFLDS=".02////"_$P(IB0,U,3)
     72 S IBFLDS=IBFLDS_";.03////"_$S($$EXTERNAL^DILFD(364.2,.02,"U",$P(IB0,U,2))["REJ":"R",1:"I")_";.05////"_IBBTCH_";.06////"_IBMNUM_";.04////"_+$P(IB0,U,8)_";.07////"_IBSEQ_$S($P(IB0,U,5):";.11////"_$P(IB0,U,5),1:"")
     73 S IBFLDS=IBFLDS_";.12////"_$P(IB0,U,10)_";.09////0"
     74 S IBFLDS=IBFLDS_";.15////"_$$CHKSUM^IBCEST1("^IBA(364.2,"_IBTDA_",2)")
     75 I IBPID'="" D
     76 . S IBPID("TYPE")=$S($$FT^IBCEF(IBBILL)=2:"P",1:"I")
     77 . D UPDINS(.IBPID,$$POLICY^IBCEF(IBBILL,1,$TR(IBSEQ,"PST","123")),IBBILL)
     78 ;
     79 I IBDUP D  I $D(Y) G UPDQ
     80 . ; Stuff fields into existing entry
     81 . ; (may be needed for reprocessing of aborted updates)
     82 . S DIE="^IBM(361,",DA=IBDUP,DR=IBFLDS_";1///@"
     83 . D ^DIE
     84 . I $D(Y) S IBY=-1 Q  ;Update not successful
     85 . S IBY=IBDUP
     86 ;
     87 K IBT
     88 I 'IBDUP D  ; Create new entry and stuff fields
     89 . S DIC(0)="L",DIC="^IBM(361,",DLAYGO=361
     90 . S DIC("DR")=IBFLDS
     91 . D FILE^DICN
     92 . K DO,DD,DLAYGO,DIC
     93 . S IBY=+Y
     94 . Q:IBY'>0
     95 . ;
     96 . ; IB*2*320 - Check for duplicate status message
     97 . NEW IBNEW,IBOLD,PCE,Z,DIK,DA
     98 . S IBNEW=""
     99 . F PCE=3,4,5,7,8,11,15 S IBNEW=IBNEW_$P($G(^IBM(361,IBY,0)),U,PCE)_U
     100 . S Z=0
     101 . F  S Z=$O(^IBM(361,"B",IBBILL,Z)) Q:'Z  I Z'=IBY D  Q:IBY'>0
     102 .. S IBOLD=""
     103 .. F PCE=3,4,5,7,8,11,15 S IBOLD=IBOLD_$P($G(^IBM(361,Z,0)),U,PCE)_U
     104 .. I IBNEW'=IBOLD Q   ; no duplicate so get the next one
     105 .. S DIK="^IBM(361,",DA=IBY,IBY=-1 D ^DIK D DELMSG^IBCESRV2(IBTDA)
     106 .. Q
     107 . Q
     108 ;
     109 I IBY>0 D  ;Move text over
     110 . K IBT
     111 . ;
     112 . D BLDMSG(IB1,IBTDA,.IBT,.IBAUTO)
     113 . ;
     114 . ; IB*2*320 - esg - 2Q messages will be filed as informational
     115 . I $P($G(^IBM(361,+IBY,0)),U,3)="R",$G(IBT(1))["2Q  CLAIM REJECTED BY CLEARINGHOUSE" D
     116 .. S IBAUTO=1
     117 .. S DIE=361,DA=+IBY,DR=".03////I" D ^DIE
     118 .. Q
     119 . ;
     120 . ; if info msg, ck for no review needed based on first line of text
     121 . I $G(IBAUTO),$P($G(^IBM(361,+IBY,0)),U,3)="I" D
     122 .. S DIE="^IBM(361,",DR=".09////2;.14////1;.1////F",DA=+IBY D ^DIE
     123 .. I IB1,$P($G(^IBM(361,+IBY,0)),U,11),$$PRINTUPD^IBCEU0($G(IBT(1)),$P($G(^IBM(361,+IBY,0)),U,11))
     124 . ;
     125 . D WP^DIE(361,+IBY_",",1,"A","IBT")    ; file message text
     126 . ;
     127 . ; Delete message after it successfully updates the database.
     128 . D DELMSG^IBCESRV2(IBTDA)
     129 . Q
     130 ;
     131UPDQ L -^IBA(364.2,IBTDA,0)
     132 Q
     133 ;
     134BLDMSG(IB1,IBTDA,IBT,IBAUTO) ; Builds message text
     135 ; IB1 = flag for batch message
     136 ; IBTDA = ien of entry in file 364.2
     137 ; IBT = array returned with message text
     138 ; IBAUTO = if passed by reference, returns 1 if text indicates review
     139 ;          not needed
     140 N IBDATA,IBCK,IBZ,IBZ0,IBZ1,Z
     141 S (IBZ,IBZ0,IBDATA,IBAUTO,IBCK)=0
     142 I 'IB1 S IBT(1)="Status message received for batch "_$P($G(^IBA(364.1,IBBTCH,0)),U)_" dated "_$$FMTE^XLFDT($P($G(^IBA(364.2,IBTDA,0)),U,10),2),IBZ0=1
     143 ; Don't move the raw data over, just move the text of the message
     144 F  S IBZ=$O(^IBA(364.2,IBTDA,2,IBZ)) Q:'IBZ  S IBZ1=$G(^(IBZ,0)) S IBDATA=($E(IBZ1,1,2)="##") Q:IBDATA  S IBZ0=IBZ0+1,IBT(IBZ0)=IBZ1 I 'IBCK S Z=$$CKREVU^IBCEM4(IBZ1,,,.IBCK),IBAUTO=$S(IBCK:0,Z:1,1:IBAUTO)
     145 ;
     146 ; Convert Message Lines in IBT to be no longer than 70 chars
     147 D MSGLNSZ(.IBT)
     148 Q
     149 ;
     150UPDINS(IBPID,IBINS,IBIFN) ; Update the insurance id or the bill printed at
     151 ;    the EDI contractor's print shop and mailed to the ins co.
     152 ; IBPID = the id returned from the EDI contractor for the ins co
     153 ;      ("TYPE") = P if professional id or I if institutional id
     154 ; IBINS = the ien of the insurance co it was sent to (file 36)
     155 ; IBIFN = the ien of the claim (file 399)
     156 ;
     157 N IBID,IBIDFLD,IBPRT,IBLOOK,DA,DR,DIE,X,Y,Z
     158 ;
     159 Q:'$G(IBINS)!($G(IBPID)="")
     160 ;
     161 ; Strip spaces off the end of data
     162 S IBLOOK=""
     163 I $L(IBPID) F Z=$L(IBPID):-1:1 I $E(IBPID,Z)'=" " S IBLOOK=$E(IBPID,1,Z) Q
     164 ;
     165 S IBPRT=($E(IBLOOK,2,5)="PRNT")
     166 I IBPRT D  ; Set printed via EDI field on bill
     167 . S DA=IBIFN,DIE="^DGCR(399,",DR="26////1" D ^DIE
     168 ;
     169 S IBLOOK=$E($S('IBPRT:$P(IBLOOK,"PAYID=",2),1:""),1,5)
     170 Q:IBLOOK=""!($E(IBLOOK,2,5)="PRNT")
     171 S IBIDFLD="3.0"_$S($G(IBPID("TYPE"))="I":4,1:2)
     172 S IBID=$P($G(^DIC(36,+IBINS,3)),U,IBIDFLD*100#100)
     173 Q:IBID=IBLOOK
     174 I IBID="" D  G UPDINSQ ; Update insurance co electronic id # if blank
     175 . S DIE="^DIC(36,",DR=IBIDFLD_"////"_IBLOOK,DA=IBINS D ^DIE
     176 I IBID'="",IBLOOK'="" D  ; Bulletin that the id on file and id returned
     177 . ; are different
     178 . N XMTO,XMDUZ,XMBODY,IBXM,XMSUBJ,XMZ
     179 . S XMTO("I:G.IB EDI")=""
     180 . S XMDUZ="",XMBODY="IBXM",XMSUBJ="PAYER ID RETURNED IS DIFFERENT THAN PAYER ID ON FILE"
     181 . S IBXM(1)="BILL #     : "_$P($G(^DGCR(399,IBIFN,0)),U)
     182 . S IBXM(2)="PAYER      : "_$P($G(^DIC(36,+IBINS,0)),U)
     183 . S IBXM(3)="BILL TYPE  : "_$S($G(IBPID("TYPE"))="I":"INSTITUT",1:"PROFESS")_"IONAL"
     184 . S IBXM(4)="ID ON FILE : "_IBID
     185 . S IBXM(5)="ID RETURNED: "_IBLOOK
     186 . S IBXM(6)=" ",IBXM(7)="   Please determine which id number is correct and correct the id in the",IBXM(8)="insurance file for this payer, if needed"
     187 . D SENDMSG^XMXAPI(XMDUZ,XMSUBJ,XMBODY,.XMTO,,.XMZ)
     188 ;
     189UPDINSQ Q
     190 ;
     191MSGLNSZ(MSG) ; Change Input Message Lines to be no more than 70 characters long each
     192 ;
     193 ; Input/Output:   MSG  - array of Input Message Lines; this is also the Output Message
     194 ; which is an array of Converted Message Lines (with lines no more than 70 chars each)
     195 ;
     196 N LN,XARY,XARYLN,CNT,OUTMSG,TMPMSG,LDNGSP
     197 S LN="",CNT=0
     198 F  S LN=$O(MSG(LN)) Q:LN=""  D  ;
     199 . ;
     200 . ; Find any leading spaces in original message line,
     201 . ; to be used if line got split below
     202 . S TMPMSG=$$TRIM^XLFSTR(MSG(LN),"L"," ")  ;Trim Leading Spaces
     203 . S LDNGSP=$P(MSG(LN),TMPMSG,1)  ;get leading spaces if any
     204 . ;
     205 . ; Converts a single line to multiple lines with a maximum width of 70 each
     206 . ; If line is 70 chars or less, this call returns the exact line
     207 . K XARY D FSTRNG^IBJU1(MSG(LN),70,.XARY)
     208 . ;
     209 . ; Scan lines and merge them into the final output array (OUTMSG)
     210 . ; On lines 2 and higher, add Leading Spaces found above, if any.
     211 . S XARYLN=""
     212 . F  S XARYLN=$O(XARY(XARYLN)) Q:XARYLN=""  S CNT=CNT+1,OUTMSG(CNT)=$S(XARYLN=1:XARY(XARYLN),1:LDNGSP_XARY(XARYLN))
     213 ;
     214 ; Move the final Message Lines (OUTMSG) into MSG array to be returned
     215 K MSG M MSG=OUTMSG
     216 Q  ;MSGLNSZ
     217 ;

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEST1.m

    r613 r623  
    1 IBCEST1 ;ALB/ESG - IB 837 EDI Status Message Processing Cont ;18-JUL-2005
    2         ;;2.0;INTEGRATED BILLING;**320,397**;21-MAR-94;Build 3
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5         Q
    6         ;
    7 CHKSUM(IBARRAY) ; Incoming 277STAT status message checksum calculation
    8         ; This function calculates the checksum of the raw 277stat data from
    9         ; the data in array IBARRAY.  This is done to prevent duplicates.
    10         ; Input parameter IBARRAY is the array reference where the data exists
    11         ;    at @IBARRAY@(n,0) where n is a sequential #
    12         ; For file 364.2, IBARRAY = "^IBA(364.2,IBTDA,2)" where IBTDA = the ien
    13         ;    of the entry in file 364.2 being evaluated
    14         ;
    15         NEW Y,LN,DATA,IBREC,POS,STSFLG
    16         S Y=0,STSFLG=0
    17         S LN=0
    18         F  S LN=$O(@IBARRAY@(LN)) Q:'LN  D
    19         . S DATA=$$EXT($G(@IBARRAY@(LN,0))) Q:DATA=""
    20         . S IBREC=$P(DATA,U,1)
    21         . I IBREC="277STAT" S STSFLG=1 Q      ; set the STS flag
    22         . I IBREC<1 Q             ; rec# too low
    23         . I IBREC'<99 Q           ; rec# too high
    24         . F POS=1:1:$L(DATA) S Y=Y+($A(DATA,POS)*POS)
    25         . Q
    26         ;
    27         I 'STSFLG S Y=0   ; if this array is not a 277stat message
    28         Q Y
    29         ;
    30 EXT(DATA)       ; Extracts from the text in DATA if the text contains
    31         ;  "##RAW DATA: "
    32         Q $S(DATA["##RAW DATA: ":$P(DATA,"##RAW DATA: ",2,99),1:DATA)
    33         ;
    34 SCODE(Z0)       ; status code for message
    35         N IBFD,IBI,IBRD S IBFD=0
    36         F IBI=1:1 S IBRD=$P($T(CODE+IBI),";;",2,999) Q:IBRD=""!IBFD  D
    37         . I IBRD[Z0 S IBFD=1
    38         Q IBFD
    39         ;
    40 CODE    ; *397
    41         ;;A3^AC^A7^A8^AA^2P^10^11
    42         ;;19^20^21^30^40^221^960^1AE^1AF^1AG^1AI^1AJ^1AK^1AL^1AS^1BS^1BV^1BY
    43         ;;2B^2D^2H^2M^2U^3A^3C^3E^3F^3G^3I^3K^3L^3N^3P^3S
    44         ;;4B^4C^4D^4E^4H^4I^4J^4P^4S^4T^4U^4X^4Y^7A^7D^7I^7U^7V
    45         ;;A0^A9^ACCEPT^ACCEPTED^AE^AP^APPROVE^C01^CI^CP^CTRL!99001^INQUIRY
    46         ;;OA7^OAH^OAI^OAK^OAT^OAV^OAY^OAZ^OB9^OBX^OCU^PG^PN5
    47         ;;TE^W!00000117^Z3^ZAI^ZAN
    48         ;
     1IBCEST1 ;ALB/ESG - IB 837 EDI Status Message Processing Cont ;18-JUL-2005
     2 ;;2.0;INTEGRATED BILLING;**320**;21-MAR-94
     3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
     4 ;
     5 Q
     6 ;
     7CHKSUM(IBARRAY) ; Incoming 277STAT status message checksum calculation
     8 ; This function calculates the checksum of the raw 277stat data from
     9 ; the data in array IBARRAY.  This is done to prevent duplicates.
     10 ; Input parameter IBARRAY is the array reference where the data exists
     11 ;    at @IBARRAY@(n,0) where n is a sequential #
     12 ; For file 364.2, IBARRAY = "^IBA(364.2,IBTDA,2)" where IBTDA = the ien
     13 ;    of the entry in file 364.2 being evaluated
     14 ;
     15 NEW Y,LN,DATA,IBREC,POS,STSFLG
     16 S Y=0,STSFLG=0
     17 S LN=0
     18 F  S LN=$O(@IBARRAY@(LN)) Q:'LN  D
     19 . S DATA=$$EXT($G(@IBARRAY@(LN,0))) Q:DATA=""
     20 . S IBREC=$P(DATA,U,1)
     21 . I IBREC="277STAT" S STSFLG=1 Q      ; set the STS flag
     22 . I IBREC<1 Q             ; rec# too low
     23 . I IBREC'<99 Q           ; rec# too high
     24 . F POS=1:1:$L(DATA) S Y=Y+($A(DATA,POS)*POS)
     25 . Q
     26 ;
     27 I 'STSFLG S Y=0   ; if this array is not a 277stat message
     28 Q Y
     29 ;
     30EXT(DATA) ; Extracts from the text in DATA if the text contains
     31 ;  "##RAW DATA: "
     32 Q $S(DATA["##RAW DATA: ":$P(DATA,"##RAW DATA: ",2,99),1:DATA)
     33 ;

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEU1.m

    r613 r623  
    1 IBCEU1  ;ALB/TMP - EDI UTILITIES FOR EOB PROCESSING ;10-FEB-99
    2         ;;2.0;INTEGRATED BILLING;**137,155,296,349,371**;21-MAR-94;Build 57
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5 CCOB1(IBIFN,NODE,SEQ)   ; Extract Claim level COB data
    6         ; for a bill IBIFN
    7         ; NODE = the file 361.1 node(s) to be returned, separated by commas
    8         ; SEQ = the specific insurance sequence you want returned.  If not =
    9         ;       1, 2, or 3, all are returned
    10         ; Returns IBXDATA(COB,n,node)  where COB = COB insurance sequence,
    11         ;  n is the entry number in file 361.1 and node is the node requested
    12         ;   = the requested node's data
    13         ;
    14         N IB,IBN,IBBILL,IBS,A,B,C
    15         ;
    16         K IBXDATA
    17         ;
    18         S:$G(NODE)="" NODE=1
    19         S IB=$P($G(^DGCR(399,IBIFN,"M1")),U,5,7)
    20         S:"123"'[$G(SEQ) SEQ=""
    21         ;
    22         F B=1:1:3 S IBBILL=$P(IB,U,B) I IBBILL S C=0 F  S C=$O(^IBM(361.1,"B",IBBILL,C)) Q:'C  D
    23         . I '$$EOBELIG(C) Q      ; eob not eligible for secondary claim
    24         . S IBS=$P($G(^IBM(361.1,C,0)),U,15)   ; insurance sequence
    25         . I $S('$G(SEQ):1,1:SEQ=IBS) D
    26         .. F Z=1:1:$L(NODE,",") D
    27         ... S A=$P(NODE,",",Z)
    28         ... Q:A=""
    29         ... S IBN=$G(^IBM(361.1,C,A))
    30         ... I $TR(IBN,U)'="" S IBXDATA(IBS,C,A)=IBN
    31         ;
    32         Q
    33         ;
    34 CCAS1(IBIFN,SEQ)        ; Extract all MEDICARE COB claim level adjustment data
    35         ; for a bill IBIFN (subfile 361.11 in file 361.1)
    36         ; SEQ = the specific insurance sequence you want returned.  If not =
    37         ;       1, 2, or 3, all are returned
    38         ; Returns IBXDATA(COB,n)  where COB = COB insurance sequence,
    39         ;       n is the entry number in file 361.1 and
    40         ;       = the 0-node of the subfile entry (361.11)
    41         ;    and IBXDATA(COB,n,m) where m is a sequential # and
    42         ;                         = this level's 0-node
    43         N IB,IBA,IBS,IB0,IB00,IBBILL,B,C,D,E
    44         ;
    45         S IB=$P($G(^DGCR(399,IBIFN,"M1")),U,5,7)
    46         S:"123"'[$G(SEQ) SEQ=""
    47         ;
    48         F B=1:1:3 S IBBILL=$P(IB,U,B) I IBBILL S C=0 F  S C=$O(^IBM(361.1,"B",IBBILL,C)) Q:'C  D
    49         . I '$$EOBELIG(C) Q      ; eob not eligible for secondary claim
    50         . S IBS=$P($G(^IBM(361.1,C,0)),U,15)   ; insurance sequence
    51         . I $S('$G(SEQ):1,1:SEQ=IBS) D
    52         .. S (IBA,D)=0 F  S D=$O(^IBM(361.1,C,10,D)) Q:'D  S IB0=$G(^(D,0)) D
    53         ... S IBXDATA(IBS,D)=IB0
    54         ... S (IBA,E)=0
    55         ... F  S E=$O(^IBM(361.1,C,10,D,1,E)) Q:'E  S IB00=$G(^(E,0)) D
    56         .... S IBA=IBA+1
    57         .... I $TR(IB00,U)'="" S IBXDATA(IBS,D,IBA)=IB00
    58         ;
    59         Q
    60         ;
    61 SEQ(A)  ; Translate sequence # A into corresponding letter representation
    62         S A=$E("PST",A)
    63         I $S(A'="":"PST"'[A,1:1) S A="P"
    64         Q A
    65         ;
    66 EOBTOT(IBIFN,IBCOBN)    ; Total all EOB's for a bill's COB sequence
    67         ; Function returns the total of all EOB's for a specific COB seq
    68         ; IBIFN = ien of bill in file 399
    69         ; IBCOBN = the # of the COB sequence you want EOB/MRA total for (1-3)
    70         ;
    71         N Z,Z0,IBTOT
    72         S IBTOT=0
    73         I $O(^IBM(361.1,"ABS",IBIFN,IBCOBN,0)) D
    74         . ; Set up prior payment field here from MRA/EOB(s)
    75         . S (IBTOT,Z)=0
    76         . F  S Z=$O(^IBM(361.1,"ABS",IBIFN,IBCOBN,Z)) Q:'Z  D
    77         .. ; HD64841 IB*2*371 - total up the payer paid amounts
    78         .. S IBTOT=IBTOT+$P($G(^IBM(361.1,Z,1)),U,1)
    79         Q IBTOT
    80         ;
    81         ;
    82 LCOBOUT(IBXSAVE,IBXDATA,COL)    ; Output the line adjustment reasons COB
    83         ;  line # data for an electronic claim
    84         ; IBXSAVE,IBXDATA = arrays holding formatter information for claim -
    85         ;                   pass by reference
    86         ; COL = the column in the 837 flat file being output for LCAS record
    87         N LINE,COBSEQ,RECCT,GRPCD,SEQ,RCCT,RCPC,DATA,RCREC,SEQLINE K IBXDATA
    88         S (LINE,RECCT)=0
    89         S RCPC=(COL#3) S:'RCPC RCPC=3
    90         S RCREC=$S(COL'<4:COL-1\3,1:0)
    91         ;S RCREC=$S(COL'<4:COL+5\6-1,1:0)
    92         F  S LINE=$O(IBXSAVE("LCOB",LINE)) Q:'LINE  D
    93         . S COBSEQ=0
    94         . F  S COBSEQ=$O(IBXSAVE("LCOB",LINE,"COB",COBSEQ)) Q:'COBSEQ  S SEQLINE=0 F  S SEQLINE=$O(IBXSAVE("LCOB",LINE,"COB",COBSEQ,SEQLINE)) Q:'SEQLINE  S GRPCD="" F  S GRPCD=$O(IBXSAVE("LCOB",LINE,"COB",COBSEQ,SEQLINE,GRPCD)) Q:GRPCD=""  D
    95         .. S RECCT=RECCT+1
    96         .. I COL=2 S IBXDATA(RECCT)=LINE,DATA=LINE D:RECCT>1 ID^IBCEF2(RECCT,"LCAS")
    97         .. I COL=3 S IBXDATA(RECCT)=$TR(GRPCD," ")
    98         .. S (SEQ,RCCT)=0
    99         .. F  S SEQ=$O(IBXSAVE("LCOB",LINE,"COB",COBSEQ,SEQLINE,GRPCD,SEQ)) Q:'SEQ  I $TR($G(IBXSAVE("LCOB",LINE,"COB",COBSEQ,SEQLINE,GRPCD,SEQ)),U)'="" D
    100         ... S RCCT=RCCT+1
    101         ... Q:COL'<4&(RCCT'=RCREC)&(RCCT'>6)
    102         ... S DATA=$S(COL=2:LINE,COL=3:$TR(GRPCD," "),1:$P($G(IBXSAVE("LCOB",LINE,"COB",COBSEQ,SEQLINE,GRPCD,SEQ)),U,RCPC))
    103         ... I COL'<4,RCCT=RCREC S:DATA'="" IBXDATA(RECCT)=DATA Q
    104         ... I RCCT>6 S RCCT=1,RECCT=RECCT+1 D:COL=2 ID^IBCEF2(RECCT,"LCAS") I DATA'="",$S(COL'>3:1,1:RCCT=RCREC) S IBXDATA(RECCT)=DATA
    105         Q
    106         ;
    107 CCOBOUT(IBXSAVE,IBXDATA,COL)    ; Output the claim adjustment reasons COB
    108         ;  data for an electronic claim
    109         ; IBXSAVE,IBXDATA = arrays holding formatter information for claim -
    110         ;                   pass by reference
    111         ; COL = the column in the 837 flat file being output for CCAS record
    112         N COBSEQ,RECCT,GRPSEQ,SEQ,RCPC,RCCT,RCREC,DATA K IBXDATA
    113         S RECCT=0
    114         S RCPC=(COL#3) S:'RCPC RCPC=3
    115         S RCREC=$S(COL'<4:COL+5\6-1,1:0)
    116         S COBSEQ=0
    117         F  S COBSEQ=$O(IBXSAVE("CCAS",COBSEQ)) Q:'COBSEQ  S GRPSEQ="" F  S GRPSEQ=$O(IBXSAVE("CCAS",COBSEQ,GRPSEQ)) Q:GRPSEQ=""  D
    118         . S RECCT=RECCT+1
    119         . I COL=2 S IBXDATA(RECCT)=COBSEQ D:RECCT>1 ID^IBCEF2(RECCT,"CCAS")
    120         . I COL=3 S IBXDATA(RECCT)=$P($G(IBXSAVE("CCAS",COBSEQ,GRPSEQ)),U)
    121         . S (SEQ,RCCT)=0
    122         . F  S SEQ=$O(IBXSAVE("CCAS",COBSEQ,GRPSEQ,SEQ)) Q:'SEQ  I $TR($G(IBXSAVE("CCAS",COBSEQ,GRPSEQ,SEQ)),U)'="" D
    123         .. S RCCT=RCCT+1
    124         .. Q:COL'<4&(RCCT'=RCREC)&(RCCT'>6)
    125         .. S DATA=$S(COL=2:COBSEQ,COL=3:$P($G(IBXSAVE("CCAS",COBSEQ,GRPSEQ)),U),1:$P($G(IBXSAVE("CCAS",COBSEQ,GRPSEQ,SEQ)),U,RCPC))
    126         .. I COL'<4,RCCT=RCREC S:DATA'="" IBXDATA(RECCT)=DATA Q
    127         .. I RCCT>6 S RCCT=1,RECCT=RECCT+1 D:COL=2 ID^IBCEF2(RECCT,"CCAS") I DATA'="",$S(COL'>3:1,1:RCCT=RCREC) S IBXDATA(RECCT)=DATA
    128         Q
    129         ;
    130 COBOUT(IBXSAVE,IBXDATA,CL)      ; build LCOB segment data
    131         ; The IBXSAVE array used here is built by INS-2, then LCOB-1.9
    132         ; This is basically the 361.115, but all the piece numbers here in this
    133         ; local array are one higher than the pieces in subfile 361.115.
    134         N Z,M,N,P,PCCL
    135         S (N,Z,P)=0 F  S Z=$O(IBXSAVE("LCOB",Z)) Q:'Z  D
    136         . S N=N+1
    137         . S M=$O(IBXSAVE("LCOB",Z,"COB",""),-1) Q:'M
    138         . S P=$O(IBXSAVE("LCOB",Z,"COB",M,""),-1) Q:'P
    139         . S PCCL=$P($G(IBXSAVE("LCOB",Z,"COB",M,P)),U,CL)
    140         . S:PCCL'="" IBXDATA(N)=PCCL
    141         . Q
    142         Q
    143         ;
    144 COBPYRID(IBXIEN,IBXSAVE,IBXDATA)        ; cob insurance company payer id
    145         N CT,N,NUM
    146         K IBXDATA
    147         I '$D(IBXSAVE("LCOB")) G COBPYRX
    148         D ALLPAYID^IBCEF2(IBXIEN,.NUM,1)
    149         S NUM=$G(NUM(1))
    150         S NUM=$E(NUM_$J("",5),1,5)
    151         S (CT,N)=0
    152         F  S N=$O(IBXSAVE("LCOB",N)) Q:'N  S CT=CT+1,IBXDATA(CT)=NUM
    153 COBPYRX ;
    154         Q
    155         ;
    156 EOBELIG(IBEOB)  ; EOB eligibility for secondary claim
    157         ; Function to decide if EOB entry in file 361.1 (ien=IBEOB) is
    158         ; eligible to be included for secondary claim creation process
    159         ; The EOB is not eligible if the review status is not 3, or if there
    160         ; is no insurance sequence indicator, or if the EOB has been DENIED
    161         ; and the patient responsibility for that EOB is $0 and that EOB is
    162         ; not a split EOB.  Split EOB's need to be included (IB*2*371).
    163         ;
    164         NEW ELIG,IBDATA,PTRESP
    165         S ELIG=0
    166         I '$G(IBEOB) G EOBELIGX
    167         S IBDATA=$G(^IBM(361.1,IBEOB,0))
    168         I $P(IBDATA,U,4)'=1 G EOBELIGX      ; Only MRA EOB's for now
    169         I $D(^IBM(361.1,IBEOB,"ERR")) G EOBELIGX     ; filing error
    170         I $P(IBDATA,U,16)'=3 G EOBELIGX     ; review status - accepted-complete
    171         I '$P(IBDATA,U,15) G EOBELIGX       ; insurance sequence must exist
    172         S PTRESP=$P($G(^IBM(361.1,IBEOB,1)),U,2)     ; Pt Resp Amount for 1500s
    173         I $$FT^IBCEF(+IBDATA)=3 S PTRESP=$$PTRESPI^IBCECOB1(IBEOB)  ; for UBs
    174         I PTRESP'>0,$P(IBDATA,U,13)=2,'$$SPLIT^IBCEMU1(IBEOB) G EOBELIGX     ; Denied & No Pt. Resp. & not a split MRA
    175         ;
    176         S ELIG=1
    177 EOBELIGX        ;
    178         Q ELIG
    179         ;
    180 EOBCNT(IBIFN)   ; This function counts up the number of EOBs that are eligible
    181         ; for the secondary claim creation process for a given bill#.
    182         NEW CNT,IEN
    183         S (CNT,IEN)=0
    184         F  S IEN=$O(^IBM(361.1,"B",+$G(IBIFN),IEN)) Q:'IEN  D
    185         . I $$EOBELIG(IEN) S CNT=CNT+1
    186         . Q
    187 EOBCNTX ;
    188         Q CNT
    189         ;
     1IBCEU1 ;ALB/TMP - EDI UTILITIES FOR EOB PROCESSING ;10-FEB-99
     2 ;;2.0;INTEGRATED BILLING;**137,155,296,349**;21-MAR-94;Build 46
     3 ;;Per VHA Directive 2004-038, this routine should not be modified.
     4 ;
     5CCOB1(IBIFN,NODE,SEQ) ; Extract Claim level COB data
     6 ; for a bill IBIFN
     7 ; NODE = the file 361.1 node(s) to be returned, separated by commas
     8 ; SEQ = the specific insurance sequence you want returned.  If not =
     9 ;       1, 2, or 3, all are returned
     10 ; Returns IBXDATA(COB,n,node)  where COB = COB insurance sequence,
     11 ;  n is the entry number in file 361.1 and node is the node requested
     12 ;   = the requested node's data
     13 ;
     14 N IB,IBN,IBBILL,IBS,A,B,C
     15 ;
     16 K IBXDATA
     17 ;
     18 S:$G(NODE)="" NODE=1
     19 S IB=$P($G(^DGCR(399,IBIFN,"M1")),U,5,7)
     20 S:"123"'[$G(SEQ) SEQ=""
     21 ;
     22 F B=1:1:3 S IBBILL=$P(IB,U,B) I IBBILL S C=0 F  S C=$O(^IBM(361.1,"B",IBBILL,C)) Q:'C  D
     23 . I '$$EOBELIG(C) Q      ; eob not eligible for secondary claim
     24 . S IBS=$P($G(^IBM(361.1,C,0)),U,15)   ; insurance sequence
     25 . I $S('$G(SEQ):1,1:SEQ=IBS) D
     26 .. F Z=1:1:$L(NODE,",") D
     27 ... S A=$P(NODE,",",Z)
     28 ... Q:A=""
     29 ... S IBN=$G(^IBM(361.1,C,A))
     30 ... I $TR(IBN,U)'="" S IBXDATA(IBS,C,A)=IBN
     31 ;
     32 Q
     33 ;
     34CCAS1(IBIFN,SEQ) ; Extract all MEDICARE COB claim level adjustment data
     35 ; for a bill IBIFN (subfile 361.11 in file 361.1)
     36 ; SEQ = the specific insurance sequence you want returned.  If not =
     37 ;       1, 2, or 3, all are returned
     38 ; Returns IBXDATA(COB,n)  where COB = COB insurance sequence,
     39 ;       n is the entry number in file 361.1 and
     40 ;       = the 0-node of the subfile entry (361.11)
     41 ;    and IBXDATA(COB,n,m) where m is a sequential # and
     42 ;                         = this level's 0-node
     43 N IB,IBA,IBS,IB0,IB00,IBBILL,B,C,D,E
     44 ;
     45 S IB=$P($G(^DGCR(399,IBIFN,"M1")),U,5,7)
     46 S:"123"'[$G(SEQ) SEQ=""
     47 ;
     48 F B=1:1:3 S IBBILL=$P(IB,U,B) I IBBILL S C=0 F  S C=$O(^IBM(361.1,"B",IBBILL,C)) Q:'C  D
     49 . I '$$EOBELIG(C) Q      ; eob not eligible for secondary claim
     50 . S IBS=$P($G(^IBM(361.1,C,0)),U,15)   ; insurance sequence
     51 . I $S('$G(SEQ):1,1:SEQ=IBS) D
     52 .. S (IBA,D)=0 F  S D=$O(^IBM(361.1,C,10,D)) Q:'D  S IB0=$G(^(D,0)) D
     53 ... S IBXDATA(IBS,D)=IB0
     54 ... S (IBA,E)=0
     55 ... F  S E=$O(^IBM(361.1,C,10,D,1,E)) Q:'E  S IB00=$G(^(E,0)) D
     56 .... S IBA=IBA+1
     57 .... I $TR(IB00,U)'="" S IBXDATA(IBS,D,IBA)=IB00
     58 ;
     59 Q
     60 ;
     61SEQ(A) ; Translate sequence # A into corresponding letter representation
     62 S A=$E("PST",A)
     63 I $S(A'="":"PST"'[A,1:1) S A="P"
     64 Q A
     65 ;
     66EOBTOT(IBIFN,IBCOBN) ; Total all EOB's for a bill's COB sequence
     67 ; Function returns the total of all EOB's for a specific COB seq
     68 ; IBIFN = ien of bill in file 399
     69 ; IBCOBN = the # of the COB sequence you want EOB/MRA total for (1-3)
     70 ;
     71 N Z,Z0,IBTOT
     72 S IBTOT=0
     73 I $O(^IBM(361.1,"ABS",IBIFN,IBCOBN,0)) D
     74 . ; Set up prior payment field here from MRA/EOB(s)
     75 . S (IBTOT,Z)=0
     76 . F  S Z=$O(^IBM(361.1,"ABS",IBIFN,IBCOBN,Z)) Q:'Z  D
     77 .. S IBTOT=IBTOT+$P($G(^IBM(361.1,Z,1)),U,2)
     78 Q IBTOT
     79 ;
     80 ;
     81LCOBOUT(IBXSAVE,IBXDATA,COL) ; Output the line adjustment reasons COB
     82 ;  line # data for an electronic claim
     83 ; IBXSAVE,IBXDATA = arrays holding formatter information for claim -
     84 ;                   pass by reference
     85 ; COL = the column in the 837 flat file being output for LCAS record
     86 N LINE,COBSEQ,RECCT,GRPCD,SEQ,RCCT,RCPC,DATA,RCREC,SEQLINE K IBXDATA
     87 S (LINE,RECCT)=0
     88 S RCPC=(COL#3) S:'RCPC RCPC=3
     89 S RCREC=$S(COL'<4:COL-1\3,1:0)
     90 ;S RCREC=$S(COL'<4:COL+5\6-1,1:0)
     91 F  S LINE=$O(IBXSAVE("LCOB",LINE)) Q:'LINE  D
     92 . S COBSEQ=0
     93 . F  S COBSEQ=$O(IBXSAVE("LCOB",LINE,"COB",COBSEQ)) Q:'COBSEQ  S SEQLINE=0 F  S SEQLINE=$O(IBXSAVE("LCOB",LINE,"COB",COBSEQ,SEQLINE)) Q:'SEQLINE  S GRPCD="" F  S GRPCD=$O(IBXSAVE("LCOB",LINE,"COB",COBSEQ,SEQLINE,GRPCD)) Q:GRPCD=""  D
     94 .. S RECCT=RECCT+1
     95 .. I COL=2 S IBXDATA(RECCT)=LINE,DATA=LINE D:RECCT>1 ID^IBCEF2(RECCT,"LCAS")
     96 .. I COL=3 S IBXDATA(RECCT)=$TR(GRPCD," ")
     97 .. S (SEQ,RCCT)=0
     98 .. F  S SEQ=$O(IBXSAVE("LCOB",LINE,"COB",COBSEQ,SEQLINE,GRPCD,SEQ)) Q:'SEQ  I $TR($G(IBXSAVE("LCOB",LINE,"COB",COBSEQ,SEQLINE,GRPCD,SEQ)),U)'="" D
     99 ... S RCCT=RCCT+1
     100 ... Q:COL'<4&(RCCT'=RCREC)&(RCCT'>6)
     101 ... S DATA=$S(COL=2:LINE,COL=3:$TR(GRPCD," "),1:$P($G(IBXSAVE("LCOB",LINE,"COB",COBSEQ,SEQLINE,GRPCD,SEQ)),U,RCPC))
     102 ... I COL'<4,RCCT=RCREC S:DATA'="" IBXDATA(RECCT)=DATA Q
     103 ... I RCCT>6 S RCCT=1,RECCT=RECCT+1 D:COL=2 ID^IBCEF2(RECCT,"LCAS") I DATA'="",$S(COL'>3:1,1:RCCT=RCREC) S IBXDATA(RECCT)=DATA
     104 Q
     105 ;
     106CCOBOUT(IBXSAVE,IBXDATA,COL) ; Output the claim adjustment reasons COB
     107 ;  data for an electronic claim
     108 ; IBXSAVE,IBXDATA = arrays holding formatter information for claim -
     109 ;                   pass by reference
     110 ; COL = the column in the 837 flat file being output for CCAS record
     111 N COBSEQ,RECCT,GRPSEQ,SEQ,RCPC,RCCT,RCREC,DATA K IBXDATA
     112 S RECCT=0
     113 S RCPC=(COL#3) S:'RCPC RCPC=3
     114 S RCREC=$S(COL'<4:COL+5\6-1,1:0)
     115 S COBSEQ=0
     116 F  S COBSEQ=$O(IBXSAVE("CCAS",COBSEQ)) Q:'COBSEQ  S GRPSEQ="" F  S GRPSEQ=$O(IBXSAVE("CCAS",COBSEQ,GRPSEQ)) Q:GRPSEQ=""  D
     117 . S RECCT=RECCT+1
     118 . I COL=2 S IBXDATA(RECCT)=COBSEQ D:RECCT>1 ID^IBCEF2(RECCT,"CCAS")
     119 . I COL=3 S IBXDATA(RECCT)=$P($G(IBXSAVE("CCAS",COBSEQ,GRPSEQ)),U)
     120 . S (SEQ,RCCT)=0
     121 . F  S SEQ=$O(IBXSAVE("CCAS",COBSEQ,GRPSEQ,SEQ)) Q:'SEQ  I $TR($G(IBXSAVE("CCAS",COBSEQ,GRPSEQ,SEQ)),U)'="" D
     122 .. S RCCT=RCCT+1
     123 .. Q:COL'<4&(RCCT'=RCREC)&(RCCT'>6)
     124 .. S DATA=$S(COL=2:COBSEQ,COL=3:$P($G(IBXSAVE("CCAS",COBSEQ,GRPSEQ)),U),1:$P($G(IBXSAVE("CCAS",COBSEQ,GRPSEQ,SEQ)),U,RCPC))
     125 .. I COL'<4,RCCT=RCREC S:DATA'="" IBXDATA(RECCT)=DATA Q
     126 .. I RCCT>6 S RCCT=1,RECCT=RECCT+1 D:COL=2 ID^IBCEF2(RECCT,"CCAS") I DATA'="",$S(COL'>3:1,1:RCCT=RCREC) S IBXDATA(RECCT)=DATA
     127 Q
     128 ;
     129COBOUT(IBXSAVE,IBXDATA,CL) ;
     130 N Z,M,N,P,PCCL
     131 S (N,Z,P)=0 F  S Z=$O(IBXSAVE("LCOB",Z)) Q:'Z  D
     132 . S N=N+1
     133 . S M=$O(IBXSAVE("LCOB",Z,"COB",""),-1) Q:'M
     134 . S P=$O(IBXSAVE("LCOB",Z,"COB",M,""),-1) Q:'P
     135 . S PCCL=$P($G(IBXSAVE("LCOB",Z,"COB",M,P)),U,CL)
     136 . S:PCCL'="" IBXDATA(N)=PCCL
     137 . Q
     138 Q
     139 ;
     140COBPYRID(IBXIEN,IBXSAVE,IBXDATA) ; cob insurance company payer id
     141 N CT,Z,N,NUM
     142 K IBXDATA
     143 I '$D(IBXSAVE("LCOB")) G COBPYRX
     144 D ALLPAYID^IBCEF2(IBXIEN,.NUM,1)
     145 S Z=$$COID^IBCEF2(IBXIEN),NUM=$G(NUM(1))
     146 S:Z="" Z="0000"
     147 S NUM=$E(NUM_$J("",5),1,5)_$E(Z_$J("",4),1,4)
     148 S (CT,N)=0
     149 F  S N=$O(IBXSAVE("LCOB",N)) Q:'N  S CT=CT+1,IBXDATA(CT)=NUM
     150COBPYRX ;
     151 Q
     152 ;
     153EOBELIG(IBEOB) ; EOB eligibility for secondary claim
     154 ; Function to decide if EOB entry in file 361.1 (ien=IBEOB) is
     155 ; eligible to be included for secondary claim creation process
     156 ; The EOB is not eligible if the review status is not 3, or if there
     157 ; is no insurance sequence indicator, or if the EOB has been DENIED
     158 ; and the patient responsibility for that EOB is $0.
     159 ;
     160 NEW ELIG,IBDATA,PTRESP
     161 S ELIG=0
     162 I '$G(IBEOB) G EOBELIGX
     163 S IBDATA=$G(^IBM(361.1,IBEOB,0))
     164 I $P(IBDATA,U,4)'=1 G EOBELIGX      ; Only MRA EOB's for now
     165 I $P(IBDATA,U,16)'=3 G EOBELIGX     ; review status - accepted-complete
     166 I '$P(IBDATA,U,15) G EOBELIGX       ; insurance sequence must exist
     167 S PTRESP=$P($G(^IBM(361.1,IBEOB,1)),U,2)     ; Pt Resp Amount for 1500s
     168 I $$FT^IBCEF(+IBDATA)=3 S PTRESP=$$PTRESPI^IBCECOB1(IBEOB)  ; for UBs
     169 I PTRESP'>0,$P(IBDATA,U,13)=2 G EOBELIGX     ; Denied & No Pt. Resp.
     170 I $D(^IBM(361.1,IBEOB,"ERR")) G EOBELIGX     ; filing error
     171 ;
     172 S ELIG=1
     173EOBELIGX ;
     174 Q ELIG
     175 ;
     176EOBCNT(IBIFN) ; This function counts up the number of EOBs that are eligible
     177 ; for the secondary claim creation process for a given bill#.
     178 NEW CNT,IEN
     179 S (CNT,IEN)=0
     180 F  S IEN=$O(^IBM(361.1,"B",+$G(IBIFN),IEN)) Q:'IEN  D
     181 . I $$EOBELIG(IEN) S CNT=CNT+1
     182 . Q
     183EOBCNTX ;
     184 Q CNT
     185 ;

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEU3.m

    r613 r623  
    1 IBCEU3  ;ALB/TMP - EDI UTILITIES FOR 1500 CLAIM FORM ;12/29/05 9:58am
    2         ;;2.0;INTEGRATED BILLING;**51,137,155,323,348,371**;21-MAR-94;Build 57
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5 BOX19(IBIFN)    ; Returns the text that should print in box 19 of the CMS-1500
    6         ;   for bill ien IBIFN
    7         ; Data is derived from a combo of data throughout
    8         ; the system and is limited to 80 characters.  The hierarchy for
    9         ; including data is as follows (until 80 characters have been used):
    10         ;   DATE LAST SEEN and REFERRING PHYSICIAN ID# (physical therapy)
    11         ;                      specialty codes = 025,065,073,067,048
    12         ;   LAST X-RAY DATE (chiropractic) specialty code = 35
    13         ;   HOMEBOUND INDICATOR (independent lab renders an EKG or obtains
    14         ;                        a specimen from a homebound patient)
    15         ;   NO ASSIGNMENT OF BENEFITS (if no assignment of benefits indicated)
    16         ;   Hearing aid testing (if applicable)
    17         ;   ATTENDING PHYSICIAN NOT HOSPICE EMPLOYEE (if applicable)
    18         ;   SPECIAL PROGRAM indicator if Medicare demonstration project for
    19         ;                   lung volume reduction surgery study is set
    20         ;   COMMENTS FOUND IN BOX 19 DATA FIELD FOR THE CLAIM
    21         ;   REMARKS FOUND IN BILL COMMENT FOR THE CLAIM, INCLUDING PROSTHETICS
    22         ;     DETAIL
    23         ;
    24         N IBGO,IBHOSP,IBID,IBLSDT,IBXDATA,IB19,IBHAID,IBXRAY,IBSPEC,Z,Z0,IBSUB,IBPRT,IBREM
    25         S IB19="",IBGO=1
    26         S IBSUB=$S('$G(^TMP("IBTX",$J,IBIFN)):"BOX24",1:"OUTPT")
    27         I $D(IBXSAVE(IBSUB)) N IBXSAVE
    28         S IBPRT=(IBSUB["24")
    29         ;
    30         S IBSPEC=$$BILLSPEC(IBIFN)
    31         G:'IBPRT NPRT
    32         ; Check for chiropractic services
    33         I $P($G(^DGCR(399,IBIFN,"U3")),U,5)'="" S:$P($G(^DGCR(399,IBIFN,"U3")),U,4)'="" IBGO=$$LENOK("Last X-ray: "_$TR($$DATE^IBCF2($P(^DGCR(399,IBIFN,"U3"),U,4))," ","/"),.IB19)
    34         G:'IBGO BOX19Q
    35         ;
    36         I "^25^65^73^67^48^"[(U_IBSPEC_U) D
    37         . K IBXDATA D F^IBCEF("N-DATE LAST SEEN",,,IBIFN)
    38         . I IBXDATA'="" S IBID="",IBLSDT=$$DATE^IBCF2(IBXDATA,0,1) D  I IBLSDT'="" S IBGO=$$LENOK("Date Last Seen:"_IBLSDT_IBID,.IB19)
    39         .. ; Only print if specialty is OT or PT or proc for routine foot care
    40         .. D F^IBCEF("N-REFERRING PROVIDER ID",,,IBIFN) I IBXDATA'="" S IBID=" By:"_IBXDATA
    41         ;
    42         G:'IBGO BOX19Q
    43         K IBXDATA D F^IBCEF("N-HOMEBOUND",,,IBIFN)
    44         I IBXDATA G:'$$LENOK("Homebound",.IB19) BOX19Q
    45         ;
    46         K IBXDATA D F^IBCEF("N-ASSIGN OF BENEFITS INDICATOR",,,IBIFN)
    47         I "Nn0"[IBXDATA&(IBXDATA'="") G:'$$LENOK("Patient refuses to assign benefits",.IB19) BOX19Q
    48         ;
    49         I '$D(IBXSAVE(IBSUB)) D B24^IBCEF3(.IBXSAVE,IBIFN,$S($G(IBNOSHOW)=0:0,1:1))
    50         ;
    51         S (IBHAID,IBHOSP,IBXRAY)=0
    52         ;
    53         S Z=0 F  S Z=$O(IBXSAVE(IBSUB,Z)) Q:'Z  D  G:'IBGO BOX19Q
    54         . I $D(IBXSAVE(IBSUB,Z,"RX")),$P(IBXSAVE(IBSUB,Z,"RX"),U,3)="" S IBGO=$$LENOK("NOC Drug:"_$P(IBXSAVE(IBSUB,Z,"RX"),U,2)_" Units:"_+$P(IBXSAVE(IBSUB,Z,"RX"),U,6),.IB19)
    55         . ;
    56         . Q:'IBGO
    57         . I 'IBHAID,$P(IBXSAVE(IBSUB,Z),U,5)="V5010",$$COBCT^IBCEF(IBIFN)>1 D  Q
    58         .. S IBHAID=1,IBGO=$$LENOK("Testing for hearing aid",.IB19) Q
    59         . ;
    60         . Q:'IBGO
    61         . I 'IBHOSP,$P($G(IBXSAVE(IBSUB,Z,"AUX")),U,3) S IBHOSP=1,IBGO=$$LENOK("Attending physician,not hospice employee",.IB19) Q
    62         G:'IBGO BOX19Q
    63         K IBXDATA D F^IBCEF("N-SPECIAL PROGRAM",,,IBIFN)
    64         I IBXDATA=30 G:'$$LENOK("Medicare demonstration project for lung volume reduction surgery study",.IB19) BOX19Q
    65         ;
    66         G:'IBGO BOX19Q
    67 NPRT    K IBXDATA D F^IBCEF("N-HCFA 1500 BOX 19 RAW DATA",,,IBIFN)
    68         S IBREM=0
    69         I IBXDATA'="" G:'$$LENOK("Remarks:"_IBXDATA,.IB19) BOX19Q S IBREM=1
    70         K IBXDATA D F^IBCEF("N-BILL REMARKS",,,IBIFN)
    71         I IBXDATA'="" G:'$$LENOK($S('IBREM:"Remarks:",1:"")_IBXDATA,.IB19) BOX19Q
    72         ;
    73 BOX19Q  Q IB19
    74         ;
    75 LENOK(IBDATA,IB19)      ; Add text IBDATA to box 19 string (IB19 passed by ref)
    76         ; Check length of box 19 data - truncate at 96 (max length)
    77         ; Returns 0 if max length reached or exceeded, otherwise, 1
    78         N OK
    79         S OK=1
    80         S IB19=IB19_$S(IB19'="":" ",1:"")_$G(IBDATA)
    81         I $L(IB19)'<96 S OK=0,IB19=$E(IB19,1,96) G LENOKQ
    82 LENOKQ  Q OK
    83         ;
    84 ASK19(IBIFN)    ; Ask to display CMS-1500 box 19 data for current IBIFN
    85         N DIR,DIC,X,Y,DIE,DR,Z
    86         S DIR(0)="YA",DIR("B")="NO",DIR("A")="DISPLAY THE FULL CMS-1500 BOX 19?: "
    87         D ^DIR
    88         I Y=1 S Z=$$BOX19(IBIFN) W !!,?4,"19",?20,$E(Z,1,32) W:$L(Z)>32 !,?4,$E(Z,33,80),!
    89         Q
    90         ;
    91 ONLAB(IBIFN)    ; Functions returns 1 if the bill IBIFN is outside non-lab
    92         N IBP,IBPUR
    93         S IBP=0
    94         S IBPUR=$P($G(^DGCR(399,IBIFN,"U2")),U,11)
    95         I IBPUR,"13"[IBPUR S IBP=1
    96         Q IBP
    97         ;
    98 TEXT24(FLD,IBXSAVE,IBXDATA,IBSUB)       ; Format the text line of box 24 by fld
    99         ; INPUT:
    100         ;   FLD = the letter of the field in box 24 (A-J)
    101         ;   IBXSAVE = passed by reference = extracted data for the box 24 lines
    102         ;   IBSUB = the subscript of the IBXSAVE array to use.
    103         ;           If null, use "BOX24"
    104         ; OUTPUT:
    105         ;   IBXDATA = passed by reference, set to the correct part of the
    106         ;             text that will print in the field's positions
    107         ;
    108         ; esg - 8/14/06 - modified for the new cms-1500 form - IB*2*348
    109         ;
    110         N Z,IBLINE,IBVAL,IBS,IBE,IBTEXT,IBAUX,IBDAT,IBZ,IBREN,IBRENQ,IBRENNPI,IBRENSID
    111         K IBXDATA
    112         S (IBLINE,Z)=0 S:$G(IBSUB)="" IBSUB="BOX24"
    113         ;
    114         I FLD="I"!(FLD="J") D   ; extract the Rendering provider data
    115         . I '$G(IBXIEN) Q       ; assume that the claim# exists
    116         . S IBREN=$$CFIDS^IBCEF77(IBXIEN)
    117         . S IBRENQ=$P(IBREN,U,1)    ; qual
    118         . S IBRENSID=$P(IBREN,U,2)  ; id
    119         . S IBRENNPI=$P(IBREN,U,3)  ; npi
    120         . Q
    121         ;
    122         F  S Z=$O(IBXSAVE(IBSUB,Z)) Q:'Z  D
    123         . S IBDAT=$G(IBXSAVE(IBSUB,Z))
    124         . S IBAUX=$G(IBXSAVE(IBSUB,Z,"AUX"))
    125         . S IBTEXT=$G(IBXSAVE(IBSUB,Z,"TEXT"))
    126         . S IBZ=$P(IBAUX,U,9)
    127         . I IBZ="" S IBZ="  "
    128         . S IBTEXT=IBZ_IBTEXT
    129         . ;
    130         . I $S($G(IBAC)=4:$S($D(IBXSAVE(IBSUB,Z,"ARX")):1,1:$D(IBXSAVE(IBSUB,Z,"A"))),$D(IBXSAVE(IBSUB,Z,"RX")):0,1:$G(IBNOSHOW)) S IBTEXT=""
    131         . ;
    132         . I FLD="AF" S IBVAL=$P(IBDAT,U),IBS=1,IBE=9 D   ; From date of service
    133         .. S IBVAL=$E(IBVAL,1,2)_" "_$E(IBVAL,3,4)_" "_$E(IBVAL,7,8)
    134         .. Q
    135         . ;
    136         . I FLD="AT" S IBVAL=$S($P(IBDAT,U,2):$P(IBDAT,U,2),1:$P(IBDAT,U)),IBS=10,IBE=18 D    ; To date of service
    137         .. S IBVAL=$E(IBVAL,1,2)_" "_$E(IBVAL,3,4)_" "_$E(IBVAL,7,8)
    138         .. Q
    139         . ;
    140         . I FLD="B" S IBVAL=$P(IBDAT,U,3),IBS=19,IBE=21   ; place of service
    141         . I FLD="C" S IBVAL=$S($P(IBDAT,U,13)=1:"Y",1:""),IBS=22,IBE=24   ; emergency indicator
    142         . I FLD="D" S IBVAL=$P(IBDAT,U,5),IBS=25,IBE=44 D   ; procedures and modifiers
    143         .. N M S M=$$MODLST^IBEFUNC($P(IBDAT,U,10))       ; modifier list
    144         .. S IBVAL=$$FO^IBCNEUT1(IBVAL,6)_"  "            ; procedure code
    145         .. S IBVAL=IBVAL_$$FO^IBCNEUT1($P(M,",",1),3)     ; mod#1
    146         .. S IBVAL=IBVAL_$$FO^IBCNEUT1($P(M,",",2),3)     ; mod#2
    147         .. S IBVAL=IBVAL_$$FO^IBCNEUT1($P(M,",",3),3)     ; mod#3
    148         .. S IBVAL=IBVAL_$$FO^IBCNEUT1($P(M,",",4),3)     ; mod#4
    149         .. Q
    150         . ;
    151         . I FLD="E" S IBVAL=$TR($P(IBDAT,U,7),","),IBS=45,IBE=48  ; diagnosis pointer
    152         . I FLD="F" S IBVAL=$P(IBDAT,U,8)*$P(IBDAT,U,9),IBS=49,IBE=57 D
    153         .. ; total charges
    154         .. S IBVAL=$$DOL^IBCEF77(IBVAL,9)
    155         .. Q
    156         . ;
    157         . I FLD="G" S IBVAL=$S($P(IBDAT,U,12):$P(IBDAT,U,12),1:$P(IBDAT,U,9)),IBS=58,IBE=61 D
    158         .. ; days or units or anesthesia minutes
    159         .. S IBVAL=$J(+IBVAL,4)
    160         .. Q
    161         . ;
    162         . ; columns H,I,J don't have any free text supplemental information
    163         . ;
    164         . I FLD="H" D     ; epsdt family plan
    165         .. S IBVAL=$P(IBAUX,U,7),IBS=0,IBE=0,IBTEXT=""   ; line 1 blank
    166         .. I IBVAL S IBVAL="Y"
    167         .. Q
    168         . I FLD="I" D     ; ID qualifier for rendering provider
    169         .. S IBVAL="",IBS=1,IBE=2   ; line 2 blank
    170         .. S IBTEXT=$G(IBRENQ)      ; qualifier on line 1
    171         .. Q
    172         . I FLD="J" D     ; rendering provider ID and NPI
    173         .. S IBTEXT=$G(IBRENSID),IBS=1,IBE=11   ; secondary ID line 1
    174         .. S IBVAL=$G(IBRENNPI)                 ; NPI# line 2
    175         .. Q
    176         . ;
    177         . S IBLINE=IBLINE+1                      ; top line
    178         . S IBXDATA(IBLINE)=$E(IBTEXT,IBS,IBE)   ; text in shaded area (top)
    179         . S IBLINE=IBLINE+1             ; bottom line
    180         . S IBXDATA(IBLINE)=IBVAL       ; field value in unshaded area (bottom)
    181         . Q
    182         ;
    183         Q
    184         ;
    185 BILLSPEC(IBIFN,IBPRV)   ;  Returns the specialty of the provider on bill IBIFN
    186         ; If IBPRV is supplied, returns the data for that provider, otherwise,
    187         ;  returns the specialty of the 'main/required' provider on the bill.
    188         ;  Default = 99 if no valid code found
    189         ; IBPRV = vp of provider (file 200 or 355.93)
    190         N Z,IBSPEC,IBINS,IBDT
    191         S IBSPEC="",IBPRV=$G(IBPRV)
    192         S IBDT=$P($G(^DGCR(399,+IBIFN,"U")),U,1)  ; use statement from date
    193         ;
    194         I $G(IBPRV) D  G SPECQ
    195         . S IBSPEC=$$SPEC^IBCEU(IBPRV,IBDT)
    196         ;
    197         ;Get rendering for professional, attending for institutional,
    198         S IBINS=($$FT^IBCEF(IBIFN)=3)
    199         D GETPRV^IBCEU(IBIFN,"ALL",.IBPRV)
    200         S Z=$S('IBINS:3,1:4)
    201         I $G(IBPRV(Z,1))'="" D
    202         . I $P(IBPRV(Z,1),U,3) S IBSPEC=$$SPEC^IBCEU($P($G(IBPRV(Z,1)),U,3),IBDT) Q:IBSPEC'=""
    203         . S Z0=+$O(^DGCR(399,IBIFN,"PRV","B",Z,0))
    204         . I Z0,$P($G(^DGCR(399,IBIFN,"PRV",Z0,0)),U,8)'="" S IBSPEC=$P(^(0),U,8)
    205         ;
    206 SPECQ   I IBSPEC="" S IBSPEC="99"
    207         Q IBSPEC
    208         ;
    209 CHAMPVA(IBIFN)  ; Returns 1 if the bill IBIFN has a CHAMPVA rate type
    210         Q $E($P($G(^DGCR(399.3,+$P($G(^DGCR(399,IBIFN,0)),U,7),0)),U),1,7)="CHAMPVA"
    211         ;
    212 FAC(IBIFN)      ; Is facility always to print in box 32 for bill ien IBIFN?
    213         ;  Returns 1 if yes, 0 if no
    214         Q $S($P($G(^DGCR(399,IBIFN,"UF2")),U,2):1,1:$P($G(^IBE(350.9,1,2)),U,12))
    215         ;
    216 MCR24K(IBIFN)   ;Function returns MEDICARE id# for professional (CMS-1500) box 24k for bill IBIFN if appropriate
    217         Q $S($$FT^IBCEF(IBIFN)=2&$$MCRONBIL^IBEFUNC(IBIFN):"V"_$$MCRSPEC^IBCEU4(IBIFN,1)_$P($$SITE^VASITE,U,3),1:"")
     1IBCEU3 ;ALB/TMP - EDI UTILITIES FOR 1500 CLAIM FORM ; 12/29/05 9:58am
     2 ;;2.0;INTEGRATED BILLING;**51,137,155,323,348**;21-MAR-94;Build 5
     3 ;
     4BOX19(IBIFN) ; Returns the text that should print in box 19 of the CMS-1500
     5 ;   for bill ien IBIFN
     6 ; Data is derived from a combo of data throughout
     7 ; the system and is limited to 80 characters.  The hierarchy for
     8 ; including data is as follows (until 80 characters have been used):
     9 ;   DATE LAST SEEN and REFERRING PHYSICIAN ID# (physical therapy)
     10 ;                      specialty codes = 025,065,073,067,048
     11 ;   LAST X-RAY DATE (chiropractic) specialty code = 35
     12 ;   HOMEBOUND INDICATOR (independent lab renders an EKG or obtains
     13 ;                        a specimen from a homebound patient)
     14 ;   NO ASSIGNMENT OF BENEFITS (if no assignment of benefits indicated)
     15 ;   Hearing aid testing (if applicable)
     16 ;   ATTENDING PHYSICIAN NOT HOSPICE EMPLOYEE (if applicable)
     17 ;   SPECIAL PROGRAM indicator if Medicare demonstration project for
     18 ;                   lung volume reduction surgery study is set
     19 ;   COMMENTS FOUND IN BOX 19 DATA FIELD FOR THE CLAIM
     20 ;   REMARKS FOUND IN BILL COMMENT FOR THE CLAIM, INCLUDING PROSTHETICS
     21 ;     DETAIL
     22 ;
     23 N IBGO,IBHOSP,IBID,IBLSDT,IBXDATA,IB19,IBHAID,IBXRAY,IBSPEC,Z,Z0,IBSUB,IBPRT,IBREM
     24 S IB19="",IBGO=1
     25 S IBSUB=$S('$G(^TMP("IBTX",$J,IBIFN)):"BOX24",1:"OUTPT")
     26 I $D(IBXSAVE(IBSUB)) N IBXSAVE
     27 S IBPRT=(IBSUB["24")
     28 ;
     29 S IBSPEC=$$BILLSPEC(IBIFN)
     30 G:'IBPRT NPRT
     31 I "^25^65^73^67^48^"[(U_IBSPEC_U) D
     32 . K IBXDATA D F^IBCEF("N-DATE LAST SEEN",,,IBIFN)
     33 . I IBXDATA'="" S IBID="",IBLSDT=$$DATE^IBCF2(IBXDATA,0,1) D  I IBLSDT'="" S IBGO=$$LENOK("Date Last Seen:"_IBLSDT_IBID,.IB19)
     34 .. ; Only print if specialty is OT or PT or proc for routine foot care
     35 .. D F^IBCEF("N-REFERRING PROVIDER ID",,,IBIFN) I IBXDATA'="" S IBID=" By:"_IBXDATA
     36 ;
     37 G:'IBGO BOX19Q
     38 K IBXDATA D F^IBCEF("N-HOMEBOUND",,,IBIFN)
     39 I IBXDATA G:'$$LENOK("Homebound",.IB19) BOX19Q
     40 ;
     41 K IBXDATA D F^IBCEF("N-ASSIGN OF BENEFITS INDICATOR",,,IBIFN)
     42 I "Nn0"[IBXDATA&(IBXDATA'="") G:'$$LENOK("Patient refuses to assign benefits",.IB19) BOX19Q
     43 ;
     44 I '$D(IBXSAVE(IBSUB)) D B24^IBCEF3(.IBXSAVE,IBIFN,$S($G(IBNOSHOW)=0:0,1:1))
     45 ;
     46 S (IBHAID,IBHOSP,IBXRAY)=0
     47 ;
     48 S Z=0 F  S Z=$O(IBXSAVE(IBSUB,Z)) Q:'Z  D  G:'IBGO BOX19Q
     49 . I $D(IBXSAVE(IBSUB,Z,"RX")),$P(IBXSAVE(IBSUB,Z,"RX"),U,3)="" S IBGO=$$LENOK("NOC Drug:"_$P(IBXSAVE(IBSUB,Z,"RX"),U,2)_" Units:"_+$P(IBXSAVE(IBSUB,Z,"RX"),U,6),.IB19)
     50 . ;
     51 . Q:'IBGO
     52 . I 'IBHAID,$P(IBXSAVE(IBSUB,Z),U,5)="V5010",$$COBCT^IBCEF(IBIFN)>1 D  Q
     53 .. S IBHAID=1,IBGO=$$LENOK("Testing for hearing aid",.IB19) Q
     54 . ;
     55 . Q:'IBGO
     56 . I 'IBHOSP,$P($G(IBXSAVE(IBSUB,Z,"AUX")),U,3) D  Q
     57 .. S IBHOSP=1,IBGO=$$LENOK("Attending physician,not hospice employee",.IB19)
     58 . ;
     59 . Q:'IBGO
     60 . I 'IBXRAY,IBSPEC=35,$G(IBXSAVE(IBSUB,Z,"AUX"))'="" D  Q
     61 .. ; Check for chiropratic services in claim type or specialty
     62 .. S IBXRAY=1
     63 .. S IBGO=$$LENOK($S($P(IBXSAVE(IBSUB,Z,"AUX"),U,2):"Last Xray:"_$$DATE^IBCF2($P(IBXSAVE(IBSUB,Z,"AUX"),U,2),0,1)_" ",1:"")_$S($P(IBXSAVE(IBSUB,Z,"AUX"),U,4)'="":"Level of Sublux:"_$P(IBXSAVE(IBSUB,Z,"AUX"),U,4),1:""),.IB19)
     64 ;
     65 G:'IBGO BOX19Q
     66 K IBXDATA D F^IBCEF("N-SPECIAL PROGRAM",,,IBIFN)
     67 I IBXDATA=30 G:'$$LENOK("Medicare demonstration project for lung volume reduction surgery study",.IB19) BOX19Q
     68 ;
     69 G:'IBGO BOX19Q
     70NPRT K IBXDATA D F^IBCEF("N-HCFA 1500 BOX 19 RAW DATA",,,IBIFN)
     71 S IBREM=0
     72 I IBXDATA'="" G:'$$LENOK("Remarks:"_IBXDATA,.IB19) BOX19Q S IBREM=1
     73 K IBXDATA D F^IBCEF("N-BILL REMARKS",,,IBIFN)
     74 I IBXDATA'="" G:'$$LENOK($S('IBREM:"Remarks:",1:"")_IBXDATA,.IB19) BOX19Q
     75 ;
     76BOX19Q Q IB19
     77 ;
     78LENOK(IBDATA,IB19) ; Add text IBDATA to box 19 string (IB19 passed by ref)
     79 ; Check length of box 19 data - truncate at 96 (max length)
     80 ; Returns 0 if max length reached or exceeded, otherwise, 1
     81 N OK
     82 S OK=1
     83 S IB19=IB19_$S(IB19'="":" ",1:"")_$G(IBDATA)
     84 I $L(IB19)'<96 S OK=0,IB19=$E(IB19,1,96) G LENOKQ
     85LENOKQ Q OK
     86 ;
     87ASK19(IBIFN) ; Ask to display CMS-1500 box 19 data for current IBIFN
     88 N DIR,DIC,X,Y,DIE,DR,Z
     89 S DIR(0)="YA",DIR("B")="NO",DIR("A")="DISPLAY THE FULL CMS-1500 BOX 19?: "
     90 D ^DIR
     91 I Y=1 S Z=$$BOX19(IBIFN) W !!,?4,"19",?20,$E(Z,1,32) W:$L(Z)>32 !,?4,$E(Z,33,80),!
     92 Q
     93 ;
     94ONLAB(IBIFN) ; Functions returns 1 if the bill IBIFN is outside non-lab
     95 N IBP,IBPUR
     96 S IBP=0
     97 S IBPUR=$P($G(^DGCR(399,IBIFN,"U2")),U,11)
     98 I IBPUR,"13"[IBPUR S IBP=1
     99 Q IBP
     100 ;
     101TEXT24(FLD,IBXSAVE,IBXDATA,IBSUB) ; Format the text line of box 24 by fld
     102 ; INPUT:
     103 ;   FLD = the letter of the field in box 24 (A-J)
     104 ;   IBXSAVE = passed by reference = extracted data for the box 24 lines
     105 ;   IBSUB = the subscript of the IBXSAVE array to use.
     106 ;           If null, use "BOX24"
     107 ; OUTPUT:
     108 ;   IBXDATA = passed by reference, set to the correct part of the
     109 ;             text that will print in the field's positions
     110 ;
     111 ; esg - 8/14/06 - modified for the new cms-1500 form - IB*2*348
     112 ;
     113 N Z,IBLINE,IBVAL,IBS,IBE,IBTEXT,IBAUX,IBDAT,IBZ,IBREN,IBRENQ,IBRENNPI,IBRENSID
     114 K IBXDATA
     115 S (IBLINE,Z)=0 S:$G(IBSUB)="" IBSUB="BOX24"
     116 ;
     117 I FLD="I"!(FLD="J") D   ; extract the Rendering provider data
     118 . I '$G(IBXIEN) Q       ; assume that the claim# exists
     119 . S IBREN=$$CFIDS^IBCEF77(IBXIEN)
     120 . S IBRENQ=$P(IBREN,U,1)    ; qual
     121 . S IBRENSID=$P(IBREN,U,2)  ; id
     122 . S IBRENNPI=$P(IBREN,U,3)  ; npi
     123 . Q
     124 ;
     125 F  S Z=$O(IBXSAVE(IBSUB,Z)) Q:'Z  D
     126 . S IBDAT=$G(IBXSAVE(IBSUB,Z))
     127 . S IBAUX=$G(IBXSAVE(IBSUB,Z,"AUX"))
     128 . S IBTEXT=$G(IBXSAVE(IBSUB,Z,"TEXT"))
     129 . S IBZ=$P(IBAUX,U,9)
     130 . I IBZ="" S IBZ="  "
     131 . S IBTEXT=IBZ_IBTEXT
     132 . ;
     133 . I $S($G(IBAC)=4:$S($D(IBXSAVE(IBSUB,Z,"ARX")):1,1:$D(IBXSAVE(IBSUB,Z,"A"))),$D(IBXSAVE(IBSUB,Z,"RX")):0,1:$G(IBNOSHOW)) S IBTEXT=""
     134 . ;
     135 . I FLD="AF" S IBVAL=$P(IBDAT,U),IBS=1,IBE=9 D   ; From date of service
     136 .. S IBVAL=$E(IBVAL,1,2)_" "_$E(IBVAL,3,4)_" "_$E(IBVAL,7,8)
     137 .. Q
     138 . ;
     139 . I FLD="AT" S IBVAL=$S($P(IBDAT,U,2):$P(IBDAT,U,2),1:$P(IBDAT,U)),IBS=10,IBE=18 D    ; To date of service
     140 .. S IBVAL=$E(IBVAL,1,2)_" "_$E(IBVAL,3,4)_" "_$E(IBVAL,7,8)
     141 .. Q
     142 . ;
     143 . I FLD="B" S IBVAL=$P(IBDAT,U,3),IBS=19,IBE=21   ; place of service
     144 . I FLD="C" S IBVAL=$S($P(IBDAT,U,13)=1:"Y",1:""),IBS=22,IBE=24   ; emergency indicator
     145 . I FLD="D" S IBVAL=$P(IBDAT,U,5),IBS=25,IBE=44 D   ; procedures and modifiers
     146 .. N M S M=$$MODLST^IBEFUNC($P(IBDAT,U,10))       ; modifier list
     147 .. S IBVAL=$$FO^IBCNEUT1(IBVAL,6)_"  "            ; procedure code
     148 .. S IBVAL=IBVAL_$$FO^IBCNEUT1($P(M,",",1),3)     ; mod#1
     149 .. S IBVAL=IBVAL_$$FO^IBCNEUT1($P(M,",",2),3)     ; mod#2
     150 .. S IBVAL=IBVAL_$$FO^IBCNEUT1($P(M,",",3),3)     ; mod#3
     151 .. S IBVAL=IBVAL_$$FO^IBCNEUT1($P(M,",",4),3)     ; mod#4
     152 .. Q
     153 . ;
     154 . I FLD="E" S IBVAL=$TR($P(IBDAT,U,7),","),IBS=45,IBE=48  ; diagnosis pointer
     155 . I FLD="F" S IBVAL=$P(IBDAT,U,8)*$P(IBDAT,U,9),IBS=49,IBE=57 D
     156 .. ; total charges
     157 .. S IBVAL=$$DOL^IBCEF77(IBVAL,9)
     158 .. Q
     159 . ;
     160 . I FLD="G" S IBVAL=$S($P(IBDAT,U,12):$P(IBDAT,U,12),1:$P(IBDAT,U,9)),IBS=58,IBE=61 D
     161 .. ; days or units or anesthesia minutes
     162 .. S IBVAL=$J(+IBVAL,4)
     163 .. Q
     164 . ;
     165 . ; columns H,I,J don't have any free text supplemental information
     166 . ;
     167 . I FLD="H" D     ; epsdt family plan
     168 .. S IBVAL=$P(IBAUX,U,7),IBS=0,IBE=0,IBTEXT=""   ; line 1 blank
     169 .. I IBVAL S IBVAL="Y"
     170 .. Q
     171 . I FLD="I" D     ; ID qualifier for rendering provider
     172 .. S IBVAL="",IBS=1,IBE=2   ; line 2 blank
     173 .. S IBTEXT=$G(IBRENQ)      ; qualifier on line 1
     174 .. Q
     175 . I FLD="J" D     ; rendering provider ID and NPI
     176 .. S IBTEXT=$G(IBRENSID),IBS=1,IBE=11   ; secondary ID line 1
     177 .. S IBVAL=$G(IBRENNPI)                 ; NPI# line 2
     178 .. Q
     179 . ;
     180 . S IBLINE=IBLINE+1                      ; top line
     181 . S IBXDATA(IBLINE)=$E(IBTEXT,IBS,IBE)   ; text in shaded area (top)
     182 . S IBLINE=IBLINE+1             ; bottom line
     183 . S IBXDATA(IBLINE)=IBVAL       ; field value in unshaded area (bottom)
     184 . Q
     185 ;
     186 Q
     187 ;
     188BILLSPEC(IBIFN,IBPRV) ;  Returns the specialty of the provider on bill IBIFN
     189 ; If IBPRV is supplied, returns the data for that provider, otherwise,
     190 ;  returns the specialty of the 'main/required' provider on the bill.
     191 ;  Default = 99 if no valid code found
     192 ; IBPRV = vp of provider (file 200 or 355.93)
     193 N Z,IBSPEC,IBINS,IBDT
     194 S IBSPEC="",IBPRV=$G(IBPRV)
     195 S IBDT=$P($G(^DGCR(399,+IBIFN,"U")),U,1)  ; use statement from date
     196 ;
     197 I $G(IBPRV) D  G SPECQ
     198 . S IBSPEC=$$SPEC^IBCEU(IBPRV,IBDT)
     199 ;
     200 ;Get rendering for professional, attending for institutional,
     201 S IBINS=($$FT^IBCEF(IBIFN)=3)
     202 D GETPRV^IBCEU(IBIFN,"ALL",.IBPRV)
     203 S Z=$S('IBINS:3,1:4)
     204 I $G(IBPRV(Z,1))'="" D
     205 . I $P(IBPRV(Z,1),U,3) S IBSPEC=$$SPEC^IBCEU($P($G(IBPRV(Z,1)),U,3),IBDT) Q:IBSPEC'=""
     206 . S Z0=+$O(^DGCR(399,IBIFN,"PRV","B",Z,0))
     207 . I Z0,$P($G(^DGCR(399,IBIFN,"PRV",Z0,0)),U,8)'="" S IBSPEC=$P(^(0),U,8)
     208 ;
     209SPECQ I IBSPEC="" S IBSPEC="99"
     210 Q IBSPEC
     211 ;
     212CHAMPVA(IBIFN) ; Returns 1 if the bill IBIFN has a CHAMPVA rate type
     213 Q $E($P($G(^DGCR(399.3,+$P($G(^DGCR(399,IBIFN,0)),U,7),0)),U),1,7)="CHAMPVA"
     214 ;
     215FAC(IBIFN) ; Is facility always to print in box 32 for bill ien IBIFN?
     216 ;  Returns 1 if yes, 0 if no
     217 Q $S($P($G(^DGCR(399,IBIFN,"UF2")),U,2):1,1:$P($G(^IBE(350.9,1,2)),U,12))
     218 ;
     219MCR24K(IBIFN) ;Function returns MEDICARE id# for professional (CMS-1500) box 24k for bill IBIFN if appropriate
     220 Q $S($$FT^IBCEF(IBIFN)=2&$$MCRONBIL^IBEFUNC(IBIFN):"V"_$$MCRSPEC^IBCEU4(IBIFN,1)_$P($$SITE^VASITE,U,3),1:"")

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEU6.m

    r613 r623  
    1 IBCEU6  ;ALB/ESG - EDI UTILITIES FOR EOB PROCESSING ;29-JUL-2003
    2         ;;2.0;INTEGRATED BILLING;**155,371**;21-MAR-94;Build 57
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         Q
    5         ;
    6 COBLINE(IBIFN,IBI,IBXDATA,SORT,IBXTRA)  ; Extract all COB data for line item
    7         ;  from file 361.1 (EOB), subfile 15 into IBXDATA(IBI,"COB",n)
    8         ;
    9         ; IBIFN = bill entry #
    10         ; IBI = VistA outbound line item #
    11         ; IBXDATA = array returned with COB line item data/pass by reference
    12         ; SORT = flag that determines whether the data should be sorted for
    13         ;        output for the 837 record ('PR' group always there and has
    14         ;        a reason code for deductible first and co-insurance second -
    15         ;        even if they are 0).
    16         ;        1 = sort, 0 = no sort needed
    17         ;
    18         ;   Returns IBXDATA(IBI,"COB",COB,n) with COB data for each line item
    19         ;      found in an accepted EOB for the bill and = the '0' node data of
    20         ;      file 361.115 (LINE LEVEL ADJUSTMENTS)
    21         ;         -- AND --
    22         ;    IBXDATA(IBI,"COB",COB,n,z,p)=
    23         ;           the data on the '0' node for each subordinate entry of file
    24         ;           361.11511 (REASONS) (Only first 3 pieces for 837 output)
    25         ;               z = this is either piece 1 of the 0-node for subfile
    26         ;                   361.1151 (ADJUSTMENTS)
    27         ;                          OR
    28         ;                   for the 837 COB 'sorted' output, this will be ' PR'
    29         ;                    for the forced/extracted entries for deductible
    30         ;                    and co-insurance so they are always output first
    31         ;                    The space needs to be stripped off on output
    32         ;         -- AND --
    33         ; IBXTRA = array returned if passed by reference if line is found
    34         ;          associated with line IBI due to bundling/unbundling
    35         ;          IBXTRA("ALL",x,paid procedure)=COB SEQ ^ seq # corresponding
    36         ;                        to subscript n in IBXDATA(,"COB",COB,n
    37         ;                (x = line #-original proc-service dt)
    38         ;
    39         N A,B,B1,C,D,IBDATA,IB0,IB00,IBA,IBB,IBDED,IBCOI,IBS,IBN,IBDT
    40         ;
    41         ; If multiple EOB's reference this line for the same COB sequence,
    42         ;   extract only the last one marked accepted containing this line item.
    43         ;
    44         S A=0
    45         F  S A=$O(^IBM(361.1,"B",IBIFN,A)) Q:'A  D
    46         . I '$$EOBELIG^IBCEU1(A) Q   ; eob not eligible for secondary claim
    47         . I '$D(^IBM(361.1,A,15,"AC",IBI)) Q   ; this EOB does not reference VistA line# IBI
    48         . S IBA=0
    49         . S IBDATA=$G(^IBM(361.1,A,0))
    50         . S IBS=$P(IBDATA,U,15)      ; insurance sequence#
    51         . S IBN=+$O(IBXDATA(IBI,"COB",IBS,0))
    52         . I IBN D  Q:IBN  ; check for later EOB
    53         .. I $G(IBDT(IBI,IBS)),IBDT(IBI,IBS)<$P(IBDATA,U,6) K IBDT(IBI,IBS),IBXDATA(IBI,"COB",IBS) S IBN=0
    54         . ;
    55         . S IBDT(IBI,IBS)=$P(IBDATA,U,6)
    56         . S B=0
    57         . F  S B=$O(^IBM(361.1,A,15,"AC",IBI,B)) Q:'B  S IB0=$G(^IBM(361.1,A,15,B,0)),IB0=IB0_U_IBDT(IBI,IBS) D
    58         .. Q:$TR(IB0,U)=""
    59         .. S IBA=IBA+1,IBXDATA(IBI,"COB",IBS,IBA)=IBI_U_IB0
    60         .. ;
    61         .. ; capture the modifiers (361.1152)
    62         .. I $D(^IBM(361.1,A,15,B,2)) M IBXDATA(IBI,"COBMOD")=^IBM(361.1,A,15,B,2)
    63         .. I $P(IB0,U,15)'="" D  ;Line involved in bundling/unbundling
    64         ... N Z0 S Z0=IBI_"-"_$P(IB0,U,15)_"-"_$P(IB0,U,16)
    65         ... S IBXTRA("ALL",Z0,$P(IB0,U,4))=IBS_U_IBA,$P(IBXDATA(IBI,"COB",IBS,IBA),U)=""
    66         .. S C=0,(IBDED(IBA),IBCOI(IBA))="0^0" ;Assume 0 if not found in list
    67         .. F  S C=$O(^IBM(361.1,A,15,B,1,C)) Q:'C  S IB0=$G(^(C,0)) D
    68         ... S D=0
    69         ... F  S D=$O(^IBM(361.1,A,15,B,1,C,1,D)) Q:'D  S IB00=$S($G(SORT):$P($G(^(D,0)),U,1,3),1:$G(^(D,0))) D
    70         .... I $G(SORT),$P(IB0,U)="PR" D  ;Check for deductible or co-ins
    71         ..... I 'IBDED(IBA),$P(IB00,U)=1 S IBDED(IBA)=IB00,IB00="" Q
    72         ..... I 'IBCOI(IBA),$P(IB00,U)=2 S IBCOI(IBA)=IB00,IB00="" Q
    73         .... I $TR(IB00,U)'="" S IBB=$O(IBXDATA(IBI,"COB",IBS,IBA,$P(IB0,U),""),-1)+1,IBXDATA(IBI,"COB",IBS,IBA,$P(IB0,U),IBB)=IB00
    74         .. Q:'$G(SORT)
    75         .. S IBXDATA(IBI,"COB",IBS,IBA," PR",1)=IBDED(IBA)
    76         .. S IBXDATA(IBI,"COB",IBS,IBA," PR",2)=IBCOI(IBA)
    77         Q
    78         ;
     1IBCEU6 ;ALB/ESG - EDI UTILITIES FOR EOB PROCESSING ;29-JUL-2003
     2 ;;2.0;INTEGRATED BILLING;**155**;21-MAR-94
     3 ;
     4 Q
     5 ;
     6COBLINE(IBIFN,IBI,IBXDATA,SORT,IBXTRA) ; Extract all COB data for line item
     7 ;  from file 361.1 (EOB), subfile 15 into IBXDATA(IBI,"COB",n)
     8 ;
     9 ; IBIFN = bill entry #
     10 ; IBI = VistA outbound line item #
     11 ; IBXDATA = array returned with COB line item data/pass by reference
     12 ; SORT = flag that determines whether the data should be sorted for
     13 ;        output for the 837 record ('PR' group always there and has
     14 ;        a reason code for deductible first and co-insurance second -
     15 ;        even if they are 0).
     16 ;        1 = sort, 0 = no sort needed
     17 ;
     18 ;   Returns IBXDATA(IBI,"COB",COB,n) with COB data for each line item
     19 ;      found in an accepted EOB for the bill and = the '0' node data of
     20 ;      file 361.115 (LINE LEVEL ADJUSTMENTS)
     21 ;         -- AND --
     22 ;    IBXDATA(IBI,"COB",COB,n,z,p)=
     23 ;           the data on the '0' node for each subordinate entry of file
     24 ;           361.11511 (REASONS) (Only first 3 pieces for 837 output)
     25 ;               z = this is either piece 1 of the 0-node for subfile
     26 ;                   361.1151 (ADJUSTMENTS)
     27 ;                          OR
     28 ;                   for the 837 COB 'sorted' output, this will be ' PR'
     29 ;                    for the forced/extracted entries for deductible
     30 ;                    and co-insurance so they are always output first
     31 ;                    The space needs to be stripped off on output
     32 ;         -- AND --
     33 ; IBXTRA = array returned if passed by reference if line is found
     34 ;          associated with line IBI due to bundling/unbundling
     35 ;          IBXTRA("ALL",x,paid procedure)=COB SEQ ^ seq # corresponding
     36 ;                        to subscript n in IBXDATA(,"COB",COB,n
     37 ;                (x = line #-original proc-service dt)
     38 ;
     39 N A,B,B1,C,D,IBDATA,IB0,IB00,IBA,IBB,IBDED,IBCOI,IBS,IBN,IBDT
     40 ;
     41 ; If multiple EOB's reference this line for the same COB sequence,
     42 ;   extract only the last one marked accepted containing this line item.
     43 ;
     44 S A=0
     45 F  S A=$O(^IBM(361.1,"B",IBIFN,A)) Q:'A  D
     46 . I '$$EOBELIG^IBCEU1(A) Q   ; eob not eligible for secondary claim
     47 . S IBA=0
     48 . S IBDATA=$G(^IBM(361.1,A,0))
     49 . S IBS=$P(IBDATA,U,15)      ; insurance sequence#
     50 . S IBN=+$O(IBXDATA(IBI,"COB",IBS,0))
     51 . I IBN D  Q:IBN  ; check for later EOB
     52 .. I $G(IBDT(IBI,IBS)),IBDT(IBI,IBS)<$P(IBDATA,U,6) K IBDT(IBI,IBS),IBXDATA(IBI,"COB",IBS) S IBN=0
     53 . ;
     54 . S IBDT(IBI,IBS)=$P(IBDATA,U,6)
     55 . S B=0
     56 . F  S B=$O(^IBM(361.1,A,15,"AC",IBI,B)) Q:'B  S IB0=$G(^IBM(361.1,A,15,B,0)),IB0=IB0_U_IBDT(IBI,IBS) D
     57 .. Q:$TR(IB0,U)=""
     58 .. S IBA=IBA+1,IBXDATA(IBI,"COB",IBS,IBA)=IBI_U_IB0
     59 .. ;
     60 .. ; capture the modifiers (361.1152)
     61 .. I $D(^IBM(361.1,A,15,B,2)) M IBXDATA(IBI,"COBMOD")=^IBM(361.1,A,15,B,2)
     62 .. I $P(IB0,U,15)'="" D  ;Line involved in bundling/unbundling
     63 ... N Z0 S Z0=IBI_"-"_$P(IB0,U,15)_"-"_$P(IB0,U,16)
     64 ... S IBXTRA("ALL",Z0,$P(IB0,U,4))=IBS_U_IBA,$P(IBXDATA(IBI,"COB",IBS,IBA),U)=""
     65 .. S C=0,(IBDED(IBA),IBCOI(IBA))="0^0" ;Assume 0 if not found in list
     66 .. F  S C=$O(^IBM(361.1,A,15,B,1,C)) Q:'C  S IB0=$G(^(C,0)) D
     67 ... S D=0
     68 ... F  S D=$O(^IBM(361.1,A,15,B,1,C,1,D)) Q:'D  S IB00=$S($G(SORT):$P($G(^(D,0)),U,1,3),1:$G(^(D,0))) D
     69 .... I $G(SORT),$P(IB0,U)="PR" D  ;Check for deductible or co-ins
     70 ..... I 'IBDED(IBA),$P(IB00,U)=1 S IBDED(IBA)=IB00,IB00="" Q
     71 ..... I 'IBCOI(IBA),$P(IB00,U)=2 S IBCOI(IBA)=IB00,IB00="" Q
     72 .... I $TR(IB00,U)'="" S IBB=$O(IBXDATA(IBI,"COB",IBS,IBA,$P(IB0,U),""),-1)+1,IBXDATA(IBI,"COB",IBS,IBA,$P(IB0,U),IBB)=IB00
     73 .. Q:'$G(SORT)
     74 .. S IBXDATA(IBI,"COB",IBS,IBA," PR",1)=IBDED(IBA)
     75 .. S IBXDATA(IBI,"COB",IBS,IBA," PR",2)=IBCOI(IBA)
     76 Q
     77 ;

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEXTRP.m

    r613 r623  
    1 IBCEXTRP        ;ALB/JEH - VIEW/PRINT EDI EXTRACT DATA ;4/22/03 9:59am
    2         ;;2.0;INTEGRATED BILLING;**137,197,211,348,349,377**;21-MAR-94;Build 23
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5 EN      ;
    6 INIT    ;
    7         W !!,"This option will display the EDI extract data for a bill.",!
    8         N IBREC1,IBIEN,IBINC,DIC,X,Y,DIR,IB364IEN,IBVNUM,IBSEG,STOP,POP,DTOUT,DUOUT
    9         ;
    10         N DPTNOFZY S DPTNOFZY=1 ; Suppress PATIENT file fuzzy lookups
    11         S DIC="^DGCR(399,",DIC(0)="AEMQ",DIC("S")="I 234[$P(^(0),U,13)" D ^DIC
    12         I Y<1 G EXITQ
    13         S IBIEN=+Y,IBREC1=$G(^DGCR(399,IBIEN,0))
    14         S IB364IEN=$$LAST364^IBCEF4(IBIEN) I +$G(IB364IEN)=0 D  G EXITQ
    15         . W !,"There is no entry in the EDI Transmit Bill file for this bill number."
    16         S IBVNUM=$P($G(^IBA(364,IB364IEN,0)),U,2) I +$G(IBVNUM)=0 D  G EXITQ
    17         . W !!,"There is no batch # for this bill.  It has not been transmitted."
    18         S IBVNUM=$P($G(^IBA(364.1,IBVNUM,0)),U)
    19         S DIR("A")="Include Fields With No Data?: ",DIR("B")="NO",DIR(0)="YA"
    20         W ! D ^DIR K DIR
    21         I $D(DTOUT)!$D(DUOUT) G EXITQ
    22         S IBINC=+Y
    23         ;
    24         ; IB*2*377 - esg - Ask for specific EDI segments to view
    25         ;
    26         W !
    27         S DIR(0)="SA^A:All EDI Segments;S:Selected EDI Segments"
    28         S DIR("A")="Include (A)ll or (S)elected EDI Segments?: "
    29         S DIR("B")="All EDI Segments"
    30         D ^DIR K DIR
    31         I $D(DTOUT)!$D(DUOUT) G EXITQ
    32         I Y="A" G DEV                    ; all segments, skip to device prompt
    33         ;
    34         W !
    35         K IBSEG
    36         S STOP=0
    37         F  D  Q:STOP
    38         . S DIR(0)="FO^3:4"
    39         . S DIR("A")=" Select EDI Segment"
    40         . I $D(IBSEG) S DIR("A")="Another EDI Segment"
    41         . S DIR("?")="Enter the name of the EDI segment to include."
    42         . D ^DIR K DIR
    43         . I $D(DTOUT)!$D(DUOUT) S STOP=1 Q
    44         . S Y=$$UP^XLFSTR(Y),Y=$$TRIM^XLFSTR(Y)   ; uppercase/trim spaces
    45         . I Y="" S STOP=1 Q
    46         . S IBSEG(Y)=""
    47         . Q
    48         I $D(DTOUT)!$D(DUOUT) G EXITQ
    49         ;
    50 DEV     ; - Select device
    51         N %ZIS,ZTRTN,ZTSAVE,ZTDESC
    52         W !
    53         S %ZIS="QM" D ^%ZIS G:POP EXITQ
    54         I $D(IO("Q")) D  G EXITQ
    55         . S ZTRTN="LIST^IBCEXTRP",ZTDESC="Transmitted Bill Extract Data"
    56         . S ZTSAVE("IB*")=""
    57         . D ^%ZTLOAD
    58         . W !!,$S($D(ZTSK):"Your task number "_ZTSK_" has been queued.",1:"Unable to queue this job.")
    59         .K ZTSK,IO("Q") D HOME^%ZIS
    60         U IO
    61         ;
    62 LIST    ; - set up array and print data
    63         N IBPG,IBSEQ,IBPC,IBDA,IBREC,IBQUIT,IBILL,IBLINE,IBXDATA,IBERR,IBXERR,Z,Z0,Z1
    64         D EXTRACT(IBIEN,IBVNUM,8,1)
    65         S (IBPG,IBQUIT,IBSEQ,IBPC,IBDA,IBLINE)=0
    66         K ^TMP($J,"IBLINES")
    67         ;IB*2.0*211 - rely on form type instead of bill charge type
    68         N IBFMTYP S IBFMTYP=$$FT^IBCEF(IBIEN)
    69         S IBFMTYP=$S(IBFMTYP=2:"CMS-1500",IBFMTYP=3:"UB-04",1:"OTHER"_"("_IBFMTYP_")")
    70         S IBILL=$S($$INPAT^IBCEF(IBIEN,1):"Inpt",1:"Oupt")_"/"_IBFMTYP
    71         ;
    72         I $D(^TMP("IBXERR",$J)) D  G EXITQ
    73         . S IBERR=0 F  S IBERR=$O(^TMP("IBXERR",$J,IBERR)) Q:'IBERR  W !,$G(^TMP("IBXERR",$J,IBERR))
    74         . Q
    75         ;
    76         F  S IBSEQ=$O(^IBA(364.6,"ASEQ",8,IBSEQ)) Q:'IBSEQ  I $$INCLUDE(IBSEQ) F  S IBPC=$O(^IBA(364.6,"ASEQ",8,IBSEQ,1,IBPC)) Q:'IBPC  F  S IBDA=$O(^IBA(364.6,"ASEQ",8,IBSEQ,1,IBPC,IBDA)) Q:'IBDA  D
    77         . N IBOK,Z,IBMULT,DSP,IBDATA,PCD,SN
    78         . S IBREC=$G(^IBA(364.6,IBDA,0))
    79         . I $P(IBREC,U,11)=1 Q     ; calculate only field
    80         . ;
    81         . ; processing for piece 1 of this EDI segment to see if there is any
    82         . ; other data that exists in this segment
    83         . I IBPC=1 S IBOK=0 D
    84         .. S Z=1 F  S Z=$O(^TMP("IBXDATA",$J,1,IBSEQ,1,Z)) Q:'Z  I $G(^(Z))'="" S IBOK=1 Q
    85         .. I IBOK Q   ; data exists so include segment normally
    86         .. S SN=$P($G(^TMP("IBXDATA",$J,1,IBSEQ,1,1)),U,1)   ; segment name
    87         .. I SN="" S SN=$P($P(IBREC,U,10),"'",2)
    88         .. S SN=SN_" (No Data - Record Not Sent)"
    89         .. S $P(^TMP("IBXDATA",$J,1,IBSEQ,1,1),U,1)=SN
    90         .. Q
    91         . ;
    92         . ; loop thru all multiple occurrences of this segment
    93         . S IBMULT=0 F  S IBMULT=$O(^TMP("IBXDATA",$J,1,IBSEQ,IBMULT)) Q:'IBMULT   D
    94         .. ;
    95         .. ; field with no data; check user preference
    96         .. I '$G(IBINC),$P($G(^TMP("IBXDATA",$J,1,IBSEQ,IBMULT,IBPC)),U,1)="" Q
    97         .. ;
    98         .. ; build display data
    99         .. S PCD="["_IBPC_"] "      ; piece#
    100         .. S DSP=$P(IBREC,U,10)     ; short description field
    101         .. S IBDATA=$P($G(^TMP("IBXDATA",$J,1,IBSEQ,IBMULT,IBPC)),U,1)   ; data
    102         .. S DSP=$J(PCD,5)_$$FO^IBCNEUT1(DSP,40)_": "_IBDATA
    103         .. S ^TMP($J,"IBLINES",IBSEQ,IBMULT,IBPC)=DSP
    104         .. Q
    105         . Q
    106         ;
    107         S IBQUIT=0
    108         W:$E(IOST,1,2)["C-" @IOF ; initial form feed for screen print
    109         N IBFMTYP S IBFMTYP=$$FT^IBCEF(IBIEN)
    110         S IBFMTYP=$S(IBFMTYP=2:"CMS-1500",IBFMTYP=3:"UB-04",1:"OTHER"_"("_IBFMTYP_")")
    111         S IBILL=$S($$INPAT^IBCEF(IBIEN,1):"Inpt",1:"Oupt")_"/"_IBFMTYP
    112         D HDR
    113         S Z=0 F  S Z=$O(^TMP($J,"IBLINES",Z)) Q:'Z!IBQUIT  S Z0=0 F  S Z0=$O(^TMP($J,"IBLINES",Z,Z0)) Q:'Z0!IBQUIT  S Z1=0 F  S Z1=$O(^TMP($J,"IBLINES",Z,Z0,Z1)) Q:'Z1!IBQUIT  D  Q:IBQUIT
    114         . I IBLINE>(IOSL-3) D HDR Q:IBQUIT
    115         . W !,^TMP($J,"IBLINES",Z,Z0,Z1)
    116         . S IBLINE=IBLINE+1
    117         . I IBLINE>(IOSL-3) D HDR Q:IBQUIT
    118         . ;
    119         . ; end of segment add an extra line feed
    120         . I '$O(^TMP($J,"IBLINES",Z,Z0,Z1)) W ! S IBLINE=IBLINE+1
    121         . Q
    122         ;
    123         K ^TMP($J,"IBLINES")
    124         G EXITQ
    125         ;
    126         ;
    127 HDR     ; - Report header
    128         N DIR,Y
    129         I IBPG D  Q:IBQUIT
    130         . I $E(IOST,1,2)["C-" K DIR S DIR(0)="E" D ^DIR K DIR S IBQUIT=('Y) Q:IBQUIT
    131         . W @IOF
    132         ;
    133         S IBPG=IBPG+1
    134         W !,?25,"EDI Transmitted Bill Extract Data",!,"Bill #",?11,"Type",?27,"Patient Name",?52,"SSN",?57,$$FMTE^XLFDT(DT),?71,"Page: "_IBPG
    135         W !,$TR($J("",IOM)," ","=")
    136         W !,$P(IBREC1,U)_" "_"("_IBILL_")",?27,$P($G(^DPT(+$P(IBREC1,U,2),0)),U),?52,$P($G(^DPT($P(IBREC1,U,2),0)),U,9),!
    137         S IBLINE=6
    138         Q
    139         ;
    140 EXITQ   ; - clean up and exit
    141         I $E(IOST,1,2)["C-",'$G(IBQUIT) K DIR S DIR(0)="E" W ! D ^DIR K DIR
    142         K ^TMP("IBXERR",$J),^TMP("IBXDATA",$J),IBXERR
    143         D CLEAN^DILF
    144         Q
    145         ;
    146 EXTRACT(IBIFN,IBBATCH,IBFORM,IBLOCAL)   ; Extracts transmitted form data into global
    147         ; ^TMP("IBXDATA",$J).  Errors are in ^TMP("IBXERR",$J,err_num)=text.
    148         ; IBBATCH = Batch # of bill (if known), otherwise, set to 1.  This
    149         ;          variable must be > 0 to prevent a new batch from being added
    150         ; IBFORM = the ien of the form in file 353
    151         ; IBLOCAL = 1 if OK to use local form, 0 if not
    152         N IBVNUM,IBL,IBINC,IBSEG
    153         D FORMPRE^IBCFP1
    154         S IBVNUM=$G(IBBATCH)
    155         S IBL=$S('$G(IBLOCAL):IBFORM,1:"") ; No local form ... set = main form
    156         ; Get local form associated with parent, if any
    157         I IBL="" S IBL=$S($P($G(^IBE(353,+IBFORM,2)),U,8):$P(^(2),U,8),1:IBFORM)
    158         D SETUP^IBCE837(1)
    159         D ROUT^IBCFP1(IBFORM,1,IBIFN,0,IBL)
    160         Q
    161         ;
    162 INCLUDE(IBSEQ)  ; Function to determine if segment should be included or not
    163         N OK,LZ,SEGNAME
    164         S OK=1                   ; default is to include it
    165         I '$D(IBSEG) G INCLX     ; if nothing in array, then include all
    166         I '$D(^TMP("IBXDATA",$J,1,IBSEQ)) S OK=0 G INCLX        ; no data there
    167         S LZ=+$O(^TMP("IBXDATA",$J,1,IBSEQ,""))   ; first line# found in data
    168         S SEGNAME=$P($G(^TMP("IBXDATA",$J,1,IBSEQ,LZ,1)),U,1)   ; piece 1
    169         S SEGNAME=$$TRIM^XLFSTR(SEGNAME)
    170         I SEGNAME'="",'$D(IBSEG(SEGNAME)) S OK=0   ; don't include
    171 INCLX   ;
    172         Q OK
    173         ;
     1IBCEXTRP ;ALB/JEH - VIEW/PRINT EDI EXTRACT DATA ; 4/22/03 9:59am
     2 ;;2.0;INTEGRATED BILLING;**137,197,211,348,349**;21-MAR-94;Build 46
     3 ;;Per VHA Directive 2004-038, this routine should not be modified.
     4 ;
     5EN ;
     6INIT ;
     7 W !!,"This option will display the EDI extract data for a bill.",!
     8 N IBREC1,IBIEN,IBINC,DIC,X,Y,DIR,IB364IEN,IBVNUM
     9 ;
     10 N DPTNOFZY S DPTNOFZY=1 ; Suppress PATIENT file fuzzy lookups
     11 S DIC="^DGCR(399,",DIC(0)="AEMQ",DIC("S")="I 234[$P(^(0),U,13)" D ^DIC
     12 I Y<1 G EXITQ
     13 S IBIEN=+Y,IBREC1=$G(^DGCR(399,IBIEN,0))
     14 S IB364IEN=$$LAST364^IBCEF4(IBIEN) I +$G(IB364IEN)=0 D  G EXITQ
     15 . W !,"There is no entry in the EDI Transmit Bill file for this bill number."
     16 S IBVNUM=$P($G(^IBA(364,IB364IEN,0)),U,2) I +$G(IBVNUM)=0 D  G EXITQ
     17 . W !!,"There is no batch # for this bill.  It has not been transmitted."
     18 S IBVNUM=$P($G(^IBA(364.1,IBVNUM,0)),U)
     19 S DIR("A")="INCLUDE FIELDS WITH NO DATA?: ",DIR("B")="NO",DIR(0)="YA" D ^DIR K DIR
     20 I $D(DTOUT)!$D(DUOUT) G EXITQ
     21 S IBINC=+Y
     22DEV ; - Select device
     23 N %ZIS,ZTRTN,ZTSAVE,ZTDESC
     24 S %ZIS="QM" D ^%ZIS G:POP EXITQ
     25 I $D(IO("Q")) D  G EXITQ
     26 . S ZTRTN="LIST^IBCEXTRP",ZTDESC="Transmitted Bill Extract Data"
     27 . S ZTSAVE("IB*")=""
     28 . D ^%ZTLOAD
     29 . W !!,$S($D(ZTSK):"Your task number "_ZTSK_" has been queued.",1:"Unable to queue this job.")
     30 .K ZTSK,IO("Q") D HOME^%ZIS
     31 U IO
     32 ;
     33LIST ; - set up array and print data
     34 N IBPG,IBSEQ,IBPC,IBDA,IBREC,IBQUIT,IBILL,IBLINE,IBXDATA,IBERR,IBXERR,Z,Z0,Z1
     35 D EXTRACT(IBIEN,IBVNUM,8,1)
     36 S (IBPG,IBQUIT,IBSEQ,IBPC,IBDA,IBLINE)=0
     37 K ^TMP($J,"IBLINES")
     38 ;IB*2.0*211 - rely on form type instead of bill charge type
     39 N IBFMTYP S IBFMTYP=$$FT^IBCEF(IBIEN)
     40 S IBFMTYP=$S(IBFMTYP=2:"CMS-1500",IBFMTYP=3:"UB-04",1:"OTHER"_"("_IBFMTYP_")")
     41 S IBILL=$S($$INPAT^IBCEF(IBIEN,1):"Inpt",1:"Oupt")_"/"_IBFMTYP
     42 I $D(^TMP("IBXERR",$J)) D  G EXITQ
     43 . S IBERR=0 F  S IBERR=$O(^TMP("IBXERR",$J,IBERR)) Q:'IBERR  W !,$G(^TMP("IBXERR",$J,IBERR))
     44 F  S IBSEQ=$O(^IBA(364.6,"ASEQ",8,IBSEQ)) Q:'IBSEQ!(IBQUIT)  F  S IBPC=$O(^IBA(364.6,"ASEQ",8,IBSEQ,1,IBPC)) Q:'IBPC!(IBQUIT)  F  S IBDA=$O(^IBA(364.6,"ASEQ",8,IBSEQ,1,IBPC,IBDA)) Q:'IBDA!(IBQUIT)  S IBREC=$G(^IBA(364.6,IBDA,0)) D  Q:IBQUIT
     45 . N IBOK,Z,IBMULT
     46 . I $P(IBREC,U,11)=1 Q
     47 . I IBPC=1 S IBOK=0 D
     48 .. S Z=1 F  S Z=$O(^TMP("IBXDATA",$J,1,IBSEQ,1,Z)) Q:'Z  I $G(^(Z))'="" S IBOK=1 Q
     49 .. I 'IBOK S $P(^TMP("IBXDATA",$J,1,IBSEQ,1,1),U)=$P($G(^TMP("IBXDATA",$J,1,IBSEQ,1,1)),U)_"  (NO DATA - RECORD NOT SENT)"
     50 . S IBMULT=0 F  S IBMULT=$O(^TMP("IBXDATA",$J,1,IBSEQ,IBMULT)) Q:'IBMULT   D
     51 .. I '$G(IBINC),$P($G(^TMP("IBXDATA",$J,1,IBSEQ,IBMULT,IBPC)),U)="" Q
     52 .. S ^TMP($J,"IBLINES",IBSEQ,IBMULT,IBPC)=$E($P(IBREC,U,10)_$J("",30),1,30)_": "_$P($G(^TMP("IBXDATA",$J,1,IBSEQ,IBMULT,IBPC)),U)
     53 .
     54 W:$E(IOST,1,2)["C-" @IOF ; initial form feed for screen print
     55 N IBFMTYP S IBFMTYP=$$FT^IBCEF(IBIEN)
     56 S IBFMTYP=$S(IBFMTYP=2:"CMS-1500",IBFMTYP=3:"UB-04",1:"OTHER"_"("_IBFMTYP_")")
     57 S IBILL=$S($$INPAT^IBCEF(IBIEN,1):"Inpt",1:"Oupt")_"/"_IBFMTYP
     58 D HDR
     59 S Z=0 F  S Z=$O(^TMP($J,"IBLINES",Z)) Q:'Z  S Z0=0 F  S Z0=$O(^TMP($J,"IBLINES",Z,Z0)) Q:'Z0  S Z1=0 F  S Z1=$O(^TMP($J,"IBLINES",Z,Z0,Z1)) Q:'Z1  D  G:IBQUIT Q1
     60 . D:IBLINE>(IOSL-5) HDR Q:IBQUIT
     61 . W !,^TMP($J,"IBLINES",Z,Z0,Z1)
     62 . S IBLINE=IBLINE+1
     63Q1 K ^TMP($J,"IBLINES")
     64 Q
     65 ;
     66HDR ; - Report header
     67 N DIR,Y
     68 I IBPG D  Q:IBQUIT
     69 . I $E(IOST,1,2)["C-" K DIR S DIR(0)="E" D ^DIR K DIR S IBQUIT=('Y) Q:IBQUIT
     70 . W @IOF
     71 ;
     72 S IBPG=IBPG+1
     73 W !!,?25,"EDI Transmitted Bill Extract Data",!,"Bill #",?11,"Type",?27,"Patient Name",?52,"SSN",?57,$$FMTE^XLFDT(DT),?71,"Page: "_IBPG
     74 W !,$TR($J("",IOM)," ","=")
     75 W !,$P(IBREC1,U)_" "_"("_IBILL_")",?27,$P($G(^DPT(+$P(IBREC1,U,2),0)),U),?52,$P($G(^DPT($P(IBREC1,U,2),0)),U,9),!
     76 S IBLINE=5
     77 Q
     78 ;
     79ASK ;
     80 I $E(IOST,1,2)'["C-" Q
     81 N DIR,DIROUT,DIRUT,DTOUT,DUOUT
     82 S DIR(0)="E" D ^DIR
     83 I ($D(DIRUT))!($D(DUOUT)) S IBQUIT=1
     84 Q
     85 ;
     86EXITQ ; - clean up and exit
     87 I $E(IOST,1,2)["C-" K DIR S DIR(0)="E" W ! D ^DIR K DIR
     88 K ^TMP("IBXERR",$J),^TMP("IBXDATA",$J),IBXERR
     89 D CLEAN^DILF
     90 Q
     91 ;
     92EXTRACT(IBIFN,IBBATCH,IBFORM,IBLOCAL) ; Extracts transmitted form data into global
     93 ; ^TMP("IBXDATA",$J).  Errors are in ^TMP("IBXERR",$J,err_num)=text.
     94 ; IBBATCH = Batch # of bill (if known), otherwise, set to 1.  This
     95 ;          variable must be > 0 to prevent a new batch from being added
     96 ; IBFORM = the ien of the form in file 353
     97 ; IBLOCAL = 1 if OK to use local form, 0 if not
     98 N IBVNUM,IBL
     99 D FORMPRE^IBCFP1
     100 S IBVNUM=$G(IBBATCH)
     101 S IBL=$S('$G(IBLOCAL):IBFORM,1:"") ; No local form ... set = main form
     102 ; Get local form associated with parent, if any
     103 I IBL="" S IBL=$S($P($G(^IBE(353,+IBFORM,2)),U,8):$P(^(2),U,8),1:IBFORM)
     104 D SETUP^IBCE837(1)
     105 D ROUT^IBCFP1(IBFORM,1,IBIFN,0,IBL)
     106 Q
     107 ;

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCF331.m

    r613 r623  
    1 IBCF331 ;ALB/ARH - UB92 HCFA-1450 (GATHER CODES CONT) ;25-AUG-1993
    2         ;;2.0;INTEGRATED BILLING;**52,210,309,389**; 21-MAR-94;Build 6
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5         ;
    6 DX      ;additional dx codes (ie more than 9 on bill)
    7         D SET^IBCSC4D(IBIFN,"",.IBARRAY) G:$P(IBARRAY,U,2)'>9 RX
    8         S IBX=+$P(IBARRAY,U,2)-9+2 D SPACE
    9         S IBZ="" D SET2
    10         S IBZ="ADDITIONAL DIAGNOSIS CODES:" D SET2
    11         S IBX=0 F IBI=1:1 S IBX=$O(IBARRAY(IBX)) Q:IBX=""  I IBI>9 D
    12         . S IBY=$$ICD9^IBACSV(+$G(IBARRAY(IBX)),$$BDATE^IBACSV(+IBIFN)) Q:IBY=""
    13         . S IBZ=$P(IBY,U)_$J(" ",(10-$L($P(IBY,U))))_$P(IBY,U,3) D SET2
    14         ;
    15 RX      ;add rx refills
    16         D SET^IBCSC5A(IBIFN,.IBARRAY) G:'$P(IBARRAY,U,2) PD
    17         S IBX=+$P(IBARRAY,U,2)+2 D SPACE
    18         S IBZ="" D SET2
    19         S IBZ="PRESCRIPTION REFILLS:" D SET2
    20         S IBX=0 F  S IBX=$O(IBARRAY(IBX)) Q:IBX=""  S IBY=0 F  S IBY=$O(IBARRAY(IBX,IBY)) Q:'IBY  S IBLN=IBARRAY(IBX,IBY) D
    21         . D ZERO^IBRXUTL(+$P(IBLN,U,2))
    22         . S IBZ=IBX_$J(" ",(11-$L(IBX)))_" "_$J($S($P(IBLN,U,6):"$"_$FN($P(IBLN,U,6),",",2),1:""),10)_"  "_$J($$FMTE^XLFDT(IBY,2),8)_"  "_$G(^TMP($J,"IBDRUG",+$P(IBLN,U,2),.01)) D SET2
    23         . S IBZ="",IBZ=$S(+$P(IBLN,U,4):"QTY: "_$P(IBLN,U,4)_" ",1:"")_$S(+$P(IBLN,U,3):"for "_$P(IBLN,U,3)_" days supply ",1:"") I IBZ'="" S IBZ=$J(" ",35)_IBZ D SET2
    24         . S IBZ="",IBZ=$S($P(IBLN,U,5)'="":"NDC #: "_$P(IBLN,U,5),1:"") I IBZ'="" S IBZ=$J(" ",35)_IBZ D SET2
    25         . K ^TMP($J,"IBDRUG")
    26         . Q
    27         ;
    28 PD      ;add prosthetic items
    29         D SET^IBCSC5B(IBIFN,.IBARRAY) G:'$P(IBARRAY,U,2) END
    30         S IBX=+$P(IBARRAY,U,2)+2 D SPACE
    31         S IBZ="" D SET2
    32         S IBZ="PROSTHETIC ITEMS:" D SET2
    33         S IBX=0 F  S IBX=$O(IBARRAY(IBX)) Q:IBX=""  S IBY=0 F  S IBY=$O(IBARRAY(IBX,IBY)) Q:'IBY  D
    34         . S IBZ=$$FMTE^XLFDT(IBX,2)_" "_$J($S($P(IBARRAY(IBX,IBY),U,2):"$"_$FN($P(IBARRAY(IBX,IBY),U,2),",",2),1:""),10)_"  "_$E($$PINB^IBCSC5B(+IBARRAY(IBX,IBY)),1,54) D SET2
    35         ;
    36 END     Q
    37         ;
    38 SET2    D SET2^IBCF33 Q
    39 SPACE   D SPACE^IBCF33 Q
     1IBCF331 ;ALB/ARH - UB92 HCFA-1450 (GATHER CODES CONT) ;25-AUG-1993
     2 ;;2.0;INTEGRATED BILLING;**52,210,309**; 21-MAR-94
     3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
     4 ;
     5 ;
     6DX ;additional dx codes (ie more than 9 on bill)
     7 D SET^IBCSC4D(IBIFN,"",.IBARRAY) G:$P(IBARRAY,U,2)'>9 RX
     8 S IBX=+$P(IBARRAY,U,2)-9+2 D SPACE
     9 S IBZ="" D SET2
     10 S IBZ="ADDITIONAL DIAGNOSIS CODES:" D SET2
     11 S IBX=0 F IBI=1:1 S IBX=$O(IBARRAY(IBX)) Q:IBX=""  I IBI>9 D
     12 . S IBY=$$ICD9^IBACSV(+$G(IBARRAY(IBX)),$$BDATE^IBACSV(+IBIFN)) Q:IBY=""
     13 . S IBZ=$P(IBY,U)_$J(" ",(10-$L($P(IBY,U))))_$P(IBY,U,3) D SET2
     14 ;
     15RX ;add rx refills
     16 D SET^IBCSC5A(IBIFN,.IBARRAY) G:'$P(IBARRAY,U,2) PD
     17 S IBX=+$P(IBARRAY,U,2)+2 D SPACE
     18 S IBZ="" D SET2
     19 S IBZ="PRESCRIPTION REFILLS:" D SET2
     20 S IBX=0 F  S IBX=$O(IBARRAY(IBX)) Q:IBX=""  S IBY=0 F  S IBY=$O(IBARRAY(IBX,IBY)) Q:'IBY  S IBLN=IBARRAY(IBX,IBY) D
     21 . D ZERO^IBRXUTL(+$P(IBLN,U,2))
     22 . S IBZ=IBX_$J(" ",(11-$L(IBX)))_" "_$J($S($P(IBLN,U,6):"$"_$FN($P(IBLN,U,6),",",2),1:""),10)_"  "_$J($$FMTE^XLFDT(IBY,2),8)_"  "_$G(^TMP($J,"IBDRUG",+$P(IBLN,U,2),.01)) D SET2
     23 . S IBZ="",IBZ=$S(+$P(IBLN,U,4):"QTY: "_$P(IBLN,U,4)_" ",1:"")_$S(+$P(IBLN,U,3):"for "_$P(IBLN,U,3)_" days supply ",1:"") I IBZ'="" S IBZ=$J(" ",35)_IBZ D SET2
     24 . S IBZ="",IBZ=$S($P(IBLN,U,5)'="":"NDC #: "_$P(IBLN,U,5),1:"") I IBZ'="" S IBZ=$J(" ",35)_IBZ D SET2
     25 . K ^TMP($J,"IBDRUG")
     26 . Q
     27 ;
     28PD ;add prosthetic items
     29 D SET^IBCSC5B(IBIFN,.IBARRAY) G:'$P(IBARRAY,U,2) END
     30 S IBX=+$P(IBARRAY,U,2)+2 D SPACE
     31 S IBZ="" D SET2
     32 S IBZ="PROSTHETIC ITEMS:" D SET2
     33 S IBX=0 F  S IBX=$O(IBARRAY(IBX)) Q:IBX=""  S IBY=0 F  S IBY=$O(IBARRAY(IBX,IBY)) Q:'IBY  D
     34 . S IBZ=$$FMTE^XLFDT(IBX,2)_" "_$J($S($P(IBARRAY(IBX,IBY),U,2):"$"_$FN($P(IBARRAY(IBX,IBY),U,2),",",2),1:""),10)_"  "_$E($P($$PIN^IBCSC5B(IBY),U,2),1,54) D SET2
     35 ;
     36END Q
     37 ;
     38SET2 D SET2^IBCF33 Q
     39SPACE D SPACE^IBCF33 Q

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCF4.m

    r613 r623  
    1 IBCF4   ;ALB/ARH - PRINT BILL ADDENDUM ;12-JAN-94
    2         ;;2.0;INTEGRATED BILLING;**52,137,199,309,389**;21-MAR-94;Build 6
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5 PRXA    ;get bill number then print rx refill addendums for bills
    6         S DIC("S")="I $D(^IBA(362.4,""AIFN""_+Y))!($D(^IBA(362.5,""AIFN""_+Y)))"
    7         N DPTNOFZY S DPTNOFZY=1  ;Suppress PATIENT file fuzzy lookups
    8         S DIC="^DGCR(399,",DIC(0)="AEMQ" D ^DIC K DIC G:+Y'>0 EXIT S IBBILL=$P(Y,U,2),IBIFN=+Y
    9         ;
    10         I $D(^IBA(364,"ABDT",IBIFN)),+$$TXMT^IBCEF4(IBIFN)=1 D  G:'IBTXOK PRXA
    11         .S IBTXOK=0
    12         .N IBLDT,IBX
    13         .S IBLDT=$O(^IBA(364,"ABDT",IBIFN,""),-1),IBX=$O(^IBA(364,"B",IBIFN,+IBLDT,""),-1)
    14         .I "X"[$P($G(^IBA(364,+IBX,0)),U,3) W !!,*7,"Transmittable Bill can NOT be printed until transmitted" Q
    15         .W !!,"This is a Transmittable Bill that has already been transmitted"
    16         .W !!,"WANT TO PRINT THIS BILL ADDENDUM ANYWAY" S %=2 D YN^DICN
    17         .Q:'(%+1#3)  ;-1 or 2
    18         .S IBTXOK=1
    19         ;
    20 DEV     ;get the device
    21         W !!,"Report requires 132 columns."
    22         S %ZIS="QM",%ZIS("A")="OUTPUT DEVICE: " D ^%ZIS G:POP EXIT
    23         I $D(IO("Q")) S ZTRTN="EN^IBCF4",ZTDESC="BILL ADDENDUM FOR "_IBBILL,ZTSAVE("IB*")="" D ^%ZTLOAD K IO("Q"),ZTSK G EXIT
    24         U IO D EN
    25         ;
    26 EXIT    ;clean up and quit
    27         I $D(ZTQUEUED) S ZTREQ="@" Q
    28         K IBQUIT,IBIFN,IBBILL,IBTXOK,X,Y,DTOUT,DUOUT,DIRUT,DIROUT D ^%ZISC
    29         Q
    30         ;
    31 EN      ;ENTRY POINT IF QUEUED, print all rx refills for a bill
    32         S IBY=$G(^DGCR(399,+IBIFN,0)) Q:IBY=""  S IBXREF="AIFN"_IBIFN
    33         S (IBQUIT,IBPGN,IBRX)=0,IBHDR="BILL ADDENDUM FOR "_$P($G(^DPT(+$P(IBY,U,2),0)),U,1)_" - "_$P(IBY,U,1) D HDR
    34 RX      I '$D(^IBA(362.4,IBXREF)) G PROS
    35         W !!,"PRESCRIPTION REFILLS:",!
    36         K IBRC
    37         D RCITEM^IBCSC5A(IBIFN,"IBRC",3)
    38         S IBRX=0 F  S IBRX=$O(^IBA(362.4,IBXREF,IBRX)) Q:IBRX=""!IBQUIT  S IBRIFN=0 F  S IBRIFN=$O(^IBA(362.4,IBXREF,IBRX,IBRIFN)) Q:'IBRIFN!IBQUIT  D
    39         .S IBY=$G(^IBA(362.4,IBRIFN,0)) Q:IBY=""
    40         .S IBYC=$$CHG(IBRIFN,3,.IBRC)
    41         .;
    42         . D ZERO^IBRXUTL(+$P(IBY,U,4))
    43         . W !,$P(IBY,U,1),?13,$$FMTE^XLFDT(+$P(IBY,U,3),2),?22,$J($S(IBYC:"$"_$FN(IBYC,",",2),1:""),10),?34,$G(^TMP($J,"IBDRUG",+$P(IBY,U,4),.01))
    44         . K ^TMP($J,"IBDRUG")
    45         . I $P(IBY,U,6)'="" W ?77,"QTY: ",$P(IBY,U,7)
    46         . I $P(IBY,U,7)'="" W ?87,"DAYS SUPPLY: ",$P(IBY,U,6)
    47         . I $P(IBY,U,8)'="" W ?105,"NDC #: ",$P(IBY,U,8)
    48         . S IBLN=IBLN+1 I IBLN>(IOSL-7) D PAUSE,HDR
    49         K IBRC
    50         ;
    51 PROS    I '$D(^IBA(362.5,IBXREF)) G END
    52         W !!!,"PROSTHETIC ITEMS:",!
    53         K IBRC
    54         D RCITEM^IBCSC5A(IBIFN,"IBRC",5)
    55         S IBPI=0 F  S IBPI=$O(^IBA(362.5,IBXREF,IBPI)) Q:IBPI=""!IBQUIT  S IBPIFN=0 F  S IBPIFN=$O(^IBA(362.5,IBXREF,IBPI,IBPIFN)) Q:'IBPIFN!IBQUIT  D
    56         . S IBY=$G(^IBA(362.5,IBPIFN,0)),IBYC="" Q:IBY=""
    57         . S IBYC=$$CHG(IBPIFN,5,.IBRC)
    58         . W !,$$FMTE^XLFDT(+$P(IBY,U,1),2),?11,$J($S(IBYC:"$"_$FN(IBYC,",",2),1:""),10),?24,$E($P(IBY,U,5),1,55)
    59         . S IBLN=IBLN+1 I IBLN>(IOSL-7) D PAUSE,HDR
    60         D:'IBQUIT PAUSE
    61 END     K IBX,IBY,IBPGN,IBRX,IBHDR,IBRIFN,IBLN,IBCDT,IBI,IBXREF,IBPI,IBPIFN,IBRC,IBYC
    62         Q
    63         ;
    64 CHG(IBY,IBTYP,IBRC)     ; Return charge for item entry IBY or null if no charge
    65         ; IBRC = the array containing the revenue code items and their units and charges
    66         ; IBTYP = the type of item being priced
    67         N IBZ,IBYC
    68         S IBRC=$S($D(IBRC(IBTYP,IBY)):IBY,1:0),IBYC=""
    69         F IBRC=IBRC,0 Q:'$D(IBRC(IBTYP,IBRC))  S IBZ="" D  Q:IBZ'=""!(IBRC=0)
    70         .F  S IBZ=$O(IBRC(IBTYP,IBRC,IBZ)) Q:IBZ=""  I IBRC(IBTYP,IBRC,IBZ) S $P(IBRC(IBTYP,IBRC,IBZ),U)=IBRC(IBTYP,IBRC,IBZ)-1,IBYC=$P(IBRC(IBTYP,IBRC,IBZ),U,2) K:'IBRC(IBTYP,IBRC,IBZ) IBRC(IBTYP,IBRC,IBZ) Q
    71         Q IBYC
    72         ;
    73 HDR     ;print the report header
    74         S IBQUIT=$$STOP Q:IBQUIT  S IBPGN=IBPGN+1,IBLN=5
    75         D NOW^%DTC S Y=$E(%,1,12) D DD^%DT S IBCDT=$P(Y,"@",1)_"  "_$P(Y,"@",2)
    76         I IBPGN>1!($E(IOST,1,2)["C-") W @IOF
    77         W IBHDR W:IOM<85 ! W ?(IOM-30),IBCDT,?(IOM-8),"PAGE ",IBPGN,!
    78         ;W !,"RX #",?13,"REFILL DATE",?28,"DRUG",?70,"DAYS SUPPLY",?83,"QTY",?90,"NDC #",!
    79         F IBI=1:1:IOM W "-"
    80         W !
    81         Q
    82         ;
    83 PAUSE   ;pause at end of screen if being displayed on a terminal
    84         Q:$E(IOST,1,2)'["C-"
    85         S DIR(0)="E" D ^DIR K DIR
    86         I $D(DUOUT)!($D(DIRUT)) S IBQUIT=1
    87         Q
    88         ;
    89 STOP()  ;determine if user has requested the queued report to stop
    90         I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1 K ZTREQ I +$G(IBPGN) W !,"***TASK STOPPED BY USER***"
    91         Q +$G(ZTSTOP)
    92         ;
    93 RXDISP  ;displays all rx refills bills
    94         ;N IBX,IBY,IBZ,IBC,X,Y S Y=1,IBC=0,IBX="AIFN"
    95         ;F  S IBX=$O(^IBA(362.4,IBX)) Q:IBX=""  S IBY=$E(IBX,5,999),IBZ=$G(^DGCR(399,+IBY,0)) I IBZ'="" D  Q:'Y
    96         ;. W !,$P(IBZ,U,1),?10,$E($P($G(^DPT(+$P(IBZ,U,2),0)),U,1),1,20),?32,$$DATE(+$P(IBZ,U,3)),?42,$S(+$P(IBZ,U,5)<3:"INPT",1:"OUTPT")
    97         ;. W ?49,$P($G(^DGCR(399.3,+$P(IBZ,U,7),0)),U,4),?59,$E($$EXSET^IBEFUNC(+$P(IBZ,U,13),399,.13),1,7),?68,$E($P($G(^IBE(353,+$P(IBZ,U,19),0)),U,1),1,11)
    98         ;. S IBC=IBC+1 I '(IBC#10) S DIR(0)="E" D ^DIR K DIR
    99         ;Q
    100         ;
    101 DATE(X) Q $E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3)
    102         ;
    103 BILLAD(IFN)     ;returns true if bill has either rx refills or prosthetics so addendum should print
    104         N IBX S IBX=0,IFN=+$G(IFN) S:+$O(^IBA(362.4,"AIFN"_IFN,0)) IBX=1 S:+$O(^IBA(362.5,"AIFN"_IFN,0)) IBX=IBX+2
    105         Q IBX
     1IBCF4 ;ALB/ARH - PRINT BILL ADDENDUM ;12-JAN-94
     2 ;;2.0;INTEGRATED BILLING;**52,137,199,309**;21-MAR-94
     3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
     4 ;
     5PRXA ;get bill number then print rx refill addendums for bills
     6 S DIC("S")="I $D(^IBA(362.4,""AIFN""_+Y))!($D(^IBA(362.5,""AIFN""_+Y)))"
     7 N DPTNOFZY S DPTNOFZY=1  ;Suppress PATIENT file fuzzy lookups
     8 S DIC="^DGCR(399,",DIC(0)="AEMQ" D ^DIC K DIC G:+Y'>0 EXIT S IBBILL=$P(Y,U,2),IBIFN=+Y
     9 ;
     10 I $D(^IBA(364,"ABDT",IBIFN)),+$$TXMT^IBCEF4(IBIFN)=1 D  G:'IBTXOK PRXA
     11 .S IBTXOK=0
     12 .N IBLDT,IBX
     13 .S IBLDT=$O(^IBA(364,"ABDT",IBIFN,""),-1),IBX=$O(^IBA(364,"B",IBIFN,+IBLDT,""),-1)
     14 .I "X"[$P($G(^IBA(364,+IBX,0)),U,3) W !!,*7,"Transmittable Bill can NOT be printed until transmitted" Q
     15 .W !!,"This is a Transmittable Bill that has already been transmitted"
     16 .W !!,"WANT TO PRINT THIS BILL ADDENDUM ANYWAY" S %=2 D YN^DICN
     17 .Q:'(%+1#3)  ;-1 or 2
     18 .S IBTXOK=1
     19 ;
     20DEV ;get the device
     21 W !!,"Report requires 132 columns."
     22 S %ZIS="QM",%ZIS("A")="OUTPUT DEVICE: " D ^%ZIS G:POP EXIT
     23 I $D(IO("Q")) S ZTRTN="EN^IBCF4",ZTDESC="BILL ADDENDUM FOR "_IBBILL,ZTSAVE("IB*")="" D ^%ZTLOAD K IO("Q"),ZTSK G EXIT
     24 U IO D EN
     25 ;
     26EXIT ;clean up and quit
     27 I $D(ZTQUEUED) S ZTREQ="@" Q
     28 K IBQUIT,IBIFN,IBBILL,IBTXOK,X,Y,DTOUT,DUOUT,DIRUT,DIROUT D ^%ZISC
     29 Q
     30 ;
     31EN ;ENTRY POINT IF QUEUED, print all rx refills for a bill
     32 S IBY=$G(^DGCR(399,+IBIFN,0)) Q:IBY=""  S IBXREF="AIFN"_IBIFN
     33 S (IBQUIT,IBPGN,IBRX)=0,IBHDR="BILL ADDENDUM FOR "_$P($G(^DPT(+$P(IBY,U,2),0)),U,1)_" - "_$P(IBY,U,1) D HDR
     34RX I '$D(^IBA(362.4,IBXREF)) G PROS
     35 W !!,"PRESCRIPTION REFILLS:",!
     36 K IBRC
     37 D RCITEM^IBCSC5A(IBIFN,"IBRC",3)
     38 S IBRX=0 F  S IBRX=$O(^IBA(362.4,IBXREF,IBRX)) Q:IBRX=""!IBQUIT  S IBRIFN=0 F  S IBRIFN=$O(^IBA(362.4,IBXREF,IBRX,IBRIFN)) Q:'IBRIFN!IBQUIT  D
     39 .S IBY=$G(^IBA(362.4,IBRIFN,0)) Q:IBY=""
     40 .S IBYC=$$CHG(IBRIFN,3,.IBRC)
     41 .;
     42 . D ZERO^IBRXUTL(+$P(IBY,U,4))
     43 . W !,$P(IBY,U,1),?13,$$FMTE^XLFDT(+$P(IBY,U,3),2),?22,$J($S(IBYC:"$"_$FN(IBYC,",",2),1:""),10),?34,$G(^TMP($J,"IBDRUG",+$P(IBY,U,4),.01))
     44 . K ^TMP($J,"IBDRUG")
     45 . I $P(IBY,U,6)'="" W ?77,"QTY: ",$P(IBY,U,7)
     46 . I $P(IBY,U,7)'="" W ?87,"DAYS SUPPLY: ",$P(IBY,U,6)
     47 . I $P(IBY,U,8)'="" W ?105,"NDC #: ",$P(IBY,U,8)
     48 . S IBLN=IBLN+1 I IBLN>(IOSL-7) D PAUSE,HDR
     49 K IBRC
     50 ;
     51PROS I '$D(^IBA(362.5,IBXREF)) G END
     52 W !!!,"PROSTHETIC ITEMS:",!
     53 K IBRC
     54 D RCITEM^IBCSC5A(IBIFN,"IBRC",5)
     55 S IBPI=0 F  S IBPI=$O(^IBA(362.5,IBXREF,IBPI)) Q:IBPI=""!IBQUIT  S IBPIFN=0 F  S IBPIFN=$O(^IBA(362.5,IBXREF,IBPI,IBPIFN)) Q:'IBPIFN!IBQUIT  D
     56 . S IBY=$G(^IBA(362.5,IBPIFN,0)),IBYC="" Q:IBY=""
     57 . S IBYC=$$CHG(IBPIFN,5,.IBRC)
     58 . W !,$$FMTE^XLFDT(+$P(IBY,U,1),2),?11,$J($S(IBYC:"$"_$FN(IBYC,",",2),1:""),10),?24,$P($$PIN^IBCSC5B(+$P(IBY,U,3)),U,2)
     59 . S IBLN=IBLN+1 I IBLN>(IOSL-7) D PAUSE,HDR
     60 D:'IBQUIT PAUSE
     61END K IBX,IBY,IBPGN,IBRX,IBHDR,IBRIFN,IBLN,IBCDT,IBI,IBXREF,IBPI,IBPIFN,IBRC,IBYC
     62 Q
     63 ;
     64CHG(IBY,IBTYP,IBRC) ; Return charge for item entry IBY or null if no charge
     65 ; IBRC = the array containing the revenue code items and their units and charges
     66 ; IBTYP = the type of item being priced
     67 N IBZ,IBYC
     68 S IBRC=$S($D(IBRC(IBTYP,IBY)):IBY,1:0),IBYC=""
     69 F IBRC=IBRC,0 Q:'$D(IBRC(IBTYP,IBRC))  S IBZ="" D  Q:IBZ'=""!(IBRC=0)
     70 .F  S IBZ=$O(IBRC(IBTYP,IBRC,IBZ)) Q:IBZ=""  I IBRC(IBTYP,IBRC,IBZ) S $P(IBRC(IBTYP,IBRC,IBZ),U)=IBRC(IBTYP,IBRC,IBZ)-1,IBYC=$P(IBRC(IBTYP,IBRC,IBZ),U,2) K:'IBRC(IBTYP,IBRC,IBZ) IBRC(IBTYP,IBRC,IBZ) Q
     71 Q IBYC
     72 ;
     73HDR ;print the report header
     74 S IBQUIT=$$STOP Q:IBQUIT  S IBPGN=IBPGN+1,IBLN=5
     75 D NOW^%DTC S Y=$E(%,1,12) D DD^%DT S IBCDT=$P(Y,"@",1)_"  "_$P(Y,"@",2)
     76 I IBPGN>1!($E(IOST,1,2)["C-") W @IOF
     77 W IBHDR W:IOM<85 ! W ?(IOM-30),IBCDT,?(IOM-8),"PAGE ",IBPGN,!
     78 ;W !,"RX #",?13,"REFILL DATE",?28,"DRUG",?70,"DAYS SUPPLY",?83,"QTY",?90,"NDC #",!
     79 F IBI=1:1:IOM W "-"
     80 W !
     81 Q
     82 ;
     83PAUSE ;pause at end of screen if being displayed on a terminal
     84 Q:$E(IOST,1,2)'["C-"
     85 S DIR(0)="E" D ^DIR K DIR
     86 I $D(DUOUT)!($D(DIRUT)) S IBQUIT=1
     87 Q
     88 ;
     89STOP() ;determine if user has requested the queued report to stop
     90 I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1 K ZTREQ I +$G(IBPGN) W !,"***TASK STOPPED BY USER***"
     91 Q +$G(ZTSTOP)
     92 ;
     93RXDISP ;displays all rx refills bills
     94 ;N IBX,IBY,IBZ,IBC,X,Y S Y=1,IBC=0,IBX="AIFN"
     95 ;F  S IBX=$O(^IBA(362.4,IBX)) Q:IBX=""  S IBY=$E(IBX,5,999),IBZ=$G(^DGCR(399,+IBY,0)) I IBZ'="" D  Q:'Y
     96 ;. W !,$P(IBZ,U,1),?10,$E($P($G(^DPT(+$P(IBZ,U,2),0)),U,1),1,20),?32,$$DATE(+$P(IBZ,U,3)),?42,$S(+$P(IBZ,U,5)<3:"INPT",1:"OUTPT")
     97 ;. W ?49,$P($G(^DGCR(399.3,+$P(IBZ,U,7),0)),U,4),?59,$E($$EXSET^IBEFUNC(+$P(IBZ,U,13),399,.13),1,7),?68,$E($P($G(^IBE(353,+$P(IBZ,U,19),0)),U,1),1,11)
     98 ;. S IBC=IBC+1 I '(IBC#10) S DIR(0)="E" D ^DIR K DIR
     99 ;Q
     100 ;
     101DATE(X) Q $E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3)
     102 ;
     103BILLAD(IFN) ;returns true if bill has either rx refills or prosthetics so addendum should print
     104 N IBX S IBX=0,IFN=+$G(IFN) S:+$O(^IBA(362.4,"AIFN"_IFN,0)) IBX=1 S:+$O(^IBA(362.5,"AIFN"_IFN,0)) IBX=IBX+2
     105 Q IBX

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNADD.m

    r613 r623  
    1 IBCNADD ;ALB/AAS - ADDRESS RETRIEVAL ENGINE FOR FILE 399 ; 29-AUG-93
    2         ;;2.0;INTEGRATED BILLING;**52,80,377**;21-MAR-94;Build 23
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5 ADD(DA,IBCOB)   ; -- Retrieve correct billing address for a bill, mailing address of Bill Payer
    6         ;    assumes that new policy field points to valid ins. policy
    7         ;    DA = ien to file 399
    8         ;    IBCOB = payer sequence PST or 123 (optional)
    9         ;
    10         N X,Y,I,J,IB01,IB02,IBTYP,DFN,IBCNS,IBCDFN,IBCNT,IBAGAIN,IBFND,IBBILLTY,IBCHRGTY
    11         S IB02=""
    12         S DFN=$P($G(^DGCR(399,DA,0)),"^",2)
    13         S IBBILLTY=$P($G(^DGCR(399,DA,0)),"^",5),IBCHRGTY=$P($$CHGTYPE^IBCU(DA),"^;",1)
    14         ;
    15         S IBCNS=+$P($G(^DGCR(399,DA,"MP")),U,1)
    16         S IBCDFN=$P($G(^DGCR(399,DA,"MP")),U,2)
    17         ;
    18         ; If a specific payer sequence was passed in, get the ins. company and the policy ptr
    19         ; No address returned for Medicare
    20         I $G(IBCOB)'="" D  I $$MCRWNR^IBEFUNC(IBCNS) G MAINQ
    21         . S IBCOB=$TR(IBCOB,"PST","123")
    22         . S IBCNS=+$P($G(^DGCR(399,DA,"I"_IBCOB)),U,1)
    23         . S IBCDFN=+$P($G(^DGCR(399,DA,"M")),U,IBCOB+11)
    24         . Q
    25         ;
    26         I 'IBCNS G MAINQ
    27         I IBCDFN S IBCNS=+$G(^DPT(+DFN,.312,+IBCDFN,0))
    28         I '$D(^DIC(36,+IBCNS,0)) G MAINQ
    29         ;
    30         ; -- if send bill to employer and state is filled in use this
    31         I +$G(^DPT(DFN,.312,+IBCDFN,2)),+$P(^(2),"^",6) S IB02=$P(^(2),"^",2,99) G MAINQ
    32         ;
    33 MAIN    ; -- determine address for company for type bill
    34         ;
    35         ; -- get main address
    36         S IB02=$S($D(^DIC(36,+IBCNS,.11)):^(.11),1:"")
    37         S IBCNT=$G(IBCNT)+1
    38         ;
    39         ; -- if process the same co. more than once you are in an infinite loop
    40         I $D(IBCNT(IBCNS)) G MAINQ ;already processed this company  use main add
    41         S IBCNT(IBCNS)=""
    42         ;
    43         ; -- type of charges:   Rx charges - if ins company has an rx address use it, otherwise use opt address
    44         I IBCHRGTY=3 S IBTYP="R" D @IBTYP G:$D(IBFND) MAINQ I $D(IBAGAIN) K IBAGAIN G MAIN
    45         ;
    46         ; -- type of bill:   inpatient<3, outpatient>2
    47         S IBTYP=$S(IBBILLTY<3:"I",1:"O")
    48         D @IBTYP I $D(IBAGAIN) K IBAGAIN G MAIN
    49         ;
    50         ; -- return address
    51 MAINQ   Q IB02
    52         ;
    53 I       ; -- see if there is an inpatient address
    54         ; -- use if state is there
    55         I $P($G(^DIC(36,+IBCNS,.12)),"^",5) S IB02=$P($G(^(.12)),"^",1,6)
    56         ;
    57         ; -- if other company processes claims start again
    58         I $P($G(^DIC(36,+IBCNS,.12)),"^",7) S IBCNS=$P($G(^DIC(36,+IBCNS,.12)),"^",7) S IBAGAIN=1
    59         Q
    60         ;
    61 O       ; -- see if there is an outpatient address
    62         ; -- use if state is there
    63         I $P($G(^DIC(36,+IBCNS,.16)),"^",5) S IB02=$P($G(^(.16)),"^",1,6)
    64         ;
    65         ; -- if other company processes claims start again
    66         I $P($G(^DIC(36,+IBCNS,.16)),"^",7) S IBCNS=$P($G(^DIC(36,+IBCNS,.16)),"^",7) S IBAGAIN=1
    67         Q
    68         ;
    69 R       ; -- see if there is an Rx address
    70         ; -- use if state is there
    71         I $P($G(^DIC(36,+IBCNS,.18)),"^",5) S IB02=$P($G(^(.18)),"^",1,6) S IBFND=1
    72         ;
    73         ; -- if other company processes claims start again
    74         I $P($G(^DIC(36,+IBCNS,.18)),"^",7) S IBCNS=$P($G(^DIC(36,+IBCNS,.18)),"^",7) S IBAGAIN=1 K IBFND
    75         Q
     1IBCNADD ;ALB/AAS - ADDRESS RETRIEVAL ENGINE FOR FILE 399 ; 29-AUG-93
     2 ;;2.0;INTEGRATED BILLING;**52,80**;21-MAR-94
     3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
     4 ;
     5ADD(DA) ; -- Retrive correct billing address for a bill, mailing address of Bill Payer
     6 ;    assumes that new policy field points to valid ins. policy
     7 N X,Y,I,J,IB01,IB02,IBTYP,DFN,IBCNS,IBCDFN,IBCNT,IBAGAIN,IBFND,IBBILLTY,IBCHRGTY
     8 S IB02=""
     9 S DFN=$P($G(^DGCR(399,DA,0)),"^",2)
     10 S IBCNS=+$P($G(^DGCR(399,DA,"MP")),U,1) G:'IBCNS MAINQ
     11 S IBCDFN=$P($G(^DGCR(399,DA,"MP")),"^",2) I IBCDFN S IBCNS=+$G(^DPT(+DFN,.312,+IBCDFN,0))
     12 S IBBILLTY=$P($G(^DGCR(399,DA,0)),"^",5),IBCHRGTY=$P($$CHGTYPE^IBCU(DA),"^;",1)
     13 I '$D(^DIC(36,+IBCNS,0)) G MAINQ
     14 ;
     15 ; -- if send bill to employer and state is filled in use this
     16 I +$G(^DPT(DFN,.312,+IBCDFN,2)),+$P(^(2),"^",6) S IB02=$P(^(2),"^",2,99) G MAINQ
     17 ;
     18MAIN ; -- determine address for company for type bill
     19 ;
     20 ; -- get main address
     21 S IB02=$S($D(^DIC(36,+IBCNS,.11)):^(.11),1:"")
     22 S IBCNT=$G(IBCNT)+1
     23 ;
     24 ; -- if process the same co. more than once you are in an infinite loop
     25 I $D(IBCNT(IBCNS)) G MAINQ ;already processed this company  use main add
     26 S IBCNT(IBCNS)=""
     27 ;
     28 ; -- type of charges:   Rx charges - if ins company has an rx address use it, otherwise use opt address
     29 I IBCHRGTY=3 S IBTYP="R" D @IBTYP G:$D(IBFND) MAINQ I $D(IBAGAIN) K IBAGAIN G MAIN
     30 ;
     31 ; -- type of bill:   inpatient<3, outpatient>2
     32 S IBTYP=$S(IBBILLTY<3:"I",1:"O")
     33 D @IBTYP I $D(IBAGAIN) K IBAGAIN G MAIN
     34 ;
     35 ; -- return address
     36MAINQ Q IB02
     37 ;
     38I ; -- see if there is an inpatient address
     39 ; -- use if state is there
     40 I $P($G(^DIC(36,+IBCNS,.12)),"^",5) S IB02=$P($G(^(.12)),"^",1,6)
     41 ;
     42 ; -- if other company processes claims start again
     43 I $P($G(^DIC(36,+IBCNS,.12)),"^",7) S IBCNS=$P($G(^DIC(36,+IBCNS,.12)),"^",7) S IBAGAIN=1
     44 Q
     45 ;
     46O ; -- see if there is an outpatient address
     47 ; -- use if state is there
     48 I $P($G(^DIC(36,+IBCNS,.16)),"^",5) S IB02=$P($G(^(.16)),"^",1,6)
     49 ;
     50 ; -- if other company processes claims start again
     51 I $P($G(^DIC(36,+IBCNS,.16)),"^",7) S IBCNS=$P($G(^DIC(36,+IBCNS,.16)),"^",7) S IBAGAIN=1
     52 Q
     53 ;
     54R ; -- see if there is an Rx address
     55 ; -- use if state is there
     56 I $P($G(^DIC(36,+IBCNS,.18)),"^",5) S IB02=$P($G(^(.18)),"^",1,6) S IBFND=1
     57 ;
     58 ; -- if other company processes claims start again
     59 I $P($G(^DIC(36,+IBCNS,.18)),"^",7) S IBCNS=$P($G(^DIC(36,+IBCNS,.18)),"^",7) S IBAGAIN=1 K IBFND
     60 Q

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNBCD.m

    r613 r623  
    1 IBCNBCD ;ALB/ARH-Ins Buffer: display/compare buffer and existing ins ;1 Jun 97
    2         ;;2.0;INTEGRATED BILLING;**82,251,361,371**;21-MAR-94;Build 57
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5 INS(IBBUFDA,IBINSDA)    ; display a buffer entry's insurance company fields and
    6         ; an existing insurance company's fields for comparison
    7         N IBEXTDA,IBFLD1,IBFLD2,X I '$G(IBBUFDA) Q
    8         ;
    9         S IBEXTDA=$G(IBINSDA)_","
    10         ;
    11         I +$P($G(^DIC(36,+IBEXTDA,0)),U,5) W !,?10,"Selected Insurance Company "_$$GET1^DIQ(36,IBEXTDA,.01)_" is Inactive!",!
    12         ;
    13         W ! D WRTFLD("  Insurance Data:  Buffer Data                     Selected Insurance Company   ",0,80,"BU")
    14         S IBFLD1=$$GET1^DIQ(355.33,IBBUFDA,20.01),IBFLD2=$S(+IBEXTDA:$$GET1^DIQ(36,IBEXTDA,.01),1:"<none selected>") D WRTLN("Company Name:",IBFLD1,IBFLD2,"","","")
    15         S IBFLD1=$$GET1^DIQ(355.33,IBBUFDA,20.05),IBFLD2=$S(+IBEXTDA:$$GET1^DIQ(36,IBEXTDA,1),1:"") D WRTLN("Reimburse?:",IBFLD1,IBFLD2,"","","U")
    16         ;
    17         D DISPLAY(20.02,36,.131,"Phone Number:")
    18         D DISPLAY(20.03,36,.132,"Billing Phone:")
    19         D DISPLAY(20.04,36,.133,"Pre-Cert Phone:")
    20         D DISPLAY(21.01,36,.111,"Street [Line 1]:")
    21         D DISPLAY(21.02,36,.112,"Street [Line 2]:")
    22         D DISPLAY(21.03,36,.113,"Street [Line 3]:")
    23         D DISPLAY(21.04,36,.114,"City:")
    24         D DISPLAY(21.05,36,.115,"State:")
    25         D DISPLAY(21.06,36,.116,"Zip Code:")
    26         ;
    27         S IBFLD1="(bold=accepted on Merge)",IBFLD2="(bold=replaced on Overwrite)" D WRTLN("",IBFLD1,IBFLD2,"","","U")
    28         Q
    29         ;
    30 GRP(IBBUFDA,IBGRPDA)    ; display a buffer entry's group insurance fields and an existing group/plan's fields for comparison
    31         N IBEXTDA,IBFLD1,IBFLD2,X I '$G(IBBUFDA) Q
    32         ;
    33         S IBEXTDA=$G(IBGRPDA)_","
    34         ;
    35         I +$P($G(^IBA(355.3,+IBEXTDA,0)),U,11) W !,?23,"Selected Group/Plan is Inactive!",!
    36         ;
    37         W ! D WRTFLD(" Group/Plan Data:  Buffer Data                     Selected Group/Plan          ",0,80,"BU")
    38         S IBFLD1=$$GET1^DIQ(355.33,IBBUFDA,20.01),IBFLD2=$S(+IBEXTDA:$$GET1^DIQ(355.3,IBEXTDA,.01),1:"<none selected>") D WRTLN("Company Name:",IBFLD1,IBFLD2,"","","")
    39         S IBFLD1=$$GET1^DIQ(355.33,IBBUFDA,40.01),IBFLD2=$S(+IBEXTDA:$$GET1^DIQ(355.3,IBEXTDA,.02),1:"") D WRTLN("Is Group Plan?:",IBFLD1,IBFLD2,"","","U")
    40         ;
    41         D DISPLAY(40.02,355.3,.03,"Group Name:")
    42         D DISPLAY(40.03,355.3,.04,"Group Number:")
    43         D DISPLAY(40.1,355.3,6.02,"BIN:") ;;Daou/EEN - adding BIN and PCN
    44         D DISPLAY(40.11,355.3,6.03,"PCN:")
    45         D DISPLAY(40.04,355.3,.05,"Require UR:")
    46         D DISPLAY(40.05,355.3,.06,"Require Pre-Cert:")
    47         D DISPLAY(40.06,355.3,.12,"Require Amb Cert:")
    48         D DISPLAY(40.07,355.3,.07,"Exclude Pre-Cond:")
    49         D DISPLAY(40.08,355.3,.08,"Benefits Assign:")
    50         D DISPLAY(40.09,355.3,.09,"Type of Plan:")
    51         ;
    52         S IBFLD1="(bold=accepted on merge)",IBFLD2="(bold=replaced on overwrite)" D WRTLN("",IBFLD1,IBFLD2,"","","U")
    53         Q
    54         ;
    55 POLICY(IBBUFDA,IBPOLDA) ; display a buffer entry's patient policy fields and an existing patient policy's fields for comparison
    56         N DFN,IBEXTDA,IBFLD1,IBFLD2,X,Y,DIR,DIRUT I '$G(IBBUFDA) Q
    57         S DFN=+$G(^IBA(355.33,IBBUFDA,60))
    58         ;
    59         S IBEXTDA=$G(IBPOLDA)_","_DFN_","
    60         ;
    61         W ! D WRTFLD("     Policy Data:  Buffer Data                     Selected Policy              ",0,80,"BU")
    62         S IBFLD1=$$GET1^DIQ(355.33,IBBUFDA,20.01),IBFLD2=$S(+IBEXTDA:$$GET1^DIQ(2.312,IBEXTDA,.01),1:"<none selected>") D WRTLN("Company Name:",IBFLD1,IBFLD2,"","","")
    63         S IBFLD1=$$GET1^DIQ(355.33,IBBUFDA,40.03),IBFLD2=$S(+IBEXTDA:$$GET1^DIQ(2.312,IBEXTDA,21),1:"") D WRTLN("Group #:",IBFLD1,IBFLD2,"","","")
    64         S IBFLD1=$$GET1^DIQ(355.33,IBBUFDA,60.01),IBFLD2=$S(+IBEXTDA:$$GET1^DIQ(2,DFN,.01),1:"") D WRTLN("Patient Name:",IBFLD1,IBFLD2,"","","")
    65         S IBFLD1=$P($$GET1^DIQ(355.33,IBBUFDA,.1),"@"),IBFLD2=$S(+IBEXTDA:$P($$GET1^DIQ(2.312,IBEXTDA,1.03),"@"),1:"") D WRTLN("Last Verified:",IBFLD1,IBFLD2,"","","U")
    66         ;
    67         D DISPLAY(60.02,2.312,8,"Effective Date:")
    68         D DISPLAY(60.03,2.312,3,"Expiration Date:")
    69         D DISPLAY(60.04,2.312,1,"Subscriber Id:")
    70         D DISPLAY(60.05,2.312,6,"Whose Insurance:")
    71         D DISPLAY(60.06,2.312,16,"Relationship:")
    72         D DISPLAY(60.07,2.312,17,"Name of Insured:")
    73         D DISPLAY(60.08,2.312,3.01,"Insured's DOB:")
    74         D DISPLAY(60.09,2.312,3.05,"Insured's SSN:")
    75         D DISPLAY(60.13,2.312,3.12,"Insured's SEX:")
    76         D DISPLAY(60.1,2.312,4.01,"Primary Provider:")
    77         D DISPLAY(60.11,2.312,4.02,"Provider Phone:")
    78         D DISPLAY(60.12,2.312,.2,"Coor of Benefits:")
    79         D DISPLAY(61.01,2.312,2.1,"Emp Sponsored?:")
    80         D DISPLAY(62.01,2.312,5.01,"Patient Id:")
    81         ;
    82         I +$G(^IBA(355.33,IBBUFDA,61))!($$GET1^DIQ(2.312,IBEXTDA,2.1)="YES") D ESGHP
    83         ;
    84         S IBFLD1="(bold=accepted on merge)",IBFLD2="(bold=replaced on overwrite)" D WRTLN("",IBFLD1,IBFLD2,"","","U")
    85         ;
    86         Q
    87         ;
    88 ESGHP   ; display employee sponsored group health plan
    89         W ! S DIR(0)="E",DIR("A")="Enter RETURN to continue" D ^DIR W ! Q:$D(DIRUT)
    90         ;
    91         D DISPLAY(61.02,2.312,2.015,"Employer Name:")
    92         D DISPLAY(61.03,2.312,2.11,"Emp Status:")
    93         D DISPLAY(61.04,2.312,2.12,"Retirement Date:")
    94         D DISPLAY(61.05,2.312,2.01,"Send to Employer:")
    95         D DISPLAY(61.06,2.312,2.02,"Emp Street Ln 1:")
    96         D DISPLAY(61.07,2.312,2.03,"Emp Street Ln 2:")
    97         D DISPLAY(61.08,2.312,2.04,"Emp Street Ln 3:")
    98         D DISPLAY(61.09,2.312,2.05,"Emp City:")
    99         D DISPLAY(61.1,2.312,2.06,"Emp State:")
    100         D DISPLAY(61.11,2.312,2.07,"Emp Zip Code:")
    101         D DISPLAY(61.12,2.312,2.08,"Emp Phone:")
    102         ;
    103         Q
    104         ;
    105 DISPLAY(BFLD,IFILE,IFLD,LABEL)  ; extract, compare, write the two corresponding fields; one from buffer, one from ins files
    106         N BUFDATA,EXTDATA,IBOVER,IBMERG S EXTDATA=""
    107         S BUFDATA=$$GET1^DIQ(355.33,IBBUFDA,BFLD)
    108         I +IBEXTDA S EXTDATA=$$GET1^DIQ(IFILE,IBEXTDA,IFLD)
    109         ;
    110         S IBOVER=$S(BUFDATA'=""&(BUFDATA'=EXTDATA):"B",1:""),IBMERG=$S(EXTDATA="":"B",1:"")
    111         ;
    112         D WRTLN(LABEL,BUFDATA,EXTDATA,IBOVER,IBMERG)
    113         Q
    114         ;
    115 WRTLN(LABEL,FLD1,FLD2,OVER,MERG,ATTR)   ; write a line of formatted data with label and two fields
    116         S ATTR=$G(ATTR),OVER=ATTR_$G(OVER),MERG=ATTR_$G(MERG)
    117         S LABEL=$J(LABEL,17)_"  ",FLD1=FLD1_$J("",29-$L(FLD1)),FLD2=FLD2_$J("",29-$L(FLD2))
    118         W !
    119         D WRTFLD(LABEL,0,19,ATTR),WRTFLD(FLD1,19,29,MERG)
    120         D WRTFLD(" | ",48,3,ATTR),WRTFLD(FLD2,51,29,OVER)
    121         Q
    122         ;
    123 WRTFLD(STRING,COL,WD,ATTR)      ; write an individual field with display attributes
    124         N ATTRB,ATTRE,DX,DY,X,Y
    125         S ATTRB="",ATTRB=$S(ATTR["B":$G(IOINHI),1:"")_$S(ATTR["U":$G(IOUON),1:"")
    126         S ATTRE="",ATTRE=$S(ATTR["B":$G(IOINORM),1:"")_$S(ATTR["U":$G(IOUOFF),1:"")
    127         ;
    128         S DX=COL,DY=$Y X IOXY
    129         W ATTRB,$E(STRING,1,WD),ATTRE
    130         S DX=(COL+WD),DY=$Y X IOXY
    131         Q
     1IBCNBCD ;ALB/ARH-Ins Buffer: display/compare buffer and existing ins ;1 Jun 97
     2 ;;2.0;INTEGRATED BILLING;**82,251,361**;21-MAR-94;Build 9
     3 ;;Per VHA Directive 2004-038, this routine should not be modified.
     4 ;
     5INS(IBBUFDA,IBINSDA) ; display a buffer entry's insurance company fields and
     6 ; an existing insurance company's fields for comparison
     7 N IBEXTDA,IBFLD1,IBFLD2,X I '$G(IBBUFDA) Q
     8 ;
     9 S IBEXTDA=$G(IBINSDA)_","
     10 ;
     11 I +$P($G(^DIC(36,+IBEXTDA,0)),U,5) W !,?10,"Selected Insurance Company "_$$GET1^DIQ(36,IBEXTDA,.01)_" is Inactive!",!
     12 ;
     13 W ! D WRTFLD("  Insurance Data:  Buffer Data                     Selected Insurance Company   ",0,80,"BU")
     14 S IBFLD1=$$GET1^DIQ(355.33,IBBUFDA,20.01),IBFLD2=$S(+IBEXTDA:$$GET1^DIQ(36,IBEXTDA,.01),1:"<none selected>") D WRTLN("Company Name:",IBFLD1,IBFLD2,"","","")
     15 S IBFLD1=$$GET1^DIQ(355.33,IBBUFDA,20.05),IBFLD2=$S(+IBEXTDA:$$GET1^DIQ(36,IBEXTDA,1),1:"") D WRTLN("Reimburse?:",IBFLD1,IBFLD2,"","","U")
     16 ;
     17 D DISPLAY(20.02,36,.131,"Phone Number:")
     18 D DISPLAY(20.03,36,.132,"Billing Phone:")
     19 D DISPLAY(20.04,36,.133,"Pre-Cert Phone:")
     20 D DISPLAY(21.01,36,.111,"Street [Line 1]:")
     21 D DISPLAY(21.02,36,.112,"Street [Line 2]:")
     22 D DISPLAY(21.03,36,.113,"Street [Line 3]:")
     23 D DISPLAY(21.04,36,.114,"City:")
     24 D DISPLAY(21.05,36,.115,"State:")
     25 D DISPLAY(21.06,36,.116,"Zip Code:")
     26 ;
     27 S IBFLD1="(bold=accepted on Merge)",IBFLD2="(bold=replaced on Overwrite)" D WRTLN("",IBFLD1,IBFLD2,"","","U")
     28 Q
     29 ;
     30GRP(IBBUFDA,IBGRPDA) ; display a buffer entry's group insurance fields and an existing group/plan's fields for comparison
     31 N IBEXTDA,IBFLD1,IBFLD2,X I '$G(IBBUFDA) Q
     32 ;
     33 S IBEXTDA=$G(IBGRPDA)_","
     34 ;
     35 I +$P($G(^IBA(355.3,+IBEXTDA,0)),U,11) W !,?23,"Selected Group/Plan is Inactive!",!
     36 ;
     37 W ! D WRTFLD(" Group/Plan Data:  Buffer Data                     Selected Group/Plan          ",0,80,"BU")
     38 S IBFLD1=$$GET1^DIQ(355.33,IBBUFDA,20.01),IBFLD2=$S(+IBEXTDA:$$GET1^DIQ(355.3,IBEXTDA,.01),1:"<none selected>") D WRTLN("Company Name:",IBFLD1,IBFLD2,"","","")
     39 S IBFLD1=$$GET1^DIQ(355.33,IBBUFDA,40.01),IBFLD2=$S(+IBEXTDA:$$GET1^DIQ(355.3,IBEXTDA,.02),1:"") D WRTLN("Is Group Plan?:",IBFLD1,IBFLD2,"","","U")
     40 ;
     41 D DISPLAY(40.02,355.3,.03,"Group Name:")
     42 D DISPLAY(40.03,355.3,.04,"Group Number:")
     43 D DISPLAY(40.1,355.3,6.02,"BIN:") ;;Daou/EEN - adding BIN and PCN
     44 D DISPLAY(40.11,355.3,6.03,"PCN:")
     45 D DISPLAY(40.04,355.3,.05,"Require UR:")
     46 D DISPLAY(40.05,355.3,.06,"Require Pre-Cert:")
     47 D DISPLAY(40.06,355.3,.12,"Require Amb Cert:")
     48 D DISPLAY(40.07,355.3,.07,"Exclude Pre-Cond:")
     49 D DISPLAY(40.08,355.3,.08,"Benefits Assign:")
     50 D DISPLAY(40.09,355.3,.09,"Type of Plan:")
     51 ;
     52 S IBFLD1="(bold=accepted on merge)",IBFLD2="(bold=replaced on overwrite)" D WRTLN("",IBFLD1,IBFLD2,"","","U")
     53 Q
     54 ;
     55POLICY(IBBUFDA,IBPOLDA) ; display a buffer entry's patient policy fields and an existing patient policy's fields for comparison
     56 N DFN,IBEXTDA,IBFLD1,IBFLD2,X,Y,DIR,DIRUT I '$G(IBBUFDA) Q
     57 S DFN=+$G(^IBA(355.33,IBBUFDA,60))
     58 ;
     59 S IBEXTDA=$G(IBPOLDA)_","_DFN_","
     60 ;
     61 W ! D WRTFLD("     Policy Data:  Buffer Data                     Selected Policy              ",0,80,"BU")
     62 S IBFLD1=$$GET1^DIQ(355.33,IBBUFDA,20.01),IBFLD2=$S(+IBEXTDA:$$GET1^DIQ(2.312,IBEXTDA,.01),1:"<none selected>") D WRTLN("Company Name:",IBFLD1,IBFLD2,"","","")
     63 S IBFLD1=$$GET1^DIQ(355.33,IBBUFDA,40.03),IBFLD2=$S(+IBEXTDA:$$GET1^DIQ(2.312,IBEXTDA,21),1:"") D WRTLN("Group #:",IBFLD1,IBFLD2,"","","")
     64 S IBFLD1=$$GET1^DIQ(355.33,IBBUFDA,60.01),IBFLD2=$S(+IBEXTDA:$$GET1^DIQ(2,DFN,.01),1:"") D WRTLN("Patient Name:",IBFLD1,IBFLD2,"","","")
     65 S IBFLD1=$P($$GET1^DIQ(355.33,IBBUFDA,.1),"@"),IBFLD2=$S(+IBEXTDA:$P($$GET1^DIQ(2.312,IBEXTDA,1.03),"@"),1:"") D WRTLN("Last Verified:",IBFLD1,IBFLD2,"","","U")
     66 ;
     67 D DISPLAY(60.02,2.312,8,"Effective Date:")
     68 D DISPLAY(60.03,2.312,3,"Expiration Date:")
     69 D DISPLAY(60.04,2.312,1,"Subscriber Id:")
     70 D DISPLAY(60.05,2.312,6,"Whose Insurance:")
     71 D DISPLAY(60.06,2.312,16,"Relationship:")
     72 D DISPLAY(60.07,2.312,17,"Name of Insured:")
     73 D DISPLAY(60.08,2.312,3.01,"Insured's DOB:")
     74 D DISPLAY(60.09,2.312,3.05,"Insured's SSN:")
     75 D DISPLAY(60.13,2.312,3.12,"Insured's SEX:")
     76 D DISPLAY(60.1,2.312,4.01,"Primary Provider:")
     77 D DISPLAY(60.11,2.312,4.02,"Provider Phone:")
     78 D DISPLAY(60.12,2.312,.2,"Coor of Benefits:")
     79 D DISPLAY(61.01,2.312,2.1,"Emp Sponsored?:")
     80 ;
     81 I +$G(^IBA(355.33,IBBUFDA,61))!($$GET1^DIQ(2.312,IBEXTDA,2.1)="YES") D ESGHP
     82 ;
     83 S IBFLD1="(bold=accepted on merge)",IBFLD2="(bold=replaced on overwrite)" D WRTLN("",IBFLD1,IBFLD2,"","","U")
     84 ;
     85 Q
     86 ;
     87ESGHP ; display employee sponsored group health plan
     88 W ! S DIR(0)="E",DIR("A")="Enter RETURN to continue" D ^DIR W ! Q:$D(DIRUT)
     89 ;
     90 D DISPLAY(61.02,2.312,2.015,"Employer Name:")
     91 D DISPLAY(61.03,2.312,2.11,"Emp Status:")
     92 D DISPLAY(61.04,2.312,2.12,"Retirement Date:")
     93 D DISPLAY(61.05,2.312,2.01,"Send to Employer:")
     94 D DISPLAY(61.06,2.312,2.02,"Emp Street Ln 1:")
     95 D DISPLAY(61.07,2.312,2.03,"Emp Street Ln 2:")
     96 D DISPLAY(61.08,2.312,2.04,"Emp Street Ln 3:")
     97 D DISPLAY(61.09,2.312,2.05,"Emp City:")
     98 D DISPLAY(61.1,2.312,2.06,"Emp State:")
     99 D DISPLAY(61.11,2.312,2.07,"Emp Zip Code:")
     100 D DISPLAY(61.12,2.312,2.08,"Emp Phone:")
     101 ;
     102 Q
     103 ;
     104DISPLAY(BFLD,IFILE,IFLD,LABEL) ; extract, compare, write the two corresponding fields; one from buffer, one from ins files
     105 N BUFDATA,EXTDATA,IBOVER,IBMERG S EXTDATA=""
     106 S BUFDATA=$$GET1^DIQ(355.33,IBBUFDA,BFLD)
     107 I +IBEXTDA S EXTDATA=$$GET1^DIQ(IFILE,IBEXTDA,IFLD)
     108 ;
     109 S IBOVER=$S(BUFDATA'=""&(BUFDATA'=EXTDATA):"B",1:""),IBMERG=$S(EXTDATA="":"B",1:"")
     110 ;
     111 D WRTLN(LABEL,BUFDATA,EXTDATA,IBOVER,IBMERG)
     112 Q
     113 ;
     114WRTLN(LABEL,FLD1,FLD2,OVER,MERG,ATTR) ; write a line of formatted data with label and two fields
     115 S ATTR=$G(ATTR),OVER=ATTR_$G(OVER),MERG=ATTR_$G(MERG)
     116 S LABEL=$J(LABEL,17)_"  ",FLD1=FLD1_$J("",29-$L(FLD1)),FLD2=FLD2_$J("",29-$L(FLD2))
     117 W !
     118 D WRTFLD(LABEL,0,19,ATTR),WRTFLD(FLD1,19,29,MERG)
     119 D WRTFLD(" | ",48,3,ATTR),WRTFLD(FLD2,51,29,OVER)
     120 Q
     121 ;
     122WRTFLD(STRING,COL,WD,ATTR) ; write an individual field with display attributes
     123 N ATTRB,ATTRE,DX,DY,X,Y
     124 S ATTRB="",ATTRB=$S(ATTR["B":$G(IOINHI),1:"")_$S(ATTR["U":$G(IOUON),1:"")
     125 S ATTRE="",ATTRE=$S(ATTR["B":$G(IOINORM),1:"")_$S(ATTR["U":$G(IOUOFF),1:"")
     126 ;
     127 S DX=COL,DY=$Y X IOXY
     128 W ATTRB,$E(STRING,1,WD),ATTRE
     129 S DX=(COL+WD),DY=$Y X IOXY
     130 Q

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNBEE.m

    r613 r623  
    1 IBCNBEE ;ALB/ARH-Ins Buffer: add/edit existing entries in buffer ;1 Jun 97
    2         ;;2.0;INTEGRATED BILLING;**82,184,252,251,356,361,371,377**;21-MAR-94;Build 23
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5 ADD(IBSOURCE)   ; add a new buffer file entry (#355.33), sets only status (0) node data
    6         N IBARR,IBERR,IBIFN,IBX I '$G(IBSOURCE) S IBSOURCE=1
    7         ;
    8         S IBARR(355.33,"+1,",.01)="NOW",IBARR(355.33,"+1,",.03)=IBSOURCE
    9         D UPDATE^DIE("E","IBARR","IBIFN","IBERR")
    10         S IBX=+$G(IBIFN(1)) I $D(IBERR) S $P(IBX,U,2)=$G(IBERR("DIERR",1,"TEXT",1))
    11         Q IBX
    12         ;
    13 STATUS(IBBUFDA,STATUS,NC,NG,NP) ; edit the status node
    14         ;
    15         N IBX,IBARR,IBIFN Q:'$G(IBBUFDA)  S IBIFN=IBBUFDA_","
    16         D CHK^DIE(355.33,.04,"",$G(STATUS),.IBX) Q:IBX="^"
    17         ;
    18         S IBARR(355.33,IBIFN,.04)=STATUS I STATUS="R" S (NC,NG,NP)=0
    19         S IBARR(355.33,IBIFN,.07)=+$G(NC),IBARR(355.33,IBIFN,.08)=+$G(NG),IBARR(355.33,IBIFN,.09)=+$G(NP)
    20         D FILE^DIE("E","IBARR")
    21         Q
    22         ;
    23 INS(IBBUFDA,FLDS)       ; edit the insurance company portion of a buffer file entry
    24         ;
    25         N DIC,DIE,DA,DR,X,Y,IBCNEXT1
    26         I $P($G(^IBA(355.33,+$G(IBBUFDA),0)),U,4)'="E" Q
    27         I $G(FLDS)="" S FLDS="MR"
    28         ;
    29         ; ESG - 6/18/02 - SDD 5.1.4 - Usage of Auto Match when editing
    30         ;     - the insurance company name in the buffer.  Also added an
    31         ;     - input transform (see below) to clean up the data coming in.
    32         ;     - fetch the current buffer ins co name
    33         ;
    34         I FLDS="MR" S IBCNEXT1=$P($G(^IBA(355.33,IBBUFDA,20)),U,1)
    35         ;
    36         S DR=$P($T(@(FLDS_"INS")+1),";;",2,9999) Q:DR=""
    37         ;
    38         I FLDS="MR" Q:$$INSNAME(IBBUFDA)<0  S DR=$P($T(@(FLDS_"INS")+1),";;",2,9999),DR=$P(DR,";",2,99999)
    39         ;
    40         S DIE="^IBA(355.33,",DA=IBBUFDA D ^DIE K DIE,DA,DR
    41         Q
    42         ;
    43 GRP(IBBUFDA,FLDS)       ; edit the group/plan portion of the buffer file entry
    44         ;
    45         N DIC,DIE,DA,DR,X,Y I $P($G(^IBA(355.33,+$G(IBBUFDA),0)),U,4)'="E" Q
    46         I $G(FLDS)="" S FLDS="MR"
    47         ;
    48         S DR=$P($T(@(FLDS_"GRP")+1),";;",2,9999) Q:DR=""
    49         S DIE="^IBA(355.33,",DA=IBBUFDA D ^DIE K DIE,DA,DR
    50         Q
    51         ;
    52 POLICY(IBBUFDA,FLDS)    ; edit the patient policy portion of the buffer file entry
    53         ;
    54         N DIC,DIE,DA,DR,X,Y,IBZZ I $P($G(^IBA(355.33,+$G(IBBUFDA),0)),U,4)'="E" Q
    55         I $G(FLDS)="" S FLDS="MR"
    56         ;
    57         S DR=$P($T(@(FLDS_"POL")+1),";;",2,9999) Q:DR=""
    58         S DIE="^IBA(355.33,",DA=IBBUFDA
    59         S DIE("NO^")="BACKOUTOK" D ^DIE K DIE,DA,DR Q:$D(Y)
    60         ;
    61         I FLDS="MR" D ESGHP(IBBUFDA)
    62         Q
    63         ;
    64 ESGHP(IBBUFDA)  ; sponsoring employer information
    65         N DIR,DIRUT,DUOUT,DTOUT,VAOA,VAERR,VA,DFN,IB60,IBE,IBEMPST,IBREL
    66         ;
    67         ; if insured is patient or spouse, ask if insured's current employer is the plan's sponsoring employer, if yes auto stuff it
    68         I +$G(^IBA(355.33,IBBUFDA,61)) W ! S IB60=$G(^IBA(355.33,IBBUFDA,60)) D  Q:$D(DIRUT)
    69         . ; sponsoring employer is current employer?
    70         . S DFN=+IB60,IBREL=$P(IB60,U,6),VAOA("A")=$S(IBREL="01":5,IBREL="02":6,1:"") I 'DFN!(VAOA("A")="") Q
    71         . D OAD^VADPT I $G(VAOA(9))="" Q
    72         . S DIR("?")="Enter Yes if this plan is sponsored by the "_$S(IBREL="01":"patient's",1:"spouse's")_" current employer."
    73         . S DIR("?",1)="Entering Yes will result in the "_$S(IBREL="01":"patient's",1:"spouse's")_" current employer data being",DIR("?",2)="added to the policy as the Sponsoring Employer data.",DIR("?",3)=""
    74         . S DIR("A")="Current Employer "_VAOA(9)_" Sponsors this Plan",DIR("B")="No",DIR(0)="Y" D ^DIR W ! I Y'=1 Q
    75         . ;
    76         . D DELEMP(IBBUFDA) ; delete any data already contained in these fields
    77         . ;
    78         . ; if the insured's current employer sponsors the plan then stuff that employer's address into the buffer
    79         . S IBE=$S(IBREL="01":.311,1:.25),IBEMPST=$P($G(^DPT(DFN,IBE)),U,15)
    80         . S DR="61.02///"_VAOA(9)_";61.03///"_IBEMPST_";61.06///"_$E(VAOA(1),1,30)_";61.07///"_$E(VAOA(2),1,30)
    81         . S DR=DR_";61.08///"_$E(VAOA(3),1,30)_";61.09///"_$E(VAOA(4),1,20)_";61.1////"_$P(VAOA(5),U,1)
    82         . S DR=DR_";61.11////"_$P(VAOA(11),U,1)_";61.12///"_$E(VAOA(8),1,15)
    83         . S DIE="^IBA(355.33,",DA=IBBUFDA D ^DIE K DIE,DA,DR
    84         ;
    85         ; if employer sponsored plan, edit buffer entry's sponsoring employer info
    86         I +$G(^IBA(355.33,IBBUFDA,61)) S DR="61.02:61.12",DIE="^IBA(355.33,",DA=IBBUFDA D ^DIE K DIE,DA,DR
    87         ;
    88         ; if not employer sponsored plan, delete any existing sponsoring employer data
    89         I $D(^IBA(355.33,IBBUFDA,61)),'$G(^IBA(355.33,IBBUFDA,61)) D DELEMP(IBBUFDA)
    90         Q
    91         ;
    92 DELEMP(IBBUFDA) ; delete sponsoring employer data
    93         N DIC,DIE,DA,DR,X,Y Q:'$D(^IBA(355.33,+$G(IBBUFDA),61))
    94         S DR="61.02///@;61.03///@;61.04///@;61.05///@;61.06///@;61.07///@;61.08///@;61.09///@;61.10///@;61.11///@;61.12///@"
    95         S DIE="^IBA(355.33,",DA=IBBUFDA D ^DIE K DIE,DA,DR
    96         Q
    97         ;
    98 INSHELP ;
    99         W !!,"------------------------ INSURANCE COMPANY INFORMATION -------------------------",!
    100         Q
    101 GRPHELP ;
    102         W !!,"---------------------------- GROUP/PLAN INFORMATION ----------------------------"
    103         W !," The following data defines a specific Group or Plan provided by an Insurance "
    104         W !," Company.  This may be either a group plan with many potential members or an "
    105         W !," individual plan with a single member.",!
    106         Q
    107 POLHELP ;
    108         W !!,"---------------------- POLICY AND SUBSCRIBER INFORMATION -----------------------"
    109         W !," The following data defines the subscriber specific policy information for a "
    110         W !," particular Insurance Plan.  The subscriber, the insured, and the policy holder "
    111         W !," all refer to the person who is a member of the plan and therefore holds the "
    112         W !," policy.  The patient must be covered under the plan but may not be the policy"
    113         W !," holder.",!
    114         Q
    115         ;
    116 INSNAME(IBBUFDA)        ;  Reset insurance company name
    117         N DR,DIE,DA,Y,X,IBX,IBNEW,IBNAME
    118         S IBX=-1
    119         S DR=20.01,DIE="^IBA(355.33,",DA=IBBUFDA
    120         D ^DIE
    121         I '$D(Y) S IBNEW=$$CHECK(IBBUFDA)
    122         I +$G(IBNEW)'<0,$G(IBNEW)'=0,$D(IBNEW) S DR=$P(DR,";",1)_"////"_IBNEW S DIE="^IBA(355.33,",DA=IBBUFDA D ^DIE K DIE,DA,DR I '$D(Y) S IBX=0
    123         ; BHS - 10/15/03 - If user entered a caret during $$CHECK still set
    124         ;                  return value to 0 so the user can edit the other
    125         ;                  INS fields
    126         I $G(IBNEW)=0!($G(IBNEW)=-1) S IBX=0
    127         Q IBX
    128         ;
    129 CHECK(IBBUFDA)  ; Select Insurance Company Name and Automatch
    130         ; Buffer file (#355.33), field# 20.01.
    131         ; ESG - 6/18/02 - SDD 5.1.4 - Usage of Auto Match when editing the
    132         ;       insurance company name.  Also, display the insurance company
    133         ;       name lookup/lister and the Auto Match lookup/lister.
    134         ;
    135         NEW IBNEW,IBNAME,AMLIST
    136         ;
    137         S IBNEW=0,IBNAME=$P($G(^IBA(355.33,$G(IBBUFDA),20)),U,1)
    138         I IBNAME="" G CHECKQ
    139         ;
    140         ; Perform an insurance company lookup/lister
    141         ; BHS - 10/15/03 - Removed quits when user enters a caret to quit the
    142         ;                  the ins lister or Auto Match lister
    143         S IBNEW=$$DICINS^IBCNBU1(IBNAME,1,10)
    144         I IBNEW=0!(IBNEW<0) D
    145         . I '$$AMLOOK^IBCNEUT1(IBNAME,1,.AMLIST) Q
    146         . S IBNEW=$$AMSEL^IBCNEUT1(.AMLIST)
    147         ;
    148         ; user chose a valid insurance company - possible Auto Match add
    149         I IBNEW'<0,IBNEW'=0 D AMADD^IBCNEUT6(X,IBCNEXT1)
    150         ;
    151 CHECKQ  Q IBNEW
    152         ;
    153 MRINS   ; Insurance Company fields asked of MCCR users in the Buffer Process options (all buffer ins fields 20.01-21.06)
    154         ;;20.01;20.05;20.02:20.04;21.01;I X="" S Y="@111";21.02;I X="" S Y="@111";21.03;@111;21.04:21.06
    155         ;
    156 MRGRP   ; Group/Plan fields asked of MCCR users in the Buffer Process options (all buffer grp fields 40.01-40.09) ;;Daou/EEN adding BIN and PCN (40.1,40.11)
    157         ;;40.01:40.03;40.1;40.11;40.09;40.04:40.08
    158         ;
    159 MRPOL   ; Patient Policy fields asked of MCCR users in the Buffer Process options (all buffer policy fields except ESGHP,60.05,60.06 60.02-61.01
    160         ;;60.02;60.03;60.14PT. RELATIONSHIP TO INSURED;S IBZZ=X;60.04T;I IBZZ'="18" S Y="@111";60.07///1;60.08///@;60.09///@;62.01///@;S Y="@112";@111;60.07;60.08;60.13;62.01T;@112;60.1:60.12;.03;61.01
    161         ;
    162 OTINS   ; Insurance Company fields asked of non-MCCR users entering buffer data from options outside IB (20.01-20.04,21.01-21.06)
    163         ;;20.01:20.04;21.01;I X="" S Y="@111";21.02;I X="" S Y="@111";21.03;@111;21.04:21.06
    164         ;
    165 OTGRP   ; Group/Plan fields asked of non-MCCR users entering buffer data from options outside IB (40.02,40.03,40.09) ;;Daou/EEN-adding BIN & PCN (40.1,40.11)
    166         ;;40.02;40.03;40.1;40.11;40.09
    167         ;
    168 OTPOL   ; Patient Policy fields asked of non-MCCR users entering buffer data from options outside IB (60.02-60.08)
    169         ;;60.02;60.03;60.14PT. RELATIONSHIP TO INSURED;S IBZZ=X;60.04T;I IBZZ'="18" S Y="@111";60.07///1;60.08///@;60.09///@;62.01///@;S Y="@112";@111;60.07;60.08;60.13;62.01T;@112
     1IBCNBEE ;ALB/ARH-Ins Buffer: add/edit existing entries in buffer ;1 Jun 97
     2 ;;2.0;INTEGRATED BILLING;**82,184,252,251,356,361**;21-MAR-94;Build 9
     3 ;;Per VHA Directive 2004-038, this routine should not be modified.
     4 ;
     5ADD(IBSOURCE) ; add a new buffer file entry (#355.33), sets only status (0) node data
     6 N IBARR,IBERR,IBIFN,IBX I '$G(IBSOURCE) S IBSOURCE=1
     7 ;
     8 S IBARR(355.33,"+1,",.01)="NOW",IBARR(355.33,"+1,",.03)=IBSOURCE
     9 D UPDATE^DIE("E","IBARR","IBIFN","IBERR")
     10 S IBX=+$G(IBIFN(1)) I $D(IBERR) S $P(IBX,U,2)=$G(IBERR("DIERR",1,"TEXT",1))
     11 Q IBX
     12 ;
     13STATUS(IBBUFDA,STATUS,NC,NG,NP) ; edit the status node
     14 ;
     15 N IBX,IBARR,IBIFN Q:'$G(IBBUFDA)  S IBIFN=IBBUFDA_","
     16 D CHK^DIE(355.33,.04,"",$G(STATUS),.IBX) Q:IBX="^"
     17 ;
     18 S IBARR(355.33,IBIFN,.04)=STATUS I STATUS="R" S (NC,NG,NP)=0
     19 S IBARR(355.33,IBIFN,.07)=+$G(NC),IBARR(355.33,IBIFN,.08)=+$G(NG),IBARR(355.33,IBIFN,.09)=+$G(NP)
     20 D FILE^DIE("E","IBARR")
     21 Q
     22 ;
     23INS(IBBUFDA,FLDS) ; edit the insurance company portion of a buffer file entry
     24 ;
     25 N DIC,DIE,DA,DR,X,Y,IBCNEXT1
     26 I $P($G(^IBA(355.33,+$G(IBBUFDA),0)),U,4)'="E" Q
     27 I $G(FLDS)="" S FLDS="MR"
     28 ;
     29 ; ESG - 6/18/02 - SDD 5.1.4 - Usage of Auto Match when editing
     30 ;     - the insurance company name in the buffer.  Also added an
     31 ;     - input transform (see below) to clean up the data coming in.
     32 ;     - fetch the current buffer ins co name
     33 ;
     34 I FLDS="MR" S IBCNEXT1=$P($G(^IBA(355.33,IBBUFDA,20)),U,1)
     35 ;
     36 S DR=$P($T(@(FLDS_"INS")+1),";;",2,9999) Q:DR=""
     37 ;
     38 I FLDS="MR" Q:$$INSNAME(IBBUFDA)<0  S DR=$P($T(@(FLDS_"INS")+1),";;",2,9999),DR=$P(DR,";",2,99999)
     39 ;
     40 S DIE="^IBA(355.33,",DA=IBBUFDA D ^DIE K DIE,DA,DR
     41 Q
     42 ;
     43GRP(IBBUFDA,FLDS) ; edit the group/plan portion of the buffer file entry
     44 ;
     45 N DIC,DIE,DA,DR,X,Y I $P($G(^IBA(355.33,+$G(IBBUFDA),0)),U,4)'="E" Q
     46 I $G(FLDS)="" S FLDS="MR"
     47 ;
     48 S DR=$P($T(@(FLDS_"GRP")+1),";;",2,9999) Q:DR=""
     49 S DIE="^IBA(355.33,",DA=IBBUFDA D ^DIE K DIE,DA,DR
     50 Q
     51 ;
     52POLICY(IBBUFDA,FLDS) ; edit the patient policy portion of the buffer file entry
     53 ;
     54 N DIC,DIE,DA,DR,X,Y,IBZZ I $P($G(^IBA(355.33,+$G(IBBUFDA),0)),U,4)'="E" Q
     55 I $G(FLDS)="" S FLDS="MR"
     56 ;
     57 S DR=$P($T(@(FLDS_"POL")+1),";;",2,9999) Q:DR=""
     58 S DIE="^IBA(355.33,",DA=IBBUFDA
     59 S DIE("NO^")="BACKOUTOK" D ^DIE K DIE,DA,DR Q:$D(Y)
     60 ;
     61 I FLDS="MR" D ESGHP(IBBUFDA)
     62 Q
     63 ;
     64ESGHP(IBBUFDA) ; sponsoring employer information
     65 N DIR,DIRUT,DUOUT,DTOUT,VAOA,VAERR,VA,DFN,IB60,IBE,IBEMPST,IBREL
     66 ;
     67 ; if insured is patient or spouse, ask if insured's current employer is the plan's sponsoring employer, if yes auto stuff it
     68 I +$G(^IBA(355.33,IBBUFDA,61)) W ! S IB60=$G(^IBA(355.33,IBBUFDA,60)) D  Q:$D(DIRUT)
     69 . ; sponsoring employer is current employer?
     70 . S DFN=+IB60,IBREL=$P(IB60,U,6),VAOA("A")=$S(IBREL="01":5,IBREL="02":6,1:"") I 'DFN!(VAOA("A")="") Q
     71 . D OAD^VADPT I $G(VAOA(9))="" Q
     72 . S DIR("?")="Enter Yes if this plan is sponsored by the "_$S(IBREL="01":"patient's",1:"spouse's")_" current employer."
     73 . S DIR("?",1)="Entering Yes will result in the "_$S(IBREL="01":"patient's",1:"spouse's")_" current employer data being",DIR("?",2)="added to the policy as the Sponsoring Employer data.",DIR("?",3)=""
     74 . S DIR("A")="Current Employer "_VAOA(9)_" Sponsors this Plan",DIR("B")="No",DIR(0)="Y" D ^DIR W ! I Y'=1 Q
     75 . ;
     76 . D DELEMP(IBBUFDA) ; delete any data already contained in these fields
     77 . ;
     78 . ; if the insured's current employer sponsors the plan then stuff that employer's address into the buffer
     79 . S IBE=$S(IBREL="01":.311,1:.25),IBEMPST=$P($G(^DPT(DFN,IBE)),U,15)
     80 . S DR="61.02///"_VAOA(9)_";61.03///"_IBEMPST_";61.06///"_$E(VAOA(1),1,30)_";61.07///"_$E(VAOA(2),1,30)
     81 . S DR=DR_";61.08///"_$E(VAOA(3),1,30)_";61.09///"_$E(VAOA(4),1,20)_";61.1////"_$P(VAOA(5),U,1)
     82 . S DR=DR_";61.11////"_$P(VAOA(11),U,1)_";61.12///"_$E(VAOA(8),1,15)
     83 . S DIE="^IBA(355.33,",DA=IBBUFDA D ^DIE K DIE,DA,DR
     84 ;
     85 ; if employer sponsored plan, edit buffer entry's sponsoring employer info
     86 I +$G(^IBA(355.33,IBBUFDA,61)) S DR="61.02:61.12",DIE="^IBA(355.33,",DA=IBBUFDA D ^DIE K DIE,DA,DR
     87 ;
     88 ; if not employer sponsored plan, delete any existing sponsoring employer data
     89 I $D(^IBA(355.33,IBBUFDA,61)),'$G(^IBA(355.33,IBBUFDA,61)) D DELEMP(IBBUFDA)
     90 Q
     91 ;
     92DELEMP(IBBUFDA) ; delete sponsoring employer data
     93 N DIC,DIE,DA,DR,X,Y Q:'$D(^IBA(355.33,+$G(IBBUFDA),61))
     94 S DR="61.02///@;61.03///@;61.04///@;61.05///@;61.06///@;61.07///@;61.08///@;61.09///@;61.10///@;61.11///@;61.12///@"
     95 S DIE="^IBA(355.33,",DA=IBBUFDA D ^DIE K DIE,DA,DR
     96 Q
     97 ;
     98INSHELP ;
     99 W !!,"------------------------ INSURANCE COMPANY INFORMATION -------------------------",!
     100 Q
     101GRPHELP ;
     102 W !!,"---------------------------- GROUP/PLAN INFORMATION ----------------------------"
     103 W !," The following data defines a specific Group or Plan provided by an Insurance "
     104 W !," Company.  This may be either a group plan with many potential members or an "
     105 W !," individual plan with a single member.",!
     106 Q
     107POLHELP ;
     108 W !!,"---------------------- POLICY AND SUBSCRIBER INFORMATION -----------------------"
     109 W !," The following data defines the subscriber specific policy information for a "
     110 W !," particular Insurance Plan.  The subscriber, the insured, and the policy holder "
     111 W !," all refer to the person who is a member of the plan and therefore holds the "
     112 W !," policy.  The patient must be covered under the plan but may not be the policy"
     113 W !," holder.",!
     114 Q
     115 ;
     116INSNAME(IBBUFDA) ;  Reset insurance company name
     117 N DR,DIE,DA,Y,X,IBX,IBNEW,IBNAME
     118 S IBX=-1
     119 S DR=20.01,DIE="^IBA(355.33,",DA=IBBUFDA
     120 D ^DIE
     121 I '$D(Y) S IBNEW=$$CHECK(IBBUFDA)
     122 I +$G(IBNEW)'<0,$G(IBNEW)'=0,$D(IBNEW) S DR=$P(DR,";",1)_"////"_IBNEW S DIE="^IBA(355.33,",DA=IBBUFDA D ^DIE K DIE,DA,DR I '$D(Y) S IBX=0
     123 ; BHS - 10/15/03 - If user entered a caret during $$CHECK still set
     124 ;                  return value to 0 so the user can edit the other
     125 ;                  INS fields
     126 I $G(IBNEW)=0!($G(IBNEW)=-1) S IBX=0
     127 Q IBX
     128 ;
     129CHECK(IBBUFDA) ; Select Insurance Company Name and Automatch
     130 ; Buffer file (#355.33), field# 20.01.
     131 ; ESG - 6/18/02 - SDD 5.1.4 - Usage of Auto Match when editing the
     132 ;       insurance company name.  Also, display the insurance company
     133 ;       name lookup/lister and the Auto Match lookup/lister.
     134 ;
     135 NEW IBNEW,IBNAME,AMLIST
     136 ;
     137 S IBNEW=0,IBNAME=$P($G(^IBA(355.33,$G(IBBUFDA),20)),U,1)
     138 I IBNAME="" G CHECKQ
     139 ;
     140 ; Perform an insurance company lookup/lister
     141 ; BHS - 10/15/03 - Removed quits when user enters a caret to quit the
     142 ;                  the ins lister or Auto Match lister
     143 S IBNEW=$$DICINS^IBCNBU1(IBNAME,1,10)
     144 I IBNEW=0!(IBNEW<0) D
     145 . I '$$AMLOOK^IBCNEUT1(IBNAME,1,.AMLIST) Q
     146 . S IBNEW=$$AMSEL^IBCNEUT1(.AMLIST)
     147 ;
     148 ; user chose a valid insurance company - possible Auto Match add
     149 I IBNEW'<0,IBNEW'=0 D AMADD^IBCNEUT6(X,IBCNEXT1)
     150 ;
     151CHECKQ Q IBNEW
     152 ;
     153MRINS ; Insurance Company fields asked of MCCR users in the Buffer Process options (all buffer ins fields 20.01-21.06)
     154 ;;20.01;20.05;20.02:20.04;21.01;I X="" S Y="@111";21.02;I X="" S Y="@111";21.03;@111;21.04:21.06
     155 ;
     156MRGRP ; Group/Plan fields asked of MCCR users in the Buffer Process options (all buffer grp fields 40.01-40.09) ;;Daou/EEN adding BIN and PCN (40.1,40.11)
     157 ;;40.01:40.03;40.1;40.11;40.09;40.04:40.08
     158 ;
     159MRPOL ; Patient Policy fields asked of MCCR users in the Buffer Process options (all buffer policy fields except ESGHP 60.02-61.01
     160 ;;60.02;60.03;60.05;60.06//^S X=$S(X="v":"01",X="s":"02",1:"");S IBZZ=X;60.04;I IBZZ'="01" S Y="@111";60.07///1;60.08///@;60.09///@;S Y="@112";@111;60.07:60.09;60.13;@112;60.1:60.12;.03;61.01
     161 ;
     162OTINS ; Insurance Company fields asked of non-MCCR users entering buffer data from options outside IB (20.01-20.04,21.01-21.06)
     163 ;;20.01:20.04;21.01;I X="" S Y="@111";21.02;I X="" S Y="@111";21.03;@111;21.04:21.06
     164 ;
     165OTGRP ; Group/Plan fields asked of non-MCCR users entering buffer data from options outside IB (40.02,40.03,40.09) ;;Daou/EEN-adding BIN & PCN (40.1,40.11)
     166 ;;40.02;40.03;40.1;40.11;40.09
     167 ;
     168OTPOL ; Patient Policy fields asked of non-MCCR users entering buffer data from options outside IB (60.02-60.09)
     169 ;;60.02;60.03;60.05;60.06//^S X=$S(X="v":"01",X="s":"02",1:"");S IBZZ=X;60.04;I IBZZ'="01" S Y="@111";60.07///1;60.08///@;60.09///@;S Y="@112";@111;60.07:60.09;60.13;@112

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNBLE.m

    r613 r623  
    1 IBCNBLE ;ALB/ARH-Ins Buffer: LM buffer entry screen ;1 Jun 97
    2         ;;2.0;INTEGRATED BILLING;**82,231,184,251,371**;21-MAR-94;Build 57
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5 EN      ; - main entry point for list manager display
    6         N DFN
    7         D EN^VALM("IBCNB INSURANCE BUFFER ENTRY")
    8         Q
    9         ;
    10 HDR     ; - header code for list manager display
    11         N IBX,IB0,VADM,VA,VAERR S IBX=""
    12         I +$G(DFN) D DEM^VADPT S IBX=$E(VADM(1),1,28),IBX=IBX_$J("",35-$L(IBX))_$P(VADM(2),U,2)_"    DOB: "_$P(VADM(3),U,2)_"    AGE: "_VADM(4)
    13         S VALMHDR(1)=IBX
    14         S IB0=$G(^IBA(355.33,+$G(IBBUFDA),0))
    15         S IBX=$E($P($G(^VA(200,+$P(IB0,U,2),0)),U,1),1,27)_" ("_$E($$EXPAND^IBTRE(355.33,.03,$P(IB0,U,3)),1,11)_")"
    16         S IBX="Buffer entry created on "_$$DATE(+IB0)_" by "_IBX,IBX=$J("",40-($L(IBX)\2))_IBX
    17         S VALMHDR(2)=IBX
    18         S IBX="" I +$P(IB0,U,10) S IBX="Buffer entry verified on "_$$DATE(+$P(IB0,U,10))_" by "_$E($P($G(^VA(200,+$P(IB0,U,11),0)),U,1),1,27),IBX=$J("",40-($L(IBX)\2))_IBX
    19         S VALMHDR(3)=IBX
    20         Q
    21         ;
    22 INIT    ; - initialization of list manager screen, ifn of record to display required IBBUFDA
    23         K ^TMP("IBCNBLE",$J)
    24         I '$G(IBBUFDA) S VALMQUIT="" Q
    25         S DFN=+$G(^IBA(355.33,IBBUFDA,60))
    26         D BLD
    27         Q
    28         ;
    29 HELP    ; - help text for list manager screen
    30         D FULL^VALM1
    31         W !!,"This screen displays all data in a Buffer File entry."
    32         W !!,"The actions allow editing of all data and verification of coverage."
    33         W !!,"It is not necessary to use the Verify Entry action, this action is optional.",!,"If the Verify Entry action is not used, the policy will be automatically flagged",!,"as verified when it is Accepted and stored in the main Insurance files."
    34         D PAUSE^VALM1 S VALMBCK="R"
    35         Q
    36         ;
    37 EXIT    ; - exit list manager screen
    38         K ^TMP("IBCNBLE",$J)
    39         D CLEAR^VALM1
    40         Q
    41         ;
    42 BLD     ; display buffer entry
    43         N IB0,IB20,IB40,IB60,IB61,IB62,IBL,IBLINE,ADDR,IBI,IBY
    44         S VALMCNT=0
    45         S IB0=$G(^IBA(355.33,IBBUFDA,0)),IB20=$G(^IBA(355.33,IBBUFDA,20)),IB40=$G(^IBA(355.33,IBBUFDA,40))
    46         S IB60=$G(^IBA(355.33,IBBUFDA,60)),IB61=$G(^IBA(355.33,IBBUFDA,61)),IB62=$G(^IBA(355.33,IBBUFDA,62))
    47         ;
    48         D SET(" ") S IBY=$J("",26)_"Insurance Company Information" D SET(IBY,"B") S IBLINE=""
    49         S IBL="Name: ",IBY=$P(IB20,U,1) S IBLINE=$$SETL("",IBY,IBL,10,30)
    50         S IBL="Reimburse?: ",IBY=$$EXPAND^IBTRE(355.33,20.05,$P(IB20,U,5)) S IBLINE=$$SETL(IBLINE,IBY,IBL,57,20)
    51         D SET(IBLINE) S IBLINE=""
    52         S IBL="Phone: ",IBY=$P(IB20,U,2) S IBLINE=$$SETL(IBLINE,IBY,IBL,10,20)
    53         S IBL="Billing Phone: ",IBY=$P(IB20,U,3) S IBLINE=$$SETL(IBLINE,IBY,IBL,57,20)
    54         D SET(IBLINE) S IBLINE=""
    55         S IBL="Precert Phone: ",IBY=$P(IB20,U,4) S IBLINE=$$SETL(IBLINE,IBY,IBL,57,20)
    56         D SET(IBLINE) S IBLINE=""
    57         S IBL="Remote Query From: ",IBY=$$EXTERNAL^DILFD(355.33,.14,"",$P(IB0,"^",14)) S IBLINE=$$SETL(IBLINE,IBY,IBL,57,20)
    58         D SET(IBLINE) S IBLINE="" D ADDR(21,1)
    59         S IBL="Address: ",IBY=ADDR(1) S IBLINE=$$SETL(IBLINE,IBY,IBL,10,69)
    60         D SET(IBLINE) S IBLINE=""
    61         F IBI=2:1:9 S IBL="",IBY=$G(ADDR(IBI)) Q:IBY=""  S IBLINE=$$SETL(IBLINE,IBY,IBL,10,69) D SET(IBLINE) S IBLINE=""
    62         ;
    63         D SET(" ") S IBY=$J("",29)_"Group/Plan Information" D SET(IBY,"B") S IBLINE=""
    64         S IBL="Group Plan?: ",IBY=$$YN($P(IB40,U,1)) S IBLINE=$$SETL("",IBY,IBL,16,3)
    65         S IBL="Require UR: ",IBY=$$YN($P(IB40,U,4)) S IBLINE=$$SETL(IBLINE,IBY,IBL,63,3)
    66         D SET(IBLINE) S IBLINE=""
    67         S IBL="Group Name: ",IBY=$P(IB40,U,2) S IBLINE=$$SETL("",IBY,IBL,16,20)
    68         S IBL="Require Amb Cert: ",IBY=$$YN($P(IB40,U,6)) S IBLINE=$$SETL(IBLINE,IBY,IBL,63,3)
    69         D SET(IBLINE) S IBLINE=""
    70         S IBL="Group Number: ",IBY=$P(IB40,U,3) S IBLINE=$$SETL("",IBY,IBL,16,17)
    71         S IBL="Require Pre-Cert: ",IBY=$$YN($P(IB40,U,5)) S IBLINE=$$SETL(IBLINE,IBY,IBL,63,3)
    72         ;;Daou/EEN - Adding BIN and PCN
    73         D SET(IBLINE) S IBLINE=""
    74         S IBL="BIN: ",IBY=$P(IB40,U,10) S IBLINE=$$SETL("",IBY,IBL,16,10)
    75         D SET(IBLINE) S IBLINE=""
    76         S IBL="PCN: ",IBY=$P(IB40,U,11) S IBLINE=$$SETL("",IBY,IBL,16,20)
    77         D SET(IBLINE) S IBLINE=""
    78         S IBL="Type of Plan: ",IBY=$P($G(^IBE(355.1,+$P(IB40,U,9),0)),U,1) S IBLINE=$$SETL("",IBY,IBL,16,25)
    79         S IBL="Exclude Pre-Cond: ",IBY=$$YN($P(IB40,U,7)) S IBLINE=$$SETL(IBLINE,IBY,IBL,63,3)
    80         D SET(IBLINE) S IBLINE=""
    81         S IBL="Benefits Assignable: ",IBY=$$YN($P(IB40,U,8)) S IBLINE=$$SETL(IBLINE,IBY,IBL,63,3)
    82         D SET(IBLINE) S IBLINE=""
    83         ;
    84         D SET(" ") S IBY=$J("",26)_"Policy/Subscriber Information" D SET(IBY,"B") S IBLINE=""
    85         S IBL="Whose Insurance: ",IBY=$$EXPAND^IBTRE(355.33,60.05,$P(IB60,U,5)) S IBLINE=$$SETL("",IBY,IBL,18,7)
    86         S IBL="Effective: ",IBY=$$DATE($P(IB60,U,2)) S IBLINE=$$SETL(IBLINE,IBY,IBL,62,8)
    87         D SET(IBLINE) S IBLINE=""
    88         S IBL="Insured's Name: ",IBY=$P(IB60,U,7) S IBLINE=$$SETL("",IBY,IBL,18,30)
    89         S IBL="Expiration: ",IBY=$$DATE($P(IB60,U,3)) S IBLINE=$$SETL(IBLINE,IBY,IBL,62,13)
    90         D SET(IBLINE) S IBLINE=""
    91         S IBL="Subscriber Id: ",IBY=$P(IB60,U,4) S IBLINE=$$SETL("",IBY,IBL,18,20)
    92         S IBL="Primary Provider: ",IBY=$P(IB60,U,10) S IBLINE=$$SETL(IBLINE,IBY,IBL,62,17)
    93         D SET(IBLINE) S IBLINE=""
    94         S IBL="Relationship: ",IBY=$$EXPAND^IBTRE(355.33,60.06,$P(IB60,U,6)) S IBLINE=$$SETL("",IBY,IBL,18,16)
    95         S IBL="Provider Phone: ",IBY=$P(IB60,U,11) S IBLINE=$$SETL(IBLINE,IBY,IBL,62,16)
    96         D SET(IBLINE) S IBLINE=""
    97         I $P(IB60,U,6)'="01"!($P(IB60,U,8)'="") S IBL="Insured's DOB: ",IBY=$$DATE($P(IB60,U,8)) S IBLINE=$$SETL("",IBY,IBL,18,8)
    98         S IBL="Coord of Benefits: ",IBY=$$EXPAND^IBTRE(355.33,60.12,$P(IB60,U,12)) S IBLINE=$$SETL(IBLINE,IBY,IBL,62,16)
    99         D SET(IBLINE) S IBLINE=""
    100         I $P(IB62,U)'="" S IBL="Patient Id: ",IBY=$P(IB62,U) S IBLINE=$$SETL(IBLINE,IBY,IBL,62,13)
    101         I IBLINE'="" D SET(IBLINE) S IBLINE=""
    102         ;
    103         I '$P(IB61,U,1) D SET(" ") S IBL="Employer Sponsored Group Health Plan?: ",IBY=$$YN($P(IB61,U,1)) S IBLINE=$$SETL("",IBY,IBL,40,3) D SET(IBLINE) S IBLINE="" G NXT
    104         ;
    105         D ADDR(61,6)
    106         D SET(" ") S IBY=$J("",24)_"Subscriber's Employer Information" D SET(IBY,"B") S IBLINE=""
    107         S IBL="Employer Sponsored?: ",IBY=$$YN($P(IB61,U,1)) S IBLINE=$$SETL("",IBY,IBL,22,3)
    108         S IBL="Employment Status: ",IBY=$$EXPAND^IBTRE(355.33,61.03,$P(IB61,U,3)) S IBLINE=$$SETL(IBLINE,IBY,IBL,64,15)
    109         D SET(IBLINE) S IBLINE=""
    110         S IBL="Claim to Employer: ",IBY=$$YN($P(IB61,U,5)) S IBLINE=$$SETL("",IBY,IBL,22,3)
    111         S IBL="Retirement Date: ",IBY=$$DATE($P(IB61,U,4)) S IBLINE=$$SETL(IBLINE,IBY,IBL,64,8)
    112         D SET(IBLINE) S IBLINE=""
    113         S IBL="Employer Name: ",IBY=$P(IB61,U,2) S IBLINE=$$SETL("",IBY,IBL,16,30)
    114         S IBL="Employer Phone: ",IBY=$P(IB61,U,12) S IBLINE=$$SETL(IBLINE,IBY,IBL,64,15)
    115         D SET(IBLINE) S IBLINE=""
    116         S IBL="Address: ",IBY=ADDR(1) S IBLINE=$$SETL(IBLINE,IBY,IBL,16,64)
    117         D SET(IBLINE) S IBLINE=""
    118         F IBI=2:1:9 S IBL="",IBY=$G(ADDR(IBI)) Q:IBY=""  S IBLINE=$$SETL(IBLINE,IBY,IBL,16,64) D SET(IBLINE) S IBLINE=""
    119         ;
    120 NXT     ;
    121         D SET(" ") S IBY=$J("",26)_"Buffer Entry Information" D SET(IBY,"B") S IBLINE=""
    122         S IBL="Date Entered: ",IBY=$$FMTE^XLFDT($P(IB0,U,1),2) S IBLINE=$$SETL("",IBY,IBL,18,17)
    123         S IBL="Date Verified: ",IBY=$$FMTE^XLFDT($P(IB0,U,10),2) S IBLINE=$$SETL(IBLINE,IBY,IBL,62,17)
    124         D SET(IBLINE) S IBLINE=""
    125         S IBL="Entered By: ",IBY=$$EXPAND^IBTRE(355.33,.02,$P(IB0,U,2)) S IBLINE=$$SETL("",IBY,IBL,18,40)
    126         S IBL="Verified By: ",IBY=$$EXPAND^IBTRE(355.33,.11,$P(IB0,U,11)) S IBLINE=$$SETL(IBLINE,IBY,IBL,62,17)
    127         D SET(IBLINE) S IBLINE=""
    128         ;
    129         ; esg - 6/25/02   SDD 5.1.2 - modifications to Expand Entry for IIV
    130         ; move source down one line, eIIV trace # to the left column and add
    131         ; eIIV processed date to the right column
    132         ;
    133         S IBLINE=$$TRACE(IBLINE,IBBUFDA)       ; eIIV trace #
    134         S IBL="eIIV Processed Date: ",IBY=$S($P(IB0,U,15)="":"",1:$$FMTE^XLFDT($P(IB0,U,15),"2M"))
    135         S IBLINE=$$SETL(IBLINE,IBY,IBL,62,17)
    136         D SET(IBLINE) S IBLINE=""
    137         S IBL="Source: ",IBY=$$EXPAND^IBTRE(355.33,.03,$P(IB0,U,3))
    138         S IBLINE=$$SETL("",IBY,IBL,18,17)
    139         D SET(IBLINE) S IBLINE=""
    140         ;
    141         ; Call another routine for continuation of list build
    142         D BLD^IBCNBLE1
    143         ;
    144 BLDQ    Q
    145         ;
    146         ;
    147 SETL(LINE,DATA,LABEL,COL,LNG)   ;
    148         S LINE=LINE_$J("",(COL-$L(LABEL)-$L(LINE)))_LABEL_$E(DATA,1,LNG)
    149         Q LINE
    150         ;
    151 SET(LINE,SPEC)  ;
    152         S VALMCNT=VALMCNT+1
    153         S ^TMP("IBCNBLE",$J,VALMCNT,0)=LINE
    154         I $G(SPEC)="B" D CNTRL^VALM10(VALMCNT,1,80,IOINHI,IOINORM)
    155         Q
    156         ;
    157 DATE(X) ;
    158         N Y S Y="" I X?7N.E S Y=$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3)
    159         Q Y
    160         ;
    161 YN(X)   ;
    162         N Y S X=$G(X),Y=$S(X=1:"Yes",X=0:"No",1:"")
    163         Q Y
    164         ;
    165 ADDR(NODE,FLD)  ; format address for output
    166         N IBY,IB0,IBCS,IBST,IBZIP,IBJ,IBZ,IBX K ADDR S ADDR(1)=""
    167         S IB0=$G(^IBA(355.33,IBBUFDA,NODE))
    168         S IBCS=$P(IB0,U,FLD+3),IBST=$P($G(^DIC(5,+$P(IB0,U,FLD+4),0)),U,2),IBZIP=$P(IB0,U,FLD+5)
    169         S IBZIP=$E(IBZIP,1,5)_$S($E(IBZIP,6,9)'="":"-"_$E(IBZIP,6,9),1:"")
    170         S IBST=IBST_$S(IBST=""!(IBZIP=""):"",1:"  ")_IBZIP
    171         S IBCS=IBCS_$S(IBCS=""!(IBST=""):"",1:", ")_IBST
    172         ;
    173         S IBJ=1 F IBY=$P(IB0,U,FLD),$P(IB0,U,(FLD+1)),$P(IB0,U,(FLD+2)),IBCS I IBY'="" S IBX=$G(ADDR(IBJ)),IBZ=", " D
    174         . S:IBX="" IBZ="" S:($L(IBX)+2+$L(IBY))>64 IBZ="",IBJ=IBJ+1
    175         . S ADDR(IBJ)=$G(ADDR(IBJ))_IBZ_IBY
    176         Q
    177         ;
    178 TRACE(IBLINE,IBBUFDA)   ; Add the eIIV Trace Number to the display
    179         NEW RESP,TRACENUM,IBL,IBY
    180         I '$G(IBBUFDA) G TRACEX
    181         S RESP=$O(^IBCN(365,"AF",IBBUFDA,""),-1)          ; response ien
    182         S TRACENUM=""
    183         I RESP S TRACENUM=$P($G(^IBCN(365,RESP,0)),U,9)   ; trace# field
    184         S IBL="eIIV Trace #: ",IBY=TRACENUM               ; field label/data
    185         S IBLINE=$$SETL("",IBY,IBL,18,17)             ; add it
    186 TRACEX  ;
    187         Q IBLINE
    188         ;
     1IBCNBLE ;ALB/ARH-Ins Buffer: LM buffer entry screen ;1 Jun 97
     2 ;;2.0;INTEGRATED BILLING;**82,231,184,251**;21-MAR-94
     3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
     4 ;
     5EN ; - main entry point for list manager display
     6 N DFN
     7 D EN^VALM("IBCNB INSURANCE BUFFER ENTRY")
     8 Q
     9 ;
     10HDR ; - header code for list manager display
     11 N IBX,IB0,VADM,VA,VAERR S IBX=""
     12 I +$G(DFN) D DEM^VADPT S IBX=$E(VADM(1),1,28),IBX=IBX_$J("",35-$L(IBX))_$P(VADM(2),U,2)_"    DOB: "_$P(VADM(3),U,2)_"    AGE: "_VADM(4)
     13 S VALMHDR(1)=IBX
     14 S IB0=$G(^IBA(355.33,+$G(IBBUFDA),0))
     15 S IBX=$E($P($G(^VA(200,+$P(IB0,U,2),0)),U,1),1,27)_" ("_$E($$EXPAND^IBTRE(355.33,.03,$P(IB0,U,3)),1,11)_")"
     16 S IBX="Buffer entry created on "_$$DATE(+IB0)_" by "_IBX,IBX=$J("",40-($L(IBX)\2))_IBX
     17 S VALMHDR(2)=IBX
     18 S IBX="" I +$P(IB0,U,10) S IBX="Buffer entry verified on "_$$DATE(+$P(IB0,U,10))_" by "_$E($P($G(^VA(200,+$P(IB0,U,11),0)),U,1),1,27),IBX=$J("",40-($L(IBX)\2))_IBX
     19 S VALMHDR(3)=IBX
     20 Q
     21 ;
     22INIT ; - initialization of list manager screen, ifn of record to display required IBBUFDA
     23 K ^TMP("IBCNBLE",$J)
     24 I '$G(IBBUFDA) S VALMQUIT="" Q
     25 S DFN=+$G(^IBA(355.33,IBBUFDA,60))
     26 D BLD
     27 Q
     28 ;
     29HELP ; - help text for list manager screen
     30 D FULL^VALM1
     31 W !!,"This screen displays all data in a Buffer File entry."
     32 W !!,"The actions allow editing of all data and verification of coverage."
     33 W !!,"It is not necessary to use the Verify Entry action, this action is optional.",!,"If the Verify Entry action is not used, the policy will be automatically flagged",!,"as verified when it is Accepted and stored in the main Insurance files."
     34 D PAUSE^VALM1 S VALMBCK="R"
     35 Q
     36 ;
     37EXIT ; - exit list manager screen
     38 K ^TMP("IBCNBLE",$J)
     39 D CLEAR^VALM1
     40 Q
     41 ;
     42BLD ; display buffer entry
     43 N IB0,IB20,IB40,IB60,IB61,IBL,IBLINE,ADDR,IBI,IBY
     44 S VALMCNT=0
     45 S IB0=$G(^IBA(355.33,IBBUFDA,0)),IB20=$G(^IBA(355.33,IBBUFDA,20)),IB40=$G(^IBA(355.33,IBBUFDA,40)),IB60=$G(^IBA(355.33,IBBUFDA,60)),IB61=$G(^IBA(355.33,IBBUFDA,61))
     46 ;
     47 D SET(" ") S IBY=$J("",26)_"Insurance Company Information" D SET(IBY,"B") S IBLINE=""
     48 S IBL="Name: ",IBY=$P(IB20,U,1) S IBLINE=$$SETL("",IBY,IBL,10,30)
     49 S IBL="Reimburse?: ",IBY=$$EXPAND^IBTRE(355.33,20.05,$P(IB20,U,5)) S IBLINE=$$SETL(IBLINE,IBY,IBL,57,20)
     50 D SET(IBLINE) S IBLINE=""
     51 S IBL="Phone: ",IBY=$P(IB20,U,2) S IBLINE=$$SETL(IBLINE,IBY,IBL,10,20)
     52 S IBL="Billing Phone: ",IBY=$P(IB20,U,3) S IBLINE=$$SETL(IBLINE,IBY,IBL,57,20)
     53 D SET(IBLINE) S IBLINE=""
     54 S IBL="Precert Phone: ",IBY=$P(IB20,U,4) S IBLINE=$$SETL(IBLINE,IBY,IBL,57,20)
     55 D SET(IBLINE) S IBLINE=""
     56 S IBL="Remote Query From: ",IBY=$$EXTERNAL^DILFD(355.33,.14,"",$P(IB0,"^",14)) S IBLINE=$$SETL(IBLINE,IBY,IBL,57,20)
     57 D SET(IBLINE) S IBLINE="" D ADDR(21,1)
     58 S IBL="Address: ",IBY=ADDR(1) S IBLINE=$$SETL(IBLINE,IBY,IBL,10,69)
     59 D SET(IBLINE) S IBLINE=""
     60 F IBI=2:1:9 S IBL="",IBY=$G(ADDR(IBI)) Q:IBY=""  S IBLINE=$$SETL(IBLINE,IBY,IBL,10,69) D SET(IBLINE) S IBLINE=""
     61 ;
     62 D SET(" ") S IBY=$J("",29)_"Group/Plan Information" D SET(IBY,"B") S IBLINE=""
     63 S IBL="Group Plan?: ",IBY=$$YN($P(IB40,U,1)) S IBLINE=$$SETL("",IBY,IBL,16,3)
     64 S IBL="Require UR: ",IBY=$$YN($P(IB40,U,4)) S IBLINE=$$SETL(IBLINE,IBY,IBL,63,3)
     65 D SET(IBLINE) S IBLINE=""
     66 S IBL="Group Name: ",IBY=$P(IB40,U,2) S IBLINE=$$SETL("",IBY,IBL,16,20)
     67 S IBL="Require Amb Cert: ",IBY=$$YN($P(IB40,U,6)) S IBLINE=$$SETL(IBLINE,IBY,IBL,63,3)
     68 D SET(IBLINE) S IBLINE=""
     69 S IBL="Group Number: ",IBY=$P(IB40,U,3) S IBLINE=$$SETL("",IBY,IBL,16,17)
     70 S IBL="Require Pre-Cert: ",IBY=$$YN($P(IB40,U,5)) S IBLINE=$$SETL(IBLINE,IBY,IBL,63,3)
     71 ;;Daou/EEN - Adding BIN and PCN
     72 D SET(IBLINE) S IBLINE=""
     73 S IBL="BIN: ",IBY=$P(IB40,U,10) S IBLINE=$$SETL("",IBY,IBL,16,10)
     74 D SET(IBLINE) S IBLINE=""
     75 S IBL="PCN: ",IBY=$P(IB40,U,11) S IBLINE=$$SETL("",IBY,IBL,16,20)
     76 D SET(IBLINE) S IBLINE=""
     77 S IBL="Type of Plan: ",IBY=$P($G(^IBE(355.1,+$P(IB40,U,9),0)),U,1) S IBLINE=$$SETL("",IBY,IBL,16,25)
     78 S IBL="Exclude Pre-Cond: ",IBY=$$YN($P(IB40,U,7)) S IBLINE=$$SETL(IBLINE,IBY,IBL,63,3)
     79 D SET(IBLINE) S IBLINE=""
     80 S IBL="Benefits Assignable: ",IBY=$$YN($P(IB40,U,8)) S IBLINE=$$SETL(IBLINE,IBY,IBL,63,3)
     81 D SET(IBLINE) S IBLINE=""
     82 ;
     83 D SET(" ") S IBY=$J("",26)_"Policy/Subscriber Information" D SET(IBY,"B") S IBLINE=""
     84 S IBL="Whose Insurance: ",IBY=$$EXPAND^IBTRE(355.33,60.05,$P(IB60,U,5)) S IBLINE=$$SETL("",IBY,IBL,18,7)
     85 S IBL="Effective: ",IBY=$$DATE($P(IB60,U,2)) S IBLINE=$$SETL(IBLINE,IBY,IBL,62,8)
     86 D SET(IBLINE) S IBLINE=""
     87 S IBL="Insured's Name: ",IBY=$P(IB60,U,7) S IBLINE=$$SETL("",IBY,IBL,18,30)
     88 S IBL="Expiration: ",IBY=$$DATE($P(IB60,U,3)) S IBLINE=$$SETL(IBLINE,IBY,IBL,62,13)
     89 D SET(IBLINE) S IBLINE=""
     90 S IBL="Subscriber Id: ",IBY=$P(IB60,U,4) S IBLINE=$$SETL("",IBY,IBL,18,20)
     91 S IBL="Primary Provider: ",IBY=$P(IB60,U,10) S IBLINE=$$SETL(IBLINE,IBY,IBL,62,17)
     92 D SET(IBLINE) S IBLINE=""
     93 S IBL="Relationship: ",IBY=$$EXPAND^IBTRE(355.33,60.06,$P(IB60,U,6)) S IBLINE=$$SETL("",IBY,IBL,18,16)
     94 S IBL="Provider Phone: ",IBY=$P(IB60,U,11) S IBLINE=$$SETL(IBLINE,IBY,IBL,62,16)
     95 D SET(IBLINE) S IBLINE=""
     96 I $P(IB60,U,6)'="01"!($P(IB60,U,8)'="") S IBL="Insured's DOB: ",IBY=$$DATE($P(IB60,U,8)) S IBLINE=$$SETL("",IBY,IBL,18,8)
     97 S IBL="Coord of Benefits: ",IBY=$$EXPAND^IBTRE(355.33,60.12,$P(IB60,U,12)) S IBLINE=$$SETL(IBLINE,IBY,IBL,62,16)
     98 D SET(IBLINE) S IBLINE=""
     99 I $P(IB60,U,6)'="01"!($P(IB60,U,9)'="") S IBL="Insured's SSN: ",IBY=$P(IB60,U,9) S IBLINE=$$SETL("",IBY,IBL,18,13)
     100 I IBLINE'="" D SET(IBLINE) S IBLINE=""
     101 ;
     102 I '$P(IB61,U,1) D SET(" ") S IBL="Employer Sponsored Group Health Plan?: ",IBY=$$YN($P(IB61,U,1)) S IBLINE=$$SETL("",IBY,IBL,40,3) D SET(IBLINE) S IBLINE="" G NXT
     103 ;
     104 D ADDR(61,6)
     105 D SET(" ") S IBY=$J("",24)_"Subscriber's Employer Information" D SET(IBY,"B") S IBLINE=""
     106 S IBL="Employer Sponsored?: ",IBY=$$YN($P(IB61,U,1)) S IBLINE=$$SETL("",IBY,IBL,22,3)
     107 S IBL="Employment Status: ",IBY=$$EXPAND^IBTRE(355.33,61.03,$P(IB61,U,3)) S IBLINE=$$SETL(IBLINE,IBY,IBL,64,15)
     108 D SET(IBLINE) S IBLINE=""
     109 S IBL="Claim to Employer: ",IBY=$$YN($P(IB61,U,5)) S IBLINE=$$SETL("",IBY,IBL,22,3)
     110 S IBL="Retirement Date: ",IBY=$$DATE($P(IB61,U,4)) S IBLINE=$$SETL(IBLINE,IBY,IBL,64,8)
     111 D SET(IBLINE) S IBLINE=""
     112 S IBL="Employer Name: ",IBY=$P(IB61,U,2) S IBLINE=$$SETL("",IBY,IBL,16,30)
     113 S IBL="Employer Phone: ",IBY=$P(IB61,U,12) S IBLINE=$$SETL(IBLINE,IBY,IBL,64,15)
     114 D SET(IBLINE) S IBLINE=""
     115 S IBL="Address: ",IBY=ADDR(1) S IBLINE=$$SETL(IBLINE,IBY,IBL,16,64)
     116 D SET(IBLINE) S IBLINE=""
     117 F IBI=2:1:9 S IBL="",IBY=$G(ADDR(IBI)) Q:IBY=""  S IBLINE=$$SETL(IBLINE,IBY,IBL,16,64) D SET(IBLINE) S IBLINE=""
     118 ;
     119NXT ;
     120 D SET(" ") S IBY=$J("",26)_"Buffer Entry Information" D SET(IBY,"B") S IBLINE=""
     121 S IBL="Date Entered: ",IBY=$$FMTE^XLFDT($P(IB0,U,1),2) S IBLINE=$$SETL("",IBY,IBL,18,17)
     122 S IBL="Date Verified: ",IBY=$$FMTE^XLFDT($P(IB0,U,10),2) S IBLINE=$$SETL(IBLINE,IBY,IBL,62,17)
     123 D SET(IBLINE) S IBLINE=""
     124 S IBL="Entered By: ",IBY=$$EXPAND^IBTRE(355.33,.02,$P(IB0,U,2)) S IBLINE=$$SETL("",IBY,IBL,18,40)
     125 S IBL="Verified By: ",IBY=$$EXPAND^IBTRE(355.33,.11,$P(IB0,U,11)) S IBLINE=$$SETL(IBLINE,IBY,IBL,62,17)
     126 D SET(IBLINE) S IBLINE=""
     127 ;
     128 ; esg - 6/25/02   SDD 5.1.2 - modifications to Expand Entry for IIV
     129 ; move source down one line, eIIV trace # to the left column and add
     130 ; eIIV processed date to the right column
     131 ;
     132 S IBLINE=$$TRACE(IBLINE,IBBUFDA)       ; eIIV trace #
     133 S IBL="eIIV Processed Date: ",IBY=$S($P(IB0,U,15)="":"",1:$$FMTE^XLFDT($P(IB0,U,15),"2M"))
     134 S IBLINE=$$SETL(IBLINE,IBY,IBL,62,17)
     135 D SET(IBLINE) S IBLINE=""
     136 S IBL="Source: ",IBY=$$EXPAND^IBTRE(355.33,.03,$P(IB0,U,3))
     137 S IBLINE=$$SETL("",IBY,IBL,18,17)
     138 D SET(IBLINE) S IBLINE=""
     139 ;
     140 ; Call another routine for continuation of list build
     141 D BLD^IBCNBLE1
     142 ;
     143BLDQ Q
     144 ;
     145 ;
     146SETL(LINE,DATA,LABEL,COL,LNG) ;
     147 S LINE=LINE_$J("",(COL-$L(LABEL)-$L(LINE)))_LABEL_$E(DATA,1,LNG)
     148 Q LINE
     149 ;
     150SET(LINE,SPEC) ;
     151 S VALMCNT=VALMCNT+1
     152 S ^TMP("IBCNBLE",$J,VALMCNT,0)=LINE
     153 I $G(SPEC)="B" D CNTRL^VALM10(VALMCNT,1,80,IOINHI,IOINORM)
     154 Q
     155 ;
     156DATE(X) ;
     157 N Y S Y="" I X?7N.E S Y=$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3)
     158 Q Y
     159 ;
     160YN(X) ;
     161 N Y S X=$G(X),Y=$S(X=1:"Yes",X=0:"No",1:"")
     162 Q Y
     163 ;
     164ADDR(NODE,FLD) ; format address for output
     165 N IBY,IB0,IBCS,IBST,IBZIP,IBJ,IBZ,IBX K ADDR S ADDR(1)=""
     166 S IB0=$G(^IBA(355.33,IBBUFDA,NODE))
     167 S IBCS=$P(IB0,U,FLD+3),IBST=$P($G(^DIC(5,+$P(IB0,U,FLD+4),0)),U,2),IBZIP=$P(IB0,U,FLD+5)
     168 S IBZIP=$E(IBZIP,1,5)_$S($E(IBZIP,6,9)'="":"-"_$E(IBZIP,6,9),1:"")
     169 S IBST=IBST_$S(IBST=""!(IBZIP=""):"",1:"  ")_IBZIP
     170 S IBCS=IBCS_$S(IBCS=""!(IBST=""):"",1:", ")_IBST
     171 ;
     172 S IBJ=1 F IBY=$P(IB0,U,FLD),$P(IB0,U,(FLD+1)),$P(IB0,U,(FLD+2)),IBCS I IBY'="" S IBX=$G(ADDR(IBJ)),IBZ=", " D
     173 . S:IBX="" IBZ="" S:($L(IBX)+2+$L(IBY))>64 IBZ="",IBJ=IBJ+1
     174 . S ADDR(IBJ)=$G(ADDR(IBJ))_IBZ_IBY
     175 Q
     176 ;
     177TRACE(IBLINE,IBBUFDA) ; Add the eIIV Trace Number to the display
     178 NEW RESP,TRACENUM,IBL,IBY
     179 I '$G(IBBUFDA) G TRACEX
     180 S RESP=$O(^IBCN(365,"AF",IBBUFDA,""),-1)          ; response ien
     181 S TRACENUM=""
     182 I RESP S TRACENUM=$P($G(^IBCN(365,RESP,0)),U,9)   ; trace# field
     183 S IBL="eIIV Trace #: ",IBY=TRACENUM               ; field label/data
     184 S IBLINE=$$SETL("",IBY,IBL,18,17)             ; add it
     185TRACEX ;
     186 Q IBLINE
     187 ;

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNBMI.m

    r613 r623  
    1 IBCNBMI ;ALB/ARH-Ins Buffer: move buffer data to insurance files ;09 Mar 2005  11:42 AM
    2         ;;2.0;INTEGRATED BILLING;**82,184,246,251,299,345,361,371**;21-MAR-94;Build 57
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5 INS(IBBUFDA,IBINSDA,TYPE)       ;  move buffer insurance company data (file 355.33) to existing Insurance Company (file 36)
    6         ;
    7         S IBBUFDA=IBBUFDA_",",IBINSDA=$G(IBINSDA)_","
    8         D SET("INS",IBBUFDA,IBINSDA,TYPE)
    9         Q
    10         ;
    11 GRP(IBBUFDA,IBGRPDA,TYPE)       ;  move buffer insurance group/plan data (file 355.33) to existing Group/Plan (file 355.33)
    12         ;
    13         S IBBUFDA=IBBUFDA_",",IBGRPDA=$G(IBGRPDA)_","
    14         D SET("GRP",IBBUFDA,IBGRPDA,TYPE)
    15         D STUFF("GRP",IBGRPDA)
    16         Q
    17         ;
    18 POLICY(IBBUFDA,IBPOLDA,TYPE)    ;  move buffer insurance policy data (file 355.33) to existing Patient Policy (file 2.312)
    19         ;
    20         N DFN S DFN=+$G(^IBA(355.33,+$G(IBBUFDA),60)) Q:'DFN
    21         ;
    22         S IBBUFDA=IBBUFDA_",",IBPOLDA=$G(IBPOLDA)_","_DFN_","
    23         D SET("POL",IBBUFDA,IBPOLDA,TYPE)
    24         D STUFF("POL",IBPOLDA)
    25         D POLOTH(IBBUFDA,IBPOLDA)
    26         Q
    27         ;
    28 SET(SET,IBBUFDA,IBEXTDA,TYPE)   ; move buffer data to insurance files
    29         ; Input:  IBBUFDA - ifn of Buffer File entry to move (#355.33)
    30         ;         IBEXTDA - ifn of insurance entry to update (#36,355.3,2)
    31         ;         TYPE    - 1 = Merge     (only buffer data moved to blank fields in ins file, no replace)
    32         ;                   2 = Overwrite (all buffer data moved to ins file, replace existing data)
    33         ;                   3 = Replace (all buffer data including null move to ins file)
    34         ;                   4 = Individually Accept (Skip Blanks) (user accepts
    35         ;  individual diffs b/w buffer data and existing file data (excl blanks)
    36         ;  to overwrite flds (or addr grp) in existing file)
    37         ;
    38         ;
    39         N IBX,IBFLDS,EXTFILE,DRBUF,DREXT,BUFARR,EXTARR,IBBUFFLD,IBEXTFLD,IBBUFVAL,IBEXTVAL,IBCHNG,IBCHNGN,IBERR
    40         ;
    41         D FIELDS(SET_"FLD")
    42         S IBX=$P($T(@(SET_"DR")+1),";;",2),EXTFILE=+$P(IBX,U,1),DRBUF=$P(IBX,U,2),DREXT=$P(IBX,U,3)
    43         ;
    44         D GETS^DIQ(355.33,IBBUFDA,DRBUF,"E","BUFARR")
    45         D GETS^DIQ(EXTFILE,IBEXTDA,DREXT,"E","EXTARR")
    46         ;
    47         I +$G(TYPE) S IBBUFFLD=0 F  S IBBUFFLD=$O(BUFARR(355.33,IBBUFDA,IBBUFFLD)) Q:'IBBUFFLD  D
    48         . S IBEXTFLD=$G(IBFLDS(IBBUFFLD)) Q:'IBEXTFLD
    49         . S IBBUFVAL=BUFARR(355.33,IBBUFDA,IBBUFFLD,"E")
    50         . S IBEXTVAL=$G(EXTARR(EXTFILE,IBEXTDA,IBEXTFLD,"E"))
    51         . ;
    52         . I IBBUFVAL=IBEXTVAL Q
    53         . I TYPE=1,IBEXTVAL'="" Q
    54         . I TYPE=2,IBBUFVAL="" Q
    55         . I TYPE=4,'$D(^TMP($J,"IB BUFFER SELECTED",IBBUFFLD)) Q
    56         . ;
    57         . S IBCHNG(EXTFILE,IBEXTDA,IBEXTFLD)=IBBUFVAL
    58         . S IBCHNGN(EXTFILE,IBEXTDA,IBEXTFLD)=""
    59         ;
    60         I $D(IBCHNGN)>9 D FILE^DIE("E","IBCHNGN","IBERR")
    61         I $D(IBCHNG)>9 D FILE^DIE("E","IBCHNG","IBERR")
    62         Q
    63         ;
    64 STUFF(SET,IBEXTDA)      ; update fields in insurance files that should be automatically set when an entry is edited
    65         ; Input:  IBEXTDA - ifn of insurance entry to update (#36,356,2)
    66         ;
    67         N IBX,IBFLDS,EXTFILE,IBEXTFLD,IBEXTVAL,IBCHNG,IBCHNGN,IBERR
    68         ;
    69         D FIELDS(SET_"A")
    70         S IBX=$P($T(@(SET_"DR")+1),";;",2),EXTFILE=+$P(IBX,U,1)
    71         ;
    72         S IBEXTFLD=0 F  S IBEXTFLD=$O(IBFLDS(IBEXTFLD)) Q:'IBEXTFLD  D
    73         . S IBEXTVAL=IBFLDS(IBEXTFLD) I IBEXTVAL="DUZ" S IBEXTVAL="`"_DUZ
    74         . S IBCHNG(EXTFILE,IBEXTDA,IBEXTFLD)=IBEXTVAL
    75         . S IBCHNGN(EXTFILE,IBEXTDA,IBEXTFLD)=""
    76         ;
    77         D FILE^DIE("E","IBCHNGN","IBERR")
    78         D FILE^DIE("E","IBCHNG","IBERR")
    79         Q
    80         ;
    81 FIELDS(SET)     ; return array of corresponding fields: IBFLDS(Buffer #)=Ins #
    82         N IBI,IBLN,IBB,IBE,IBG K IBFLDS,IBADDS,IBLBLS
    83         F IBI=1:1 S IBLN=$P($T(@(SET)+IBI),";;",2) Q:IBLN=""  I $E(IBLN,1)'=" " D
    84         . S IBB=$P(IBLN,U,1),IBE=$P(IBLN,U,2),IBG=$P(IBLN,U,4)
    85         . I IBB'="",IBE'="" D
    86         .. S IBFLDS(IBB)=IBE
    87         .. I SET["FLD" S IBLBLS(IBB)=$P(IBLN,U,3) I +IBG S IBADDS(IBB)=IBE
    88         Q
    89         ;
    90 INSDR   ;
    91         ;;36^20.02:20.04;21.01:21.06^.131;.132;.133;.111:.116
    92 INSFLD  ; corresponding fields:  Buffer File (355.33) and Insurance Company file (36)
    93         ;;20.02^.131^Phone Number^           ; MM Phone Number
    94         ;;20.03^.132^Billing Phone^          ; Billing Phone Number
    95         ;;20.04^.133^Pre-Cert Phone^         ; Pre-Certification Phone Number
    96         ;;21.01^.111^Street [Line 1]^1       ; MM Street Address [Line 1]
    97         ;;21.02^.112^Street [Line 2]^1       ; MM Street Address [Line 2]
    98         ;;21.03^.113^Street [Line 3]^1       ; MM Street Address [Line 3]
    99         ;;21.04^.114^City^1                  ; MM City
    100         ;;21.05^.115^State^1                 ; MM State
    101         ;;21.06^.116^Zip^1                   ; MM Zip Code
    102         ;
    103 GRPDR   ;
    104         ;;355.3^40.02:40.03;40.1;40.11;40.04:40.09;^.03:.04;6.02;6.03;.05:.09;.12
    105 GRPFLD  ;corresponding fields:  Buffer File (355.33) and Insurance Group Plan file (355.3)
    106         ;;40.02^.03^Group Name^              ; Group Name
    107         ;;40.03^.04^Group Number^            ; Group Number
    108         ;;40.1^6.02^BIN^                     ; BIN ;;Daou/EEN
    109         ;;40.11^6.03^PCN^                    ; PCN ;;Daou/EEN
    110         ;;40.04^.05^Require UR^              ; Utilization Review Required
    111         ;;40.05^.06^Require Pre-Cert^        ; Pre-Certification Required
    112         ;;40.06^.12^Require Amb Cert^        ; Ambulatory Care Certification
    113         ;;40.07^.07^Exclude Pre-Cond^        ; Exclude Pre-Existing Conditions
    114         ;;40.08^.08^Benefits Assign^         ; Benefits Assignable
    115         ;;40.09^.09^Type of Plan^            ; Type of Plan
    116         ;
    117 GRPA    ; auto set fields
    118         ;;1.05^NOW^                          ; Date Last Edited
    119         ;;1.06^DUZ^                          ; Last edited By
    120         ;
    121 POLDR   ;
    122         ;;2.312^60.02:62.01^8;3;1;6;16;17;3.01;3.05;4.01;4.02;.2;3.12;2.1;2.015;2.11;2.12;2.01:2.08;5.01
    123 POLFLD  ; corresponding fields:  Buffer File (355.33) and Insurance Patient Policy file (2.312)
    124         ;;60.02^8^Effective Date^            ; Effective Date
    125         ;;60.03^3^Expiration Date^           ; Expiration Date
    126         ;;60.04^1^Subscriber Id^             ; Subscriber Id
    127         ;;60.05^6^Whose Insurance^           ; Whose Insurance
    128         ;;60.06^16^Relationship^             ; Pt. Relationship to Insured
    129         ;;60.07^17^Name of Insured^          ; Name of Insured
    130         ;;60.08^3.01^Insured's DOB^          ; Insured's DOB
    131         ;;60.09^3.05^Insured's SSN^          ; Insured's SSN
    132         ;;60.1^4.01^Primary Provider^        ; Primary Care Provider
    133         ;;60.11^4.02^Provider Phone^         ; Primary Care Provider Phone
    134         ;;60.12^.2^Coor of Benefits^         ; Coordination of Benefits
    135         ;;60.13^3.12^Insured's Sex^          ; Insured's Sex
    136         ;; 
    137         ;;61.01^2.1^Emp Sponsored^           ; ESGHP?
    138         ;;61.02^2.015^Employer Name^         ; Subscriber's Employer Name
    139         ;;61.03^2.11^Emp Status^             ; Employment Status
    140         ;;61.04^2.12^Retirement Date^        ; Retirement Date
    141         ;;61.05^2.01^Send to Employer^       ; Send Bill to Employer?
    142         ;;61.06^2.02^Emp Street Ln 1^1       ; Employer Claims Street Line 1
    143         ;;61.07^2.03^Emp Street Ln 2^1       ; Employer Claims Street Line 2
    144         ;;61.08^2.04^Emp Street Ln 3^1       ; Employer Claims Street Line 3
    145         ;;61.09^2.05^Emp City^1              ; Employer Claims City
    146         ;;61.1^2.06^Emp State^1              ; Employer Claims State
    147         ;;61.11^2.07^Emp Zip Code^1          ; Employer Claims Zip Code
    148         ;;61.12^2.08^Emp Phone^              ; Employer Claims Phone
    149         ;;62.01^5.01^Patient Id^             ; Patient Id
    150         ;
    151 POLA    ; auto set fields
    152         ;;1.03^NOW^                          ; Date Last Verified (default is person that accepts entry)
    153         ;;1.04^DUZ^                          ; Verified By        (default is person that accepts entry)
    154         ;;1.05^NOW^                          ; Date Last Edited
    155         ;;1.06^DUZ^                          ; Last Edited By
    156         ;
    157         ;
    158 POLOTH(IBBUFDA,IBPOLDA) ; other special cases that can not be transferred using the generic code above, usually because of dependencies
    159         N IB0 S IB0=$G(^IBA(355.33,+IBBUFDA,0))
    160         ;
    161         ;  --- if buffer entry was verified before the accept step, then add the correct verifier info to the policy
    162         I +$P(IB0,U,10) D
    163         . S IBCHNG(2.312,IBPOLDA,1.03)=$E($P(IB0,U,10),1,12),IBCHNGN(2.312,IBPOLDA,1.03)=""
    164         . S IBCHNG(2.312,IBPOLDA,1.04)=$P(IB0,U,11),IBCHNGN(2.312,IBPOLDA,1.04)=""
    165         ;
    166         I $D(IBCHNGN)>9 D FILE^DIE("I","IBCHNGN","IBERR")
    167         I $D(IBCHNG)>9 D FILE^DIE("I","IBCHNG","IBERR")
    168         Q
    169         ;
    170 PAT(DFN,IBPOLDA)        ; Force DOB, SSN & SEX from Patient file (#2) in to Insurance Patient Policy file (2.312)
    171         N DA,DR,DIE,DOB,SSN,SEX,IENS,WI
    172         S IENS=IBPOLDA_","_DFN_","
    173         S WI=$$GET1^DIQ(2.312,IENS,6,"I")
    174         I WI'="v" Q  ; Only use when Whose Insurance is 'v'
    175         S DOB=$$GET1^DIQ(2,DFN,.03,"I")
    176         S SSN=$$GET1^DIQ(2,DFN,.09,"I")
    177         S SEX=$$GET1^DIQ(2,DFN,.02,"I")
    178         S DIE="^DPT("_DFN_",.312,",DA(1)=DFN,DA=IBPOLDA
    179         S DR="3.01///^S X=DOB;3.05///^S X=SSN;3.12///^S X=SEX"
    180         D ^DIE
    181         Q
     1IBCNBMI ;ALB/ARH-Ins Buffer: move buffer data to insurance files ; 09 Mar 2005  11:42 AM
     2 ;;2.0;INTEGRATED BILLING;**82,184,246,251,299,345,361**;21-MAR-94;Build 9
     3 ;;Per VHA Directive 2004-038, this routine should not be modified.
     4 ;
     5INS(IBBUFDA,IBINSDA,TYPE) ;  move buffer insurance company data (file 355.33) to existing Insurance Company (file 36)
     6 ;
     7 S IBBUFDA=IBBUFDA_",",IBINSDA=$G(IBINSDA)_","
     8 D SET("INS",IBBUFDA,IBINSDA,TYPE)
     9 Q
     10 ;
     11GRP(IBBUFDA,IBGRPDA,TYPE) ;  move buffer insurance group/plan data (file 355.33) to existing Group/Plan (file 355.33)
     12 ;
     13 S IBBUFDA=IBBUFDA_",",IBGRPDA=$G(IBGRPDA)_","
     14 D SET("GRP",IBBUFDA,IBGRPDA,TYPE)
     15 D STUFF("GRP",IBGRPDA)
     16 Q
     17 ;
     18POLICY(IBBUFDA,IBPOLDA,TYPE) ;  move buffer insurance policy data (file 355.33) to existing Patient Policy (file 2.312)
     19 ;
     20 N DFN S DFN=+$G(^IBA(355.33,+$G(IBBUFDA),60)) Q:'DFN
     21 ;
     22 S IBBUFDA=IBBUFDA_",",IBPOLDA=$G(IBPOLDA)_","_DFN_","
     23 D SET("POL",IBBUFDA,IBPOLDA,TYPE)
     24 D STUFF("POL",IBPOLDA)
     25 D POLOTH(IBBUFDA,IBPOLDA)
     26 Q
     27 ;
     28SET(SET,IBBUFDA,IBEXTDA,TYPE) ; move buffer data to insurance files
     29 ; Input:  IBBUFDA - ifn of Buffer File entry to move (#355.33)
     30 ;         IBEXTDA - ifn of insurance entry to update (#36,355.3,2)
     31 ;         TYPE    - 1 = Merge     (only buffer data moved to blank fields in ins file, no replace)
     32 ;                   2 = Overwrite (all buffer data moved to ins file, replace existing data)
     33 ;                   3 = Replace (all buffer data including null move to ins file)
     34 ;                   4 = Individually Accept (Skip Blanks) (user accepts
     35 ;  individual diffs b/w buffer data and existing file data (excl blanks)
     36 ;  to overwrite flds (or addr grp) in existing file)
     37 ;
     38 ;
     39 N IBX,IBFLDS,EXTFILE,DRBUF,DREXT,BUFARR,EXTARR,IBBUFFLD,IBEXTFLD,IBBUFVAL,IBEXTVAL,IBCHNG,IBCHNGN,IBERR
     40 ;
     41 D FIELDS(SET_"FLD")
     42 S IBX=$P($T(@(SET_"DR")+1),";;",2),EXTFILE=+$P(IBX,U,1),DRBUF=$P(IBX,U,2),DREXT=$P(IBX,U,3)
     43 ;
     44 D GETS^DIQ(355.33,IBBUFDA,DRBUF,"E","BUFARR")
     45 D GETS^DIQ(EXTFILE,IBEXTDA,DREXT,"E","EXTARR")
     46 ;
     47 I +$G(TYPE) S IBBUFFLD=0 F  S IBBUFFLD=$O(BUFARR(355.33,IBBUFDA,IBBUFFLD)) Q:'IBBUFFLD  D
     48 . S IBEXTFLD=$G(IBFLDS(IBBUFFLD)) Q:'IBEXTFLD
     49 . S IBBUFVAL=BUFARR(355.33,IBBUFDA,IBBUFFLD,"E")
     50 . S IBEXTVAL=$G(EXTARR(EXTFILE,IBEXTDA,IBEXTFLD,"E"))
     51 . ;
     52 . I IBBUFVAL=IBEXTVAL Q
     53 . I TYPE=1,IBEXTVAL'="" Q
     54 . I TYPE=2,IBBUFVAL="" Q
     55 . I TYPE=4,'$D(^TMP($J,"IB BUFFER SELECTED",IBBUFFLD)) Q
     56 . ;
     57 . S IBCHNG(EXTFILE,IBEXTDA,IBEXTFLD)=IBBUFVAL
     58 . S IBCHNGN(EXTFILE,IBEXTDA,IBEXTFLD)=""
     59 ;
     60 I $D(IBCHNGN)>9 D FILE^DIE("E","IBCHNGN","IBERR")
     61 I $D(IBCHNG)>9 D FILE^DIE("E","IBCHNG","IBERR")
     62 Q
     63 ;
     64STUFF(SET,IBEXTDA) ; update fields in insurance files that should be automatically set when an entry is edited
     65 ; Input:  IBEXTDA - ifn of insurance entry to update (#36,356,2)
     66 ;
     67 N IBX,IBFLDS,EXTFILE,IBEXTFLD,IBEXTVAL,IBCHNG,IBCHNGN,IBERR
     68 ;
     69 D FIELDS(SET_"A")
     70 S IBX=$P($T(@(SET_"DR")+1),";;",2),EXTFILE=+$P(IBX,U,1)
     71 ;
     72 S IBEXTFLD=0 F  S IBEXTFLD=$O(IBFLDS(IBEXTFLD)) Q:'IBEXTFLD  D
     73 . S IBEXTVAL=IBFLDS(IBEXTFLD) I IBEXTVAL="DUZ" S IBEXTVAL="`"_DUZ
     74 . S IBCHNG(EXTFILE,IBEXTDA,IBEXTFLD)=IBEXTVAL
     75 . S IBCHNGN(EXTFILE,IBEXTDA,IBEXTFLD)=""
     76 ;
     77 D FILE^DIE("E","IBCHNGN","IBERR")
     78 D FILE^DIE("E","IBCHNG","IBERR")
     79 Q
     80 ;
     81FIELDS(SET) ; return array of corresponding fields: IBFLDS(Buffer #)=Ins #
     82 N IBI,IBLN,IBB,IBE,IBG K IBFLDS,IBADDS,IBLBLS
     83 F IBI=1:1 S IBLN=$P($T(@(SET)+IBI),";;",2) Q:IBLN=""  I $E(IBLN,1)'=" " D
     84 . S IBB=$P(IBLN,U,1),IBE=$P(IBLN,U,2),IBG=$P(IBLN,U,4)
     85 . I IBB'="",IBE'="" D
     86 .. S IBFLDS(IBB)=IBE
     87 .. I SET["FLD" S IBLBLS(IBB)=$P(IBLN,U,3) I +IBG S IBADDS(IBB)=IBE
     88 Q
     89 ;
     90INSDR ;
     91 ;;36^20.02:20.04;21.01:21.06^.131;.132;.133;.111:.116
     92INSFLD ; corresponding fields:  Buffer File (355.33) and Insurance Company file (36)
     93 ;;20.02^.131^Phone Number^           ; MM Phone Number
     94 ;;20.03^.132^Billing Phone^          ; Billing Phone Number
     95 ;;20.04^.133^Pre-Cert Phone^         ; Pre-Certification Phone Number
     96 ;;21.01^.111^Street [Line 1]^1       ; MM Street Address [Line 1]
     97 ;;21.02^.112^Street [Line 2]^1       ; MM Street Address [Line 2]
     98 ;;21.03^.113^Street [Line 3]^1       ; MM Street Address [Line 3]
     99 ;;21.04^.114^City^1                  ; MM City
     100 ;;21.05^.115^State^1                 ; MM State
     101 ;;21.06^.116^Zip^1                   ; MM Zip Code
     102 ;
     103GRPDR ;
     104 ;;355.3^40.02:40.03;40.1;40.11;40.04:40.09;^.03:.04;6.02;6.03;.05:.09;.12
     105GRPFLD ;corresponding fields:  Buffer File (355.33) and Insurance Group Plan file (355.3)
     106 ;;40.02^.03^Group Name^              ; Group Name
     107 ;;40.03^.04^Group Number^            ; Group Number
     108 ;;40.1^6.02^BIN^                     ; BIN ;;Daou/EEN
     109 ;;40.11^6.03^PCN^                    ; PCN ;;Daou/EEN
     110 ;;40.04^.05^Require UR^              ; Utilization Review Required
     111 ;;40.05^.06^Require Pre-Cert^        ; Pre-Certification Required
     112 ;;40.06^.12^Require Amb Cert^        ; Ambulatory Care Certification
     113 ;;40.07^.07^Exclude Pre-Cond^        ; Exclude Pre-Existing Conditions
     114 ;;40.08^.08^Benefits Assign^         ; Benefits Assignable
     115 ;;40.09^.09^Type of Plan^            ; Type of Plan
     116 ;
     117GRPA ; auto set fields
     118 ;;1.05^NOW^                          ; Date Last Edited
     119 ;;1.06^DUZ^                          ; Last edited By
     120 ;
     121POLDR ;
     122 ;;2.312^60.02:61.12^8;3;1;6;16;17;3.01;3.05;4.01;4.02;.2;3.12;2.1;2.015;2.11;2.12;2.01:2.08
     123POLFLD ; corresponding fields:  Buffer File (355.33) and Insurance Patient Policy file (2.312)
     124 ;;60.02^8^Effective Date^            ; Effective Date
     125 ;;60.03^3^Expiration Date^           ; Expiration Date
     126 ;;60.04^1^Subscriber Id^             ; Subscriber Id
     127 ;;60.05^6^Whose Insurance^           ; Whose Insurance
     128 ;;60.06^16^Relationship^             ; Pt. Relationship to Insured
     129 ;;60.07^17^Name of Insured^          ; Name of Insured
     130 ;;60.08^3.01^Insured's DOB^          ; Insured's DOB
     131 ;;60.09^3.05^Insured's SSN^          ; Insured's SSN
     132 ;;60.1^4.01^Primary Provider^        ; Primary Care Provider
     133 ;;60.11^4.02^Provider Phone^         ; Primary Care Provider Phone
     134 ;;60.12^.2^Coor of Benefits^         ; Coordination of Benefits
     135 ;;60.13^3.12^Insured's Sex^          ; Insured's Sex
     136 ;; 
     137 ;;61.01^2.1^Emp Sponsored^           ; ESGHP?
     138 ;;61.02^2.015^Employer Name^         ; Subscriber's Employer Name
     139 ;;61.03^2.11^Emp Status^             ; Employment Status
     140 ;;61.04^2.12^Retirement Date^        ; Retirement Date
     141 ;;61.05^2.01^Send to Employer^       ; Send Bill to Employer?
     142 ;;61.06^2.02^Emp Street Ln 1^1       ; Employer Claims Street Line 1
     143 ;;61.07^2.03^Emp Street Ln 2^1       ; Employer Claims Street Line 2
     144 ;;61.08^2.04^Emp Street Ln 3^1       ; Employer Claims Street Line 3
     145 ;;61.09^2.05^Emp City^1              ; Employer Claims City
     146 ;;61.1^2.06^Emp State^1              ; Employer Claims State
     147 ;;61.11^2.07^Emp Zip Code^1          ; Employer Claims Zip Code
     148 ;;61.12^2.08^Emp Phone^              ; Employer Claims Phone
     149 ;
     150POLA ; auto set fields
     151 ;;1.03^NOW^                          ; Date Last Verified (default is person that accepts entry)
     152 ;;1.04^DUZ^                          ; Verified By        (default is person that accepts entry)
     153 ;;1.05^NOW^                          ; Date Last Edited
     154 ;;1.06^DUZ^                          ; Last Edited By
     155 ;
     156 ;
     157POLOTH(IBBUFDA,IBPOLDA) ; other special cases that can not be transferred using the generic code above, usually because of dependencies
     158 N IB0 S IB0=$G(^IBA(355.33,+IBBUFDA,0))
     159 ;
     160 ;  --- if buffer entry was verified before the accept step, then add the correct verifier info to the policy
     161 I +$P(IB0,U,10) D
     162 . S IBCHNG(2.312,IBPOLDA,1.03)=$E($P(IB0,U,10),1,12),IBCHNGN(2.312,IBPOLDA,1.03)=""
     163 . S IBCHNG(2.312,IBPOLDA,1.04)=$P(IB0,U,11),IBCHNGN(2.312,IBPOLDA,1.04)=""
     164 ;
     165 I $D(IBCHNGN)>9 D FILE^DIE("I","IBCHNGN","IBERR")
     166 I $D(IBCHNG)>9 D FILE^DIE("I","IBCHNG","IBERR")
     167 Q
     168 ;
     169PAT(DFN,IBPOLDA) ; Force DOB, SSN & SEX from Patient file (#2) in to Insurance Patient Policy file (2.312)
     170 N DA,DR,DIE,DOB,SSN,SEX,IENS,WI
     171 S IENS=IBPOLDA_","_DFN_","
     172 S WI=$$GET1^DIQ(2.312,IENS,6,"I")
     173 I WI'="v" Q  ; Only use when Whose Insurance is 'v'
     174 S DOB=$$GET1^DIQ(2,DFN,.03,"I")
     175 S SSN=$$GET1^DIQ(2,DFN,.09,"I")
     176 S SEX=$$GET1^DIQ(2,DFN,.02,"I")
     177 S DIE="^DPT("_DFN_",.312,",DA(1)=DFN,DA=IBPOLDA
     178 S DR="3.01///^S X=DOB;3.05///^S X=SSN;3.12///^S X=SEX"
     179 D ^DIE
     180 Q

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNEBF.m

    r613 r623  
    1 IBCNEBF ;DAOU/ALA - Create an Entry in the Buffer File ;20-JUN-2002
    2         ;;2.0;INTEGRATED BILLING;**184,271,361,371**;21-MAR-94;Build 57
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5         ;**Program Description**
    6         ;  This program will create a Buffer entry based upon input values
    7         ;
    8         Q
    9         ;
    10 PT(DFN,IRIEN,SYMBOL,OVRRIDE,ADD,IBERROR)        ;  Get data
    11         ;   from a specific patient and insurance record entry
    12         ;
    13         ;  Input Parameters
    14         ;    DFN = Patient IEN
    15         ;    IRIEN = Patient Insurance Record IEN
    16         ;    SYMBOL = IIV Symbol IEN
    17         ;    OVRRIDE = Override flag for ins. buffer record  (0 or 1)
    18         ;    ADD = If defined, then it will add a new Buffer entry
    19         ;    IBERROR = If defined, then it will be updated with error info.
    20         ;              OPTIONALLY PASSED BY REFERENCE
    21         ;
    22         I DFN=""!(IRIEN="") Q   ; * do not require SYMBOL or OVRRIDE
    23         ;
    24         ;
    25         NEW VBUF,IEN,INAME,PNAME,IIEN,GNUMB,GNAME,SUBID,PPHONE,PATID
    26         NEW BPHONE,EFFDT,EXPDT,WHO,REL,IDOB,ISSN,COB,TQIEN,RDATA,ISEX,NAME
    27         NEW MSG,XMSUB,MSGP,INSDATA,PCE,BFD,BFN,INSPCE,ESGHPARR
    28         ;
    29         S IIEN=$P($G(^DPT(DFN,.312,IRIEN,0)),U,1)
    30         S INAME=$$GET1^DIQ(36,IIEN,.01,"E")
    31         S PPHONE=$P($G(^DIC(36,IIEN,.13)),U,3)
    32         S BPHONE=$P($G(^DIC(36,IIEN,.13)),U,2)
    33         S NAME=$P($G(^DPT(DFN,.312,IRIEN,0)),U,17)
    34         S SUBID=$P($G(^DPT(DFN,.312,IRIEN,0)),U,2)
    35         S PATID=$P($G(^DPT(DFN,.312,IRIEN,5)),U,1)
    36         S WHO=$P($G(^DPT(DFN,.312,IRIEN,0)),U,6)
    37         S COB=$P($G(^DPT(DFN,.312,IRIEN,0)),U,20)
    38         S IDOB=$P($G(^DPT(DFN,.312,IRIEN,3)),U,1)
    39         S ISSN=$P($G(^DPT(DFN,.312,IRIEN,3)),U,5)
    40         S ISEX=$P($G(^DPT(DFN,.312,IRIEN,3)),U,12)
    41         S EFFDT=$P(^DPT(DFN,.312,IRIEN,0),U,8)
    42         S EXPDT=$P(^DPT(DFN,.312,IRIEN,0),U,4)
    43         S REL=$P(^DPT(DFN,.312,IRIEN,0),U,16)
    44         ;
    45         S IENS=IRIEN_","_DFN_","
    46         S GNUMB=$$GET1^DIQ(2.312,IENS,21,"E")
    47         S GNAME=$$GET1^DIQ(2.312,IENS,20,"E")
    48         ;
    49         ; Capture the employer sponsored insurance fields into array
    50         ;   ESGHPARR(buffer field number) = data
    51         ;
    52         S INSDATA=$G(^DPT(DFN,.312,IRIEN,2)),PCE=0
    53         F BFD=5:1:12,2,1,3,4 S PCE=PCE+1,BFN=BFD/100+61,INSPCE=$P(INSDATA,U,PCE) I INSPCE'="" S ESGHPARR(BFN)=INSPCE
    54         ;
    55         D FIL
    56         K ADD
    57         Q
    58         ;
    59 RP(IEN,ADD,BUFF)        ;  Get data from a specific response record
    60         ;
    61         ;  Input Parameter
    62         ;    IEN  = Internal entry number of the Response
    63         ;    ADD  = If defined, then it will add a new Buffer entry
    64         ;    BUFF = IEN of the Buffer Entry to be updated (optional)
    65         ;
    66         S BUFF=$G(BUFF) ; Initialize optional parameter
    67         ;
    68         NEW PIEN,RSTYPE
    69         S DFN=$P(^IBCN(365,IEN,0),U,2),TQIEN=$P(^IBCN(365,IEN,0),U,5)
    70         S PIEN=$P(^IBCN(365,IEN,0),U,3),RSTYPE=$P(^(0),U,10)
    71         I PIEN'="" S PNAME=$P(^IBE(365.12,PIEN,0),U,1)
    72         I TQIEN'="" S IRIEN=$P($G(^IBCN(365.1,TQIEN,0)),U,13)
    73         I $G(IRIEN)'="" S INAME="" D
    74         . S IIEN=$P($G(^DPT(DFN,.312,IRIEN,0)),U,1)
    75         . I IIEN="" Q
    76         . S INAME=$P(^DIC(36,IIEN,0),U,1)
    77         S RDATA=$G(^IBCN(365,IEN,1))
    78         S NAME=$P(RDATA,U,1)
    79         S INAME=$S($G(INAME)'=""&(RSTYPE="O"):INAME,1:$G(PNAME))
    80         S IDOB=$P(RDATA,U,2)
    81         S ISSN=$P(RDATA,U,3)
    82         S ISEX=$P(RDATA,U,4)
    83         S COB=$P(RDATA,U,13)
    84         S SUBID=$P(RDATA,U,5)
    85         S PATID=$P(RDATA,U,18)
    86         S GNAME=$P(RDATA,U,6)
    87         S GNUMB=$P(RDATA,U,7)
    88         S WHO=$P(RDATA,U,8)
    89         S REL=$P(RDATA,U,9)
    90         S EFFDT=$P(RDATA,U,11)
    91         S EXPDT=$P(RDATA,U,12)
    92         S PPHONE="",BPHONE=""
    93         ;
    94         D FIL
    95         K DFN,VBUF,IEN,IRIEN,INAME,PNAME,IIEN,GNUMB,GNAME,SUBID,PPHONE,PATID
    96         K BPHONE,EFFDT,EXPDT,WHO,REL,IDOB,ISSN,COB,TQIEN,RDATA,ISEX,NAME
    97         K ADD,%DT,D0,DG,DIC,DISYS,DIW,IENS
    98         Q
    99         ;
    100 FIL     ;  File Buffer Data
    101         ;
    102         S MSGP=$$MGRP^IBCNEUT5()
    103         ;
    104         ; Variable IDUZ is optionally set by the calling routine.  If it is
    105         ; not defined, it will be set to the specific, non-human user.
    106         ;
    107         I $G(IDUZ)="" S IDUZ=$$FIND1^DIC(200,"","X","INTERFACE,IB IIV")
    108         ;
    109         I $G(ADD) S VBUF(.02)=IDUZ  ; Entered By
    110         S VBUF(.12)=$G(SYMBOL)   ; Buffer Symbol
    111         S VBUF(.13)=$G(OVRRIDE) ; Override freshness flag
    112         I '$G(ERACT) D  ; Only file if not an error
    113         . S VBUF(20.01)=INAME  ; Insurance Company/Payer Name
    114         . S VBUF(60.01)=DFN  ; Patient IEN
    115         . S VBUF(40.03)=GNUMB  ; Group Number
    116         . S VBUF(40.02)=GNAME  ; Group Name
    117         . S VBUF(60.07)=NAME  ; Name of Insured
    118         . S VBUF(60.04)=SUBID  ; Subscriber ID
    119         . S VBUF(62.01)=PATID  ; Patient/Member ID
    120         . S VBUF(20.04)=PPHONE  ; Precertification Phone
    121         . S VBUF(20.03)=BPHONE  ; Billing Phone
    122         . S VBUF(60.02)=EFFDT  ; Effective Date
    123         . S VBUF(60.03)=EXPDT  ; Expiration Date
    124         . S VBUF(60.05)=WHO  ; Whose Insurance
    125         . S VBUF(60.06)=REL  ;  Patient Relationship
    126         . S VBUF(60.08)=IDOB  ;  Insured's DOB
    127         . S VBUF(60.09)=ISSN  ;  Insured's SSN
    128         . S VBUF(60.12)=COB  ;  Coordination of Benefits
    129         . S VBUF(60.13)=ISEX  ;  Insured's Sex
    130         . ;
    131         . ; If the employer sponsored insurance array exists, then merge it in
    132         . I $D(ESGHPARR) M VBUF=ESGHPARR
    133         ;
    134         ; Do not overwrite the existing insurance co. name if it already exists
    135         I $G(ADD)="",$G(BUFF)'="" K VBUF(20.01)
    136         ;
    137         ; ** initialize IBERROR
    138         S IBERROR=""
    139         ;
    140         ;  If need to add a new Buffer entry ...
    141         ;
    142         ;  Variable IBFDA is returned to the calling routine as the IEN of
    143         ;  the buffer entry that was just added.
    144         ;
    145         I $G(ADD) D
    146         . S IBFDA=$$ADDSTF^IBCNBES(5,DFN,.VBUF)
    147         . ; Error Message is 2nd piece of result
    148         . S IBERROR=$P(IBFDA,U,2)
    149         . S IBFDA=$P(IBFDA,U,1)
    150         ;
    151         ;  If an error, send an email message
    152         I IBERROR'="" D  Q
    153         . S MSG(1)="Error returned by $$ADDSTF^IBCNBES:"
    154         . S MSG(2)=IBERROR
    155         . S MSG(3)="Values:"
    156         . S MSG(4)=" Patient DFN = "_$G(DFN)
    157         . S MSG(5)=" Pt Ins Record IEN = "_$G(IRIEN)
    158         . S MSG(6)="Please log a Remedy Ticket for this problem."
    159         . S XMSUB="Error creating Buffer Entry."
    160         . D MSG^IBCNEUT5(MSGP,XMSUB,"MSG(")
    161         . K MSGP,MSG,XMSUB,IBERR
    162         ;
    163         ;  If need to update a new Buffer Entry ...
    164         ;
    165         ;  Variable BUFF is passed into this routine whenever the buffer
    166         ;  entry is known and the ADD flag is off.  The existing buffer entry
    167         ;  is edited in this case.
    168         ;
    169         I $G(ADD)="" D EDITSTF^IBCNBES(BUFF,.VBUF)
    170         ;
    171         ;  If an error occurred in EDITSTF, the error array is not returned
    172         ;
    173         Q
     1IBCNEBF ;DAOU/ALA - Create an Entry in the Buffer File ;20-JUN-2002
     2 ;;2.0;INTEGRATED BILLING;**184,271,361**;21-MAR-94;Build 9
     3 ;;Per VHA Directive 2004-038, this routine should not be modified.
     4 ;
     5 ;**Program Description**
     6 ;  This program will create a Buffer entry based upon input values
     7 ;
     8 Q
     9 ;
     10PT(DFN,IRIEN,SYMBOL,OVRRIDE,ADD,IBERROR) ;  Get data
     11 ;   from a specific patient and insurance record entry
     12 ;
     13 ;  Input Parameters
     14 ;    DFN = Patient IEN
     15 ;    IRIEN = Patient Insurance Record IEN
     16 ;    SYMBOL = IIV Symbol IEN
     17 ;    OVRRIDE = Override flag for ins. buffer record  (0 or 1)
     18 ;    ADD = If defined, then it will add a new Buffer entry
     19 ;    IBERROR = If defined, then it will be updated with error info.
     20 ;              OPTIONALLY PASSED BY REFERENCE
     21 ;
     22 I DFN=""!(IRIEN="") Q   ; * do not require SYMBOL or OVRRIDE
     23 ;
     24 ;
     25 NEW VBUF,IEN,INAME,PNAME,IIEN,GNUMB,GNAME,SUBID,PPHONE
     26 NEW BPHONE,EFFDT,EXPDT,WHO,REL,IDOB,ISSN,COB,TQIEN,RDATA,ISEX,NAME
     27 NEW MSG,XMSUB,MSGP,INSDATA,PCE,BFD,BFN,INSPCE,ESGHPARR
     28 ;
     29 S IIEN=$P($G(^DPT(DFN,.312,IRIEN,0)),U,1)
     30 S INAME=$$GET1^DIQ(36,IIEN,.01,"E")
     31 S PPHONE=$P($G(^DIC(36,IIEN,.13)),U,3)
     32 S BPHONE=$P($G(^DIC(36,IIEN,.13)),U,2)
     33 S NAME=$P($G(^DPT(DFN,.312,IRIEN,0)),U,17)
     34 S SUBID=$P($G(^DPT(DFN,.312,IRIEN,0)),U,2)
     35 S WHO=$P($G(^DPT(DFN,.312,IRIEN,0)),U,6)
     36 S COB=$P($G(^DPT(DFN,.312,IRIEN,0)),U,20)
     37 S IDOB=$P($G(^DPT(DFN,.312,IRIEN,3)),U,1)
     38 S ISSN=$P($G(^DPT(DFN,.312,IRIEN,3)),U,5)
     39 S ISEX=$P($G(^DPT(DFN,.312,IRIEN,3)),U,12)
     40 S EFFDT=$P(^DPT(DFN,.312,IRIEN,0),U,8)
     41 S EXPDT=$P(^DPT(DFN,.312,IRIEN,0),U,4)
     42 S REL=$P(^DPT(DFN,.312,IRIEN,0),U,16)
     43 ;
     44 S IENS=IRIEN_","_DFN_","
     45 S GNUMB=$$GET1^DIQ(2.312,IENS,21,"E")
     46 S GNAME=$$GET1^DIQ(2.312,IENS,20,"E")
     47 ;
     48 ; Capture the employer sponsored insurance fields into array
     49 ;   ESGHPARR(buffer field number) = data
     50 ;
     51 S INSDATA=$G(^DPT(DFN,.312,IRIEN,2)),PCE=0
     52 F BFD=5:1:12,2,1,3,4 S PCE=PCE+1,BFN=BFD/100+61,INSPCE=$P(INSDATA,U,PCE) I INSPCE'="" S ESGHPARR(BFN)=INSPCE
     53 ;
     54 D FIL
     55 K ADD
     56 Q
     57 ;
     58RP(IEN,ADD,BUFF) ;  Get data from a specific response record
     59 ;
     60 ;  Input Parameter
     61 ;    IEN  = Internal entry number of the Response
     62 ;    ADD  = If defined, then it will add a new Buffer entry
     63 ;    BUFF = IEN of the Buffer Entry to be updated (optional)
     64 ;
     65 S BUFF=$G(BUFF) ; Initialize optional parameter
     66 ;
     67 NEW PIEN,RSTYPE
     68 S DFN=$P(^IBCN(365,IEN,0),U,2),TQIEN=$P(^IBCN(365,IEN,0),U,5)
     69 S PIEN=$P(^IBCN(365,IEN,0),U,3),RSTYPE=$P(^(0),U,10)
     70 I PIEN'="" S PNAME=$P(^IBE(365.12,PIEN,0),U,1)
     71 I TQIEN'="" S IRIEN=$P($G(^IBCN(365.1,TQIEN,0)),U,13)
     72 I $G(IRIEN)'="" S INAME="" D
     73 . S IIEN=$P($G(^DPT(DFN,.312,IRIEN,0)),U,1)
     74 . I IIEN="" Q
     75 . S INAME=$P(^DIC(36,IIEN,0),U,1)
     76 S RDATA=$G(^IBCN(365,IEN,1))
     77 S NAME=$P(RDATA,U,1)
     78 S INAME=$S($G(INAME)'=""&(RSTYPE="O"):INAME,1:$G(PNAME))
     79 S IDOB=$P(RDATA,U,2)
     80 S ISSN=$P(RDATA,U,3)
     81 S ISEX=$P(RDATA,U,4)
     82 S COB=$P(RDATA,U,13)
     83 S SUBID=$P(RDATA,U,5)
     84 S GNAME=$P(RDATA,U,6)
     85 S GNUMB=$P(RDATA,U,7)
     86 S WHO=$P(RDATA,U,8)
     87 S REL=$P(RDATA,U,9)
     88 S EFFDT=$P(RDATA,U,11)
     89 S EXPDT=$P(RDATA,U,12)
     90 S PPHONE="",BPHONE=""
     91 ;
     92 D FIL
     93 K DFN,VBUF,IEN,IRIEN,INAME,PNAME,IIEN,GNUMB,GNAME,SUBID,PPHONE
     94 K BPHONE,EFFDT,EXPDT,WHO,REL,IDOB,ISSN,COB,TQIEN,RDATA,ISEX,NAME
     95 K ADD,%DT,D0,DG,DIC,DISYS,DIW,IENS
     96 Q
     97 ;
     98FIL ;  File Buffer Data
     99 ;
     100 S MSGP=$$MGRP^IBCNEUT5()
     101 ;
     102 ; Variable IDUZ is optionally set by the calling routine.  If it is
     103 ; not defined, it will be set to the specific, non-human user.
     104 ;
     105 I $G(IDUZ)="" S IDUZ=$$FIND1^DIC(200,"","X","INTERFACE,IB IIV")
     106 ;
     107 I $G(ADD) S VBUF(.02)=IDUZ  ; Entered By
     108 S VBUF(.12)=$G(SYMBOL)   ; Buffer Symbol
     109 S VBUF(.13)=$G(OVRRIDE) ; Override freshness flag
     110 I '$G(ERACT) D  ; Only file if not an error
     111 . S VBUF(20.01)=INAME  ; Insurance Company/Payer Name
     112 . S VBUF(60.01)=DFN  ; Patient IEN
     113 . S VBUF(40.03)=GNUMB  ; Group Number
     114 . S VBUF(40.02)=GNAME  ; Group Name
     115 . S VBUF(60.07)=NAME  ; Name of Insured
     116 . S VBUF(60.04)=SUBID  ; Subscriber ID
     117 . S VBUF(20.04)=PPHONE  ; Precertification Phone
     118 . S VBUF(20.03)=BPHONE  ; Billing Phone
     119 . S VBUF(60.02)=EFFDT  ; Effective Date
     120 . S VBUF(60.03)=EXPDT  ; Expiration Date
     121 . S VBUF(60.05)=WHO  ; Whose Insurance
     122 . S VBUF(60.06)=REL  ;  Patient Relationship
     123 . S VBUF(60.08)=IDOB  ;  Insured's DOB
     124 . S VBUF(60.09)=ISSN  ;  Insured's SSN
     125 . S VBUF(60.12)=COB  ;  Coordination of Benefits
     126 . S VBUF(60.13)=ISEX  ;  Insured's Sex
     127 . ;
     128 . ; If the employer sponsored insurance array exists, then merge it in
     129 . I $D(ESGHPARR) M VBUF=ESGHPARR
     130 ;
     131 ; Do not overwrite the existing insurance co. name if it already exists
     132 I $G(ADD)="",$G(BUFF)'="" K VBUF(20.01)
     133 ;
     134 ; ** initialize IBERROR
     135 S IBERROR=""
     136 ;
     137 ;  If need to add a new Buffer entry ...
     138 ;
     139 ;  Variable IBFDA is returned to the calling routine as the IEN of
     140 ;  the buffer entry that was just added.
     141 ;
     142 I $G(ADD) D
     143 . S IBFDA=$$ADDSTF^IBCNBES(5,DFN,.VBUF)
     144 . ; Error Message is 2nd piece of result
     145 . S IBERROR=$P(IBFDA,U,2)
     146 . S IBFDA=$P(IBFDA,U,1)
     147 ;
     148 ;  If an error, send an email message
     149 I IBERROR'="" D  Q
     150 . S MSG(1)="Error returned by $$ADDSTF^IBCNBES:"
     151 . S MSG(2)=IBERROR
     152 . S MSG(3)="Values:"
     153 . S MSG(4)=" Patient DFN = "_$G(DFN)
     154 . S MSG(5)=" Pt Ins Record IEN = "_$G(IRIEN)
     155 . S MSG(6)="Please log a NOIS for this problem."
     156 . S XMSUB="Error creating Buffer Entry."
     157 . D MSG^IBCNEUT5(MSGP,XMSUB,"MSG(")
     158 . K MSGP,MSG,XMSUB,IBERR
     159 ;
     160 ;  If need to update a new Buffer Entry ...
     161 ;
     162 ;  Variable BUFF is passed into this routine whenever the buffer
     163 ;  entry is known and the ADD flag is off.  The existing buffer entry
     164 ;  is edited in this case.
     165 ;
     166 I $G(ADD)="" D EDITSTF^IBCNBES(BUFF,.VBUF)
     167 ;
     168 ;  If an error occurred in EDITSTF, the error array is not returned
     169 ;
     170 Q

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNQ.m

    r613 r623  
    1 IBCNQ   ;ALB/MJB - MCCR PATIENT BILLING INQUIRY ;6:13 AM  4 Jan 2009
    2         ;;2.0;INTEGRATED BILLING;**51,320,377**;21-MAR-94;Build 4;WorldVistA 30-Jan-08
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5         ;Modified from FOIA VISTA,
    6         ;Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
    7         ;General Public License See attached copy of the License.
    8         ;
    9         ;This program is free software; you can redistribute it and/or modify
    10         ;it under the terms of the GNU General Public License as published by
    11         ;the Free Software Foundation; either version 2 of the License, or
    12         ;(at your option) any later version.
    13         ;
    14         ;This program is distributed in the hope that it will be useful,
    15         ;but WITHOUT ANY WARRANTY; without even the implied warranty of
    16         ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    17         ;GNU General Public License for more details.
    18         ;
    19         ;You should have received a copy of the GNU General Public License along
    20         ;with this program; if not, write to the Free Software Foundation, Inc.,
    21         ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    22         ;
    23         ;
    24         ;MAP TO DGCRNQ
    25         ;
    26         D HOME^%ZIS
    27 ASKPAT  S DIC="^DGCR(399,",DIC(0)="AEMQZ",DIC("A")="Enter BILL NUMBER or PATIENT NAME: " W !! D ^DIC G:X=""!(X["^") Q
    28         ;
    29         S IBIFN=+Y,IBQUIT=0,IBAC=7
    30 VIEW    ;
    31         ;***
    32         F I=0,"S","U","U1" S IB(I)=$G(^DGCR(399,IBIFN,I))
    33         S DFN=$P(IB(0),"^",2),IBSTAT=$P(IB(0),"^",13),IBBNO=$$BN^PRCAFN(IBIFN),IBPAGE=0 S:IBBNO=-1 IBBNO=$S($D(IBIL):IBIL,1:$P(IB(0),"^"))
    34         ;
    35         D NOW^%DTC S Y=$E(%,1,12) D D^DIQ S IBNOW=Y,IBPT=$$PT^IBEFUNC(DFN) D HDR1
    36         ;
    37         S IBUN="UNSPECIFIED",IBUK="UNKNOWN USER"
    38         W !,"Bill Status",?15,": ",$S(IBSTAT=1:"ENTERED/NOT REVIEWED",IBSTAT=2:"MRA REQUESTED",IBSTAT=3:"AUTHORIZED",IBSTAT=4:"PRINTED/TRANSMITTED",IBSTAT=7:"CANCELLED",1:IBUN)," - RECORD IS ",$S(IBSTAT=1:"",1:"UN"),"EDITABLE"
    39         W !,"Rate Type",?15,": ",$S($P(IB(0),"^",7)="":IBUN,'$D(^DGCR(399.3,$P(IB(0),"^",7),0)):IBUN,1:$P(^DGCR(399.3,$P(IB(0),"^",7),0),"^"))
    40         W:+$P(^IBE(350.9,1,1),"^",22) !,"Form Type",?15,": ",$S($P($G(^IBE(353,+$P(IB(0),"^",19),0)),"^")]"":$P(^(0),"^"),1:IBUN)
    41         W:IBSTAT=7 !,"Reason Canceled",?15,": ",$S($P(IB("S"),"^",19)]"":$P(IB("S"),"^",19),1:IBUN)
    42         I $$INPAT^IBCEF(IBIFN) S Y=$P(IB(0),"^",3) D D^DIQ W !!,"Admission Date : ",Y
    43         E  D OPDATE
    44         W !!,"Charges",?15,": " S X=$P(IB("U1"),U,1),X2="2$" D:X]"" COMMA^%DTC W $S(X]"":X,1:IBUN)
    45         I $P(IB("U1"),U,2)]"" W !,"LESS Offset",?15,": " S X=$P(IB("U1"),U,2),X2="2$" D COMMA^%DTC W X,"   [",$P(IB("U1"),U,3),"]",!,"Bill Total",?15,": " S X=($P(IB("U1"),U,1)-$P(IB("U1"),U,2)),X2="2$" D COMMA^%DTC W X
    46         S X=$$TPR^PRCAFN(IBIFN) I X>0 S X2="2$" D COMMA^%DTC W !,"Amount Paid",?15,": ",X
    47         S X=$$STA^PRCAFN(IBIFN) I X>0 W !,"AR Status",?15,": ",$P(X,"^",2)
    48         I $P(IB("U"),U)]"" S Y=$P(IB("U"),U) D D^DIQ W !!,"Statement From",?15,": ",Y S Y=$P(IB("U"),"^",2) D D^DIQ W !,"Statement To",?15,": ",Y,!
    49         I $P(IB("U"),U)']"" W !!,"Statement From",?15,": ",IBUN,!,"Statement To",?15,": ",IBUN,!
    50         D DISP I IBQUIT Q:IBAC[8  G Q
    51         I IBSTAT<5 D NOPTF^IBCB2 I 'IBAC1 D:$Y>(IOSL-6) HDR Q:IBQUIT&(IBAC[8)  G Q:IBQUIT D NOPTF1^IBCB2
    52         D PAUSE,^IBOLK1:$G(IBFULL)&('IBQUIT) Q:IBAC[8  ; Called from Outpatient Visit Date Inquiry
    53         G Q:IBQUIT,ASKPAT
    54         ;
    55 DISP    ; The variable IBAC must be defined as input to this sub-routine.
    56         G:'$D(IBAC) DISPQ
    57         S IBUN="UNSPECIFIED",IBUK="UNKNOWN USER"
    58         I IB("S")']"" W !,"Past actions of this billing record unspecified." G DISPQ
    59         S IBX="Entered^^^^^^MRA Requested^^^Authorized^^First Printed^^Last Printed^^^Cancelled"
    60         F I=1,7,10,12,14,17 I $P(IB("S"),U,I)]"" D:IBAC[7&($Y>(IOSL-4)) HDR Q:$S(IBAC'[7:0,1:IBQUIT)  D DISP1
    61         ;
    62         ;Patch 320 - Added call to retrieve claim clone history.
    63         N IBCCR,IBCURR,IBNEXT,IBBCH,IBINDENT
    64         S IBINDENT=0
    65         D EN^IBCCR(IBIFN,.IBCCR)   ; utility to pull cloning history
    66         ;
    67         ; attempt to go one claim forward from the current claim
    68         S IBCURR="IBCCR("_+$P(IB("S"),U,1)_","_IBIFN_")"
    69         S IBNEXT=$Q(@IBCURR)
    70         I IBNEXT'="" D
    71         . N IBX S IBX=@IBNEXT
    72         . W !,"Copied"
    73         . W ?15,": ",$$FMTE^XLFDT($P(IBX,U,1),"1Z")_" by "_$P(IBX,U,3)
    74         . W !,"Copied To",?15,": ",$P(IBX,U,2)
    75         . S IBINDENT=1
    76         . Q
    77         ;
    78         ; now go backwards for claim cloning history all the way back
    79         S IBBCH=IBCURR
    80         ;WVEHR ;begin change 01/04/2009
    81         ;F  S IBBCH=$Q(@IBBCH,-1) Q:IBBCH=""  D
    82         F  S IBBCH=$$Q^VWUTIL($NA(@IBBCH),-1) Q:IBBCH=""  D
    83         .;WVEHR ;end change
    84         . N IBX,TS1,TS2 S IBX=@IBBCH
    85         . I IBINDENT S TS1=4,TS2=19     ; set tab stops
    86         . E  S TS1=0,TS2=15
    87         . W !?TS1,"Copied",?TS2,": "
    88         . W $$FMTE^XLFDT($P(IBX,U,1),"1Z")_" by "_$P(IBX,U,3)
    89         . W !?TS1,"Copied From",?TS2,": ",$P(IBX,U,2)
    90         . W !?TS1,"Reason Copied",?TS2,": ",$P(IBX,U,4)
    91         . S IBINDENT=1
    92         . Q
    93         ;
    94         I $D(^DGCR(399,IBIFN,"R","AC",1)) S IB=0 F I=0:0 S IB=$O(^DGCR(399,IBIFN,"R","AC",1,IB)) Q:'IB  D:IBAC[7&($Y>(IOSL-4)) HDR Q:$S(IBAC'[7:0,1:IBQUIT)  W !,"Returned to AR : " D RETN
    95 DISPQ   Q
    96         ;
    97 DISP1   W !,$P(IBX,U,I) S Y=$P(IB("S"),U,I) D D^DIQ W ?15,": ",Y,?28," by " S IBN=$P(IB("S"),U,(I+1)) W $S(IBN']"":IBUK,$D(^VA(200,IBN,0)):$P(^(0),U,1),1:IBUK)
    98         Q
    99         ;
    100 Q       K DFN,IB,IBAC,IBBNO,IBN,IBNOW,IBPAGE,IBPT,IBU,IBQUIT,IBUK,IBUN,IBX,IBSTAT,IBAC1,IBIFN,IBOPD,DIC,X,X2,Y
    101         Q
    102         ;
    103 RETN    I $D(^DGCR(399,IBIFN,"R",IB,0)) S IBN=^(0),Y=$P($P(IBN,"^"),".") D D^DIQ W Y,?28," by " S IBN=$P(IBN,"^",2) I IBN]"",$D(^VA(200,IBN,0)) W $P(^VA(200,IBN,0),"^")
    104         Q
    105         ;
    106 HDR     D PAUSE Q:IBQUIT
    107 HDR1    S L="",$P(L,"=",80)="",IBPAGE=IBPAGE+1
    108         W:$E(IOST,1,2)["C-"!(IBPAGE>1) @IOF
    109         W $E($P(IBPT,"^"),1,20),"   ",$P(IBPT,"^",2),?38,IBBNO,?51,IBNOW,?72,"PAGE: ",IBPAGE,!,L
    110         K L Q
    111         ;
    112 OPDATE  ; List Outpatient Visit Dates.
    113         Q:'$O(^DGCR(399,IBIFN,"OP",0))
    114         W !!,"OP Visit Dates :" S IBOPD=0
    115         F I=1:1 S IBOPD=$O(^DGCR(399,IBIFN,"OP",IBOPD)) Q:'IBOPD  D
    116         . W:'((I-1)#4)&(I>1) !
    117         . S Y=IBOPD D D^DIQ W ?($S(I#4:I#4,1:4)*14+3),Y
    118         Q
    119         ;
    120 PAUSE   Q:$E(IOST,1,2)'="C-"
    121         F I=$Y:1:(IOSL-3) W !
    122         S DIR(0)="E" D ^DIR K DIR I $D(DIRUT)!($D(DUOUT)) S IBQUIT=1 K DIRUT,DTOUT,DUOUT
    123         Q
     1IBCNQ ;ALB/MJB - MCCR PATIENT BILLING INQUIRY ;7:37 PM  30 Jan 2008
     2 ;;2.0;INTEGRATED BILLING;**51,320;VWEHR1**;WorldVistA 30-Jan-08
     3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
     4 ;
     5 ;Modified from FOIA VISTA,
     6 ;Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
     7 ;General Public License See attached copy of the License.
     8 ;
     9 ;This program is free software; you can redistribute it and/or modify
     10 ;it under the terms of the GNU General Public License as published by
     11 ;the Free Software Foundation; either version 2 of the License, or
     12 ;(at your option) any later version.
     13 ;
     14 ;This program is distributed in the hope that it will be useful,
     15 ;but WITHOUT ANY WARRANTY; without even the implied warranty of
     16 ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     17 ;GNU General Public License for more details.
     18 ;
     19 ;You should have received a copy of the GNU General Public License along
     20 ;with this program; if not, write to the Free Software Foundation, Inc.,
     21 ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
     22 ;
     23 ;MAP TO DGCRNQ
     24 ;
     25 D HOME^%ZIS
     26ASKPAT S DIC="^DGCR(399,",DIC(0)="AEMQZ",DIC("A")="Enter BILL NUMBER or PATIENT NAME: " W !! D ^DIC G:X=""!(X["^") Q
     27 ;
     28 S IBIFN=+Y,IBQUIT=0,IBAC=7
     29VIEW ;
     30 ;***
     31 ;S XRTL=$ZU(0),XRTN="IBCNQ-2" D T0^%ZOSV ;start rt clock
     32 F I=0,"S","U","U1" S IB(I)=$G(^DGCR(399,IBIFN,I))
     33 S DFN=$P(IB(0),"^",2),IBSTAT=$P(IB(0),"^",13),IBBNO=$$BN^PRCAFN(IBIFN),IBPAGE=0 S:IBBNO=-1 IBBNO=$S($D(IBIL):IBIL,1:$P(IB(0),"^"))
     34 ;
     35 D NOW^%DTC S Y=$E(%,1,12) D D^DIQ S IBNOW=Y,IBPT=$$PT^IBEFUNC(DFN) D HDR1
     36 ;
     37 S IBUN="UNSPECIFIED",IBUK="UNKNOWN USER"
     38 W !,"Bill Status",?15,": ",$S(IBSTAT=1:"ENTERED/NOT REVIEWED",IBSTAT=2:"MRA REQUESTED",IBSTAT=3:"AUTHORIZED",IBSTAT=4:"PRINTED/TRANSMITTED",IBSTAT=7:"CANCELLED",1:IBUN)," - RECORD IS ",$S(IBSTAT<3:"",1:"UN"),"EDITABLE"
     39 W !,"Rate Type",?15,": ",$S($P(IB(0),"^",7)="":IBUN,'$D(^DGCR(399.3,$P(IB(0),"^",7),0)):IBUN,1:$P(^DGCR(399.3,$P(IB(0),"^",7),0),"^"))
     40 W:+$P(^IBE(350.9,1,1),"^",22) !,"Form Type",?15,": ",$S($P($G(^IBE(353,+$P(IB(0),"^",19),0)),"^")]"":$P(^(0),"^"),1:IBUN)
     41 W:IBSTAT=7 !,"Reason Canceled",?15,": ",$S($P(IB("S"),"^",19)]"":$P(IB("S"),"^",19),1:IBUN)
     42 I $$INPAT^IBCEF(IBIFN) S Y=$P(IB(0),"^",3) D D^DIQ W !!,"Admission Date : ",Y
     43 E  D OPDATE
     44 W !!,"Charges",?15,": " S X=$P(IB("U1"),U,1),X2="2$" D:X]"" COMMA^%DTC W $S(X]"":X,1:IBUN)
     45 I $P(IB("U1"),U,2)]"" W !,"LESS Offset",?15,": " S X=$P(IB("U1"),U,2),X2="2$" D COMMA^%DTC W X,"   [",$P(IB("U1"),U,3),"]",!,"Bill Total",?15,": " S X=($P(IB("U1"),U,1)-$P(IB("U1"),U,2)),X2="2$" D COMMA^%DTC W X
     46 S X=$$TPR^PRCAFN(IBIFN) I X>0 S X2="2$" D COMMA^%DTC W !,"Amount Paid",?15,": ",X
     47 S X=$$STA^PRCAFN(IBIFN) I X>0 W !,"AR Status",?15,": ",$P(X,"^",2)
     48 I $P(IB("U"),U)]"" S Y=$P(IB("U"),U) D D^DIQ W !!,"Statement From",?15,": ",Y S Y=$P(IB("U"),"^",2) D D^DIQ W !,"Statement To",?15,": ",Y,!
     49 I $P(IB("U"),U)']"" W !!,"Statement From",?15,": ",IBUN,!,"Statement To",?15,": ",IBUN,!
     50 D DISP I IBQUIT Q:IBAC[8  G Q
     51 I IBSTAT<5 D NOPTF^IBCB2 I 'IBAC1 D:$Y>(IOSL-6) HDR Q:IBQUIT&(IBAC[8)  G Q:IBQUIT D NOPTF1^IBCB2
     52 D PAUSE,^IBOLK1:$G(IBFULL)&('IBQUIT) Q:IBAC[8  ; Called from Outpatient Visit Date Inquiry
     53 G Q:IBQUIT,ASKPAT
     54 ;
     55DISP ; The variable IBAC must be defined as input to this sub-routine.
     56 G:'$D(IBAC) DISPQ
     57 S IBUN="UNSPECIFIED",IBUK="UNKNOWN USER"
     58 I IB("S")']"" W !,"Past actions of this billing record unspecified." G DISPQ
     59 S IBX="Entered^^^^^^MRA Requested^^^Authorized^^^^Last Printed^^^Cancelled"
     60 F I=1,10,14,17 I $P(IB("S"),U,I)]"" D:IBAC[7&($Y>(IOSL-4)) HDR Q:$S(IBAC'[7:0,1:IBQUIT)  D DISP1
     61 ;
     62 ;Patch 320 - Added call to retrieve claim clone history.
     63 N IBCCR,IBCURR,IBNEXT,IBBCH,IBINDENT
     64 S IBINDENT=0
     65 D EN^IBCCR(IBIFN,.IBCCR)   ; utility to pull cloning history
     66 ;
     67 ; attempt to go one claim forward from the current claim
     68 S IBCURR="IBCCR("_+$P(IB("S"),U,1)_","_IBIFN_")"
     69 S IBNEXT=$Q(@IBCURR)
     70 I IBNEXT'="" D
     71 . N IBX S IBX=@IBNEXT
     72 . W !,"Copied"
     73 . W ?15,": ",$$FMTE^XLFDT($P(IBX,U,1),"1Z")_" by "_$P(IBX,U,3)
     74 . W !,"Copied To",?15,": ",$P(IBX,U,2)
     75 . S IBINDENT=1
     76 . Q
     77 ;
     78 ; now go backwards for claim cloning history all the way back
     79 S IBBCH=IBCURR
     80 ;
     81 ;WV/EHR REVERSE $Q REPLACEMENT; SO 01/12/08 ;VWEHR1
     82 ;
     83 ;F  S IBBCH=$Q(@IBBCH,-1) Q:IBBCH=""  D
     84 F  S IBBCH=$$Q^VWUTIL($NA(@IBBCH),-1) Q:IBBCH=""  D
     85 . ;
     86 . ;END CHANGE
     87 . ;
     88 . N IBX,TS1,TS2 S IBX=@IBBCH
     89 . I IBINDENT S TS1=4,TS2=19     ; set tab stops
     90 . E  S TS1=0,TS2=15
     91 . W !?TS1,"Copied",?TS2,": "
     92 . W $$FMTE^XLFDT($P(IBX,U,1),"1Z")_" by "_$P(IBX,U,3)
     93 . W !?TS1,"Copied From",?TS2,": ",$P(IBX,U,2)
     94 . W !?TS1,"Reason Copied",?TS2,": ",$P(IBX,U,4)
     95 . S IBINDENT=1
     96 . Q
     97 ;
     98 I $D(^DGCR(399,IBIFN,"R","AC",1)) S IB=0 F I=0:0 S IB=$O(^DGCR(399,IBIFN,"R","AC",1,IB)) Q:'IB  D:IBAC[7&($Y>(IOSL-4)) HDR Q:$S(IBAC'[7:0,1:IBQUIT)  W !,"Returned to AR : " D RETN
     99DISPQ Q
     100 ;
     101DISP1 W !,$P(IBX,U,I) S Y=$P(IB("S"),U,I) D D^DIQ W ?15,": ",Y,?28," by " S IBN=$P(IB("S"),U,(I+1)) W $S(IBN']"":IBUK,$D(^VA(200,IBN,0)):$P(^(0),U,1),1:IBUK)
     102 Q
     103 ;
     104Q K DFN,IB,IBAC,IBBNO,IBN,IBNOW,IBPAGE,IBPT,IBU,IBQUIT,IBUK,IBUN,IBX,IBSTAT,IBAC1,IBIFN,IBOPD,DIC,X,X2,Y
     105 Q
     106 ;
     107RETN I $D(^DGCR(399,IBIFN,"R",IB,0)) S IBN=^(0),Y=$P($P(IBN,"^"),".") D D^DIQ W Y,?28," by " S IBN=$P(IBN,"^",2) I IBN]"",$D(^VA(200,IBN,0)) W $P(^VA(200,IBN,0),"^")
     108 Q
     109 ;
     110HDR D PAUSE Q:IBQUIT
     111HDR1 S L="",$P(L,"=",80)="",IBPAGE=IBPAGE+1
     112 W:$E(IOST,1,2)["C-"!(IBPAGE>1) @IOF
     113 W $E($P(IBPT,"^"),1,20),"   ",$P(IBPT,"^",2),?38,IBBNO,?51,IBNOW,?72,"PAGE: ",IBPAGE,!,L
     114 K L Q
     115 ;
     116OPDATE ; List Outpatient Visit Dates.
     117 Q:'$O(^DGCR(399,IBIFN,"OP",0))
     118 W !!,"OP Visit Dates :" S IBOPD=0
     119 F I=1:1 S IBOPD=$O(^DGCR(399,IBIFN,"OP",IBOPD)) Q:'IBOPD  D
     120 . W:'((I-1)#4)&(I>1) !
     121 . S Y=IBOPD D D^DIQ W ?($S(I#4:I#4,1:4)*14+3),Y
     122 Q
     123 ;
     124PAUSE Q:$E(IOST,1,2)'="C-"
     125 F I=$Y:1:(IOSL-3) W !
     126 S DIR(0)="E" D ^DIR K DIR I $D(DIRUT)!($D(DUOUT)) S IBQUIT=1 K DIRUT,DTOUT,DUOUT
     127 Q

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNRDV.m

    r613 r623  
    1 IBCNRDV ;OAKFO/ELZ - INSURANCE INFORMATION EXCHANGE VIA RDV ;27-MAR-03
    2         ;;2.0;INTEGRATED BILLING;**214,231,361,371**;21-MAR-94;Build 57
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5         ; This routine is used to exchange insurance information between
    6         ; facilities.
    7 OPT     ; Menu option entry point.  This is used to select a patient to request
    8         ; information about from the remote treating facilities.
    9         N DFN,DIC,X,Y,DTOUT,DUOUT,IBT,%,%Y,IBX,VADM,IBB,IBD,IBH,IBI,IBICN,IBR,IBRZ,IBX,IBY,IBZ,IBWAIT,IBL,DO,IBTYPE,IB1
    10         ;
    11         ; prompt for patient
    12 AGAIN   S DIC="^DPT(",DIC(0)="AEMNQ" D ^DIC Q:Y<1  S DFN=+Y
    13         ;
    14 BACKGND ; background/tasked entry point
    15         ; IBTYPE is being used as a flag to indicate this is running in background
    16         ;
    17         ; look up treating facilities
    18         K IBT S IBT=$$TFL^IBARXMU(DFN,.IBT)
    19         I IBT<1,'$D(IBTYPE) W !!,"This patient has no remote treating facilities to query." G AGAIN
    20         I IBT<1 Q
    21         ;
    22         ; display and verify we want to do this
    23         I '$D(IBTYPE) D DEM^VADPT W !!,"The patient ",VADM(1)," has the following ",IBT," remote facilitie(s)",! S IBX=0 F  S IBX=$O(IBT(IBX)) Q:IBX<1  W !?10,$P(IBT(IBX),"^",2)
    24         I '$D(IBTYPE) W !!,"Do you want to perform this Remote Query" S %=1 D YN^DICN G:%'=1 AGAIN
    25         ;
    26         ; get ICN
    27         S IBICN=$$ICN^IBARXMU(DFN) I 'IBICN,'$D(IBTYPE) W !!,"No ICN for this patient" G AGAIN
    28         I 'IBICN Q
    29         ;
    30         ; sent off the remote queries and get back handles
    31         S IBX=0 F  S IBX=$O(IBT(IBX)) Q:IBX<1  D
    32         . D SEND(.IBH,IBX,IBICN,$S($D(IBTYPE):"IBCN INSURANCE QUERY TASK",1:"IBCN INSURANCE QUERY"))
    33         . X $S(IBH(0)'="":"S $P(IBT(IBX),U,5)=IBH(0)",1:"W:'$D(IBTYPE) !,""No handle returned for "",$P(IBT(IBX),U,2) K IBT(IBX)")
    34         ;
    35         ; no handles returned
    36         I $D(IBT)<9,'$D(IBTYPE) W !!,"Unable to perform any remote queries.",! G AGAIN
    37         I $D(IBT)<9 Q
    38         ;
    39         ; go through every IBT()
    40         S IBP="|",IBX=0 F  S IBX=$O(IBT(IBX)) Q:IBX<1!($D(IBT)<9)  D
    41         . ;
    42         . ; do I have a return data.
    43         . F IBWAIT=1:1:60 W:'$D(IBTYPE) "." H 1 D CHECK(.IBR,$P(IBT(IBX),"^",5)) I $G(IBR(0))["Done" Q
    44         . I $G(IBR(0))'["Done" W:'$D(IBTYPE) !!,"Unable to communicate with ",$P(IBT(IBX),U,2) Q
    45         . K IBR
    46         . D RETURN(.IBR,$P(IBT(IBX),"^",5))
    47         . ;
    48         . ; no data returned or error message
    49         . S IBRZ=$S(-1=+$G(IBR):IBR,$G(IBR(0))="":$G(IBR(1)),1:$G(IBR(0)))
    50         . ;
    51         . ; no info to proceed
    52         . I IBRZ<1 W:'$D(IBTYPE) !,"Response from ",$P(IBT(IBX),U,2),!,$P(IBRZ,"^",2) K IBT(IBX) D:IBRZ="-1^No insurance on file" FILE(0) Q
    53         . ;
    54         . ; received insurance info, need to file and display message
    55         . W:'$D(IBTYPE) !,"Received ",$G(IBR(0))," insurance companies from ",$P(IBT(IBX),U,2) D FILE(+IBR(0))
    56         . ;
    57         . S IBY=0 F  S IBY=$O(IBR(IBY))  Q:IBY<1  D
    58         .. F IBL=5:1  S IBT=$P($T(MAP+IBL),";",3) Q:IBT=""  D
    59         ... ;
    60         ... ; am I on the right MAP line
    61         ... I $P(IBT,IBP,3)=$S(IBY#6:IBY#6,1:6) S IBZ=$P(IBR(IBY),"^",$P(IBT,IBP,4)) I $L(IBZ) D
    62         .... ;
    63         .... ; xecute code to change external to internal
    64         .... X:$L($P(IBT,IBP,7)) $P(IBT,IBP,7)
    65         .... ;
    66         .... ; put the info in the array for the buffer file
    67         .... S:$D(IBZ) IBB($P(IBT,IBP,5))=IBZ
    68         .. ;
    69         .. ; need to avoid duplicates if possible.
    70         .. I $G(IBB(20.01))["MEDICARE (WNR)" S X=0 F  S X=$O(^DPT(DFN,.312,X)) Q:X<1  I $P($G(^DIC(36,+$P($G(^DPT(DFN,.312,X,0)),"^"),0)),"^")["MEDICARE (WNR)" K IBB Q
    71         .. Q:'$D(IBB)
    72         .. ;
    73         .. ; file in the buffer file & where else needed
    74         .. I IBY#6=0 D
    75         ... I $L($G(IBB(20.01))) D
    76         .... S IBB(.14)=$$IEN^XUAF4(+IBT(IBX))
    77         .... S IBB=$$ADDSTF^IBCNBES($G(IBB(.03),1),DFN,.IBB)
    78         ... I '$D(IB1),$D(IBTYPE),$L($G(IBB(20.01))) D SCH^IBTUTL2(DFN,$G(IBSAVEI),$G(IBSAVEJ)):IBTYPE="TRKR",ADM^IBTUTL($G(IBSAVE1),$G(IBSAVE2),$G(IBSAVE3),$G(IBSAVE4)):IBTYPE="ADM" S IB1=1
    79         ... W:'$D(IBTYPE)&($L($G(IBB(20.01)))) !,$P($G(IBB),"^")," Buffer File entry for ",$G(IBB(20.01))
    80         ... K IBB
    81         ;
    82         ; flag so I don't do this patient again within 90 days
    83         S ^IBT(356,"ARDV",DFN,$$FMADD^XLFDT(DT,90))=""
    84         ;
    85         Q
    86         ;
    87 RPC(IBD,IBICN)  ; RPC entry for looking up insurance info
    88         N DFN,IBZ,IBX,IBY,IBP,IBI,IBT,IBZ
    89         S DFN=$$DFN^IBARXMU(IBICN) I 'DFN S IBD(0)="-1^ICN Not found" Q
    90         D ALL^IBCNS1(DFN,"IBY",3)
    91         I '$D(IBY) S IBD(0)="-1^No insurance on file" Q
    92         ; set up return format
    93         ; IBD(0)   = # of insurance companies
    94         S IBD(0)=$G(IBY(0))
    95         ;
    96         ; where n starts at 1 and increments to 7 for each insurance company
    97         ; IBD(n) = 355.33, zero node format
    98         ; IBD(n+1) = 355.33, 20 node format
    99         ; IBD(n+2) = 355.33, 21 node format
    100         ; IBD(n+3) = 355.33, 40 node format
    101         ; IBD(n+4) = 355.33, 60 node format
    102         ; IBD(n+5) = 355.33, 61 node format
    103         ; IBD(n+6) = 355.33, 62 node format
    104         ;
    105         S IBP="|"
    106         S IBI=0 F  S IBI=$O(IBY(IBI))  Q:IBI<1  F IBL=5:1 S IBT=$P($T(MAP+IBL),";",3) Q:IBT=""  D
    107         . S IBZ=$P($G(IBY(IBI,+IBT)),"^",$P(IBT,IBP,2)) ; set the existing data
    108         . I $L($P(IBT,IBP,6)) X $P(IBT,IBP,6) ; output transform
    109         . S $P(IBD(IBI-1*7+$P(IBT,IBP,3)),"^",$P(IBT,IBP,4))=IBZ ; set data IBD
    110         Q
    111         ;
    112 MAP     ; this is a mapping of data returned from ALL^IBCNS1 to the buffer file
    113         ; format is:  node number | piece | extract node | extract piece
    114         ;             | 355.33 field number | format out code (if any)
    115         ;             | format in code (if any)
    116         ; the extract nodes will be sequential to match buffer file DD
    117         ;;0|1|2|1|20.01|N Z X "F Z=0,.11,.13 S IBY(IBI,36+Z)=$G(^DIC(36,IBZ,Z))" S IBZ=$P(IBY(IBI,36),"^");ins co name
    118         ;;0|2|5|4|60.04;subscriber id
    119         ;;0|4|5|3|60.03;experation date
    120         ;;0|6|5|5|60.05;who's insurance
    121         ;;0|8|5|2|60.02;effective date
    122         ;;0|16|5|6|60.06;pt relationship to insured
    123         ;;0|17|5|7|60.07;name of insured
    124         ;;0|20|5|12|60.12;coordination of benefits
    125         ;;1|3|1|10|.1||I IBZ<$$FMADD^XLFDT(DT,-180) K IBZ;date (last) verified
    126         ;;1|9|1|3|.03;source of information
    127         ;;2|1|6|5|61.05;send bill to employer
    128         ;;2|2|6|6|61.06;employer claims street address (line 1)
    129         ;;2|3|6|7|61.07;employer claims street address line 2
    130         ;;2|4|6|8|61.08;employer claims street address line 3
    131         ;;2|5|6|9|61.09;employer claims city
    132         ;;2|6|6|10|61.1|S IBZ=$$EXTERNAL^DILFD(2.312,2.06,"",IBZ)|N DIC,X,Y S DIC="^DIC(5,",X=IBZ,DIC(0)="OX" D ^DIC K:+Y<1 IBZ S:+Y>0 IBZ=+Y;employer claims state
    133         ;;2|7|6|11|61.11;employer claims zip code
    134         ;;2|8|6|12|61.12;employer claims phone
    135         ;;2|10|6|1|61.01;esghp
    136         ;;2|11|6|3|61.03;employment status
    137         ;;2|12|6|4|61.04;retirement date
    138         ;;3|1|5|8|60.08;insured's dob
    139         ;;3|5|5|9|60.09;insured's ssn
    140         ;;3|12|5|13|60.13;insured's sex
    141         ;;4|1|5|10|60.1;primary care provider
    142         ;;4|2|5|11|60.11;primary provider phone
    143         ;;5|1|7|1|62.01;patient id
    144         ;;355.3|2|4|1|40.01;is this a group policy
    145         ;;355.3|3|4|2|40.02;group name
    146         ;;355.3|4|4|3|40.03;group number
    147         ;;355.3|5|4|4|40.04;(is) utilization required
    148         ;;355.3|6|4|5|40.05;(is) pre-certification required
    149         ;;355.3|7|4|7|40.07;exclude pre-existing condition
    150         ;;355.3|8|4|8|40.08;benefits assignable
    151         ;;355.3|9|4|9|40.09;type of plan
    152         ;;355.3|12|4|6|40.06;ambulatory care certification
    153         ;;36|2|2|5|20.05;reimburse
    154         ;;36.11|1|3|1|21.01;street address line 1
    155         ;;36.11|2|3|2|21.02;street address line 2
    156         ;;36.11|3|3|3|21.03;street address line 3
    157         ;;36.11|4|3|4|21.04;city
    158         ;;36.11|5|3|5|21.05|S IBZ=$$EXTERNAL^DILFD(36,.115,"",IBZ)|N DIC,X,Y S DIC="^DIC(5,",X=IBZ,DIC(0)="OX" D ^DIC K:+Y<1 IBZ S:+Y>0 IBZ=+Y;state
    159         ;;36.11|6|3|6|21.06;zip code
    160         ;;36.13|1|2|2|20.02;phone number
    161         ;;36.13|2|2|3|20.03;billing phone number
    162         ;;36.13|3|2|4|20.04;precertification phone number
    163         ;;
    164         ;
    165 SEND(IBH,IBX,IBICN,IBRPC)       ; called to send off queries
    166         D EN1^XWB2HL7(.IBH,IBX,IBRPC,"",IBICN)
    167         Q
    168         ;
    169 CHECK(IBR,IBH)  ; called to check the return status of an RPC
    170         D RPCCHK^XWB2HL7(.IBR,IBH)
    171         Q
    172         ;
    173 RETURN(IBR,IBH) ; called to get the return data and clear the broker
    174         N IBZ
    175         D RTNDATA^XWBDRPC(.IBR,IBH),CLEAR^XWBDRPC(.IBZ,IBH)
    176         Q
    177         ;
    178 TASK    ; queue off task job
    179         N ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTSK,ZTSAVE
    180         S ZTRTN="BACKGND^IBCNRDV",ZTDESC="Query Remote Facilities for Insurance",ZTDTH=$$FMADD^XLFDT($$NOW^XLFDT),(ZTIO,ZTSAVE("DFN"),ZTSAVE("IBSAVE*"),ZTSAVE("IBTYPE"))="" D ^%ZTLOAD
    181         Q
    182         ;
    183 TRKR(DFN,IBSAVEI,IBSAVEJ,IBDUZ) ; claims tracking entry
    184         N IBTYPE,IBT
    185         Q:$D(^IBT(356,"ARDV",DFN))  ; have already done recently
    186         Q:'$$TFL^IBARXMU(DFN,.IBT)  ; no remote facilities
    187         S IBTYPE="TRKR" D
    188         . I DUZ=.5 N DUZ S DUZ=+$G(IBDUZ),DUZ(2)=+$$SITE^VASITE
    189         . D TASK
    190         Q
    191         ;
    192 ADM(DFN,IBSAVE1,IBSAVE2,IBSAVE3,IBSAVE4)        ; admit event entry
    193         N IBTYPE S IBTYPE="ADM" D TASK
    194         Q
    195         ;
    196 FILE(IBX)       ; updates data into the log file
    197         ;IBX = number of insurance co's found
    198         N DIC,DA,DIE,IBM,DO,X,Y,IBZ,DR
    199         S IBM=$E($$DT^XLFDT,1,5)_"00",DA=+$O(^IBA(355.34,"B",IBM,0))
    200         I 'DA K DA L +^IBA(355.34,"B",IBM):10 S X=IBM,DIC="^IBA(355.34,",DIC(0)="F" D FILE^DICN S DA=+Y L -^IBA(355.34,"B",IBM)
    201         L +^IBA(355.34,DA):10
    202         S IBZ=^IBA(355.34,DA,0),DIE="^IBA(355.34,"
    203         S DR=".02///"_($P(IBZ,"^",2)+1)_";.03///"_($P(IBZ,"^",3)+IBX) D ^DIE
    204         L -^IBA(355.34,DA)
    205         Q
     1IBCNRDV ;OAKFO/ELZ - INSURANCE INFORMATION EXCHANGE VIA RDV;27-MAR-03
     2 ;;2.0;INTEGRATED BILLING;**214,231,361**;21-MAR-94;Build 9
     3 ;;Per VHA Directive 2004-038, this routine should not be modified.
     4 ;
     5 ; This routine is used to exchange insurance information between
     6 ; facilities.
     7OPT ; Menu option entry point.  This is used to select a patient to request
     8 ; information about from the remote treating facilities.
     9 N DFN,DIC,X,Y,DTOUT,DUOUT,IBT,%,%Y,IBX,VADM,IBB,IBD,IBH,IBI,IBICN,IBR,IBRZ,IBX,IBY,IBZ,IBWAIT,IBL,DO,IBTYPE,IB1
     10 ;
     11 ; prompt for patient
     12AGAIN S DIC="^DPT(",DIC(0)="AEMNQ" D ^DIC Q:Y<1  S DFN=+Y
     13 ;
     14BACKGND ; background/tasked entry point
     15 ; IBTYPE is being used as a flag to indicate this is running in background
     16 ;
     17 ; look up treating facilities
     18 K IBT S IBT=$$TFL^IBARXMU(DFN,.IBT)
     19 I IBT<1,'$D(IBTYPE) W !!,"This patient has no remote treating facilities to query." G AGAIN
     20 I IBT<1 Q
     21 ;
     22 ; display and verify we want to do this
     23 I '$D(IBTYPE) D DEM^VADPT W !!,"The patient ",VADM(1)," has the following ",IBT," remote facilitie(s)",! S IBX=0 F  S IBX=$O(IBT(IBX)) Q:IBX<1  W !?10,$P(IBT(IBX),"^",2)
     24 I '$D(IBTYPE) W !!,"Do you want to perform this Remote Query" S %=1 D YN^DICN G:%'=1 AGAIN
     25 ;
     26 ; get ICN
     27 S IBICN=$$ICN^IBARXMU(DFN) I 'IBICN,'$D(IBTYPE) W !!,"No ICN for this patient" G AGAIN
     28 I 'IBICN Q
     29 ;
     30 ; sent off the remote queries and get back handles
     31 S IBX=0 F  S IBX=$O(IBT(IBX)) Q:IBX<1  D
     32 . D SEND(.IBH,IBX,IBICN,$S($D(IBTYPE):"IBCN INSURANCE QUERY TASK",1:"IBCN INSURANCE QUERY"))
     33 . X $S(IBH(0)'="":"S $P(IBT(IBX),U,5)=IBH(0)",1:"W:'$D(IBTYPE) !,""No handle returned for "",$P(IBT(IBX),U,2) K IBT(IBX)")
     34 ;
     35 ; no handles returned
     36 I $D(IBT)<9,'$D(IBTYPE) W !!,"Unable to perform any remote queries.",! G AGAIN
     37 I $D(IBT)<9 Q
     38 ;
     39 ; go through every IBT()
     40 S IBP="|",IBX=0 F  S IBX=$O(IBT(IBX)) Q:IBX<1!($D(IBT)<9)  D
     41 . ;
     42 . ; do I have a return data.
     43 . F IBWAIT=1:1:60 W:'$D(IBTYPE) "." H 1 D CHECK(.IBR,$P(IBT(IBX),"^",5)) I $G(IBR(0))["Done" Q
     44 . I $G(IBR(0))'["Done" W:'$D(IBTYPE) !!,"Unable to communicate with ",$P(IBT(IBX),U,2) Q
     45 . K IBR
     46 . D RETURN(.IBR,$P(IBT(IBX),"^",5))
     47 . ;
     48 . ; no data returned or error message
     49 . S IBRZ=$S(-1=+$G(IBR):IBR,$G(IBR(0))="":$G(IBR(1)),1:$G(IBR(0)))
     50 . ;
     51 . ; no info to proceed
     52 . I IBRZ<1 W:'$D(IBTYPE) !,"Response from ",$P(IBT(IBX),U,2),!,$P(IBRZ,"^",2) K IBT(IBX) D:IBRZ="-1^No insurance on file" FILE(0) Q
     53 . ;
     54 . ; received insurance info, need to file and display message
     55 . W:'$D(IBTYPE) !,"Received ",$G(IBR(0))," insurance companies from ",$P(IBT(IBX),U,2) D FILE(+IBR(0))
     56 . ;
     57 . S IBY=0 F  S IBY=$O(IBR(IBY))  Q:IBY<1  D
     58 .. F IBL=5:1  S IBT=$P($T(MAP+IBL),";",3) Q:IBT=""  D
     59 ... ;
     60 ... ; am I on the right MAP line
     61 ... I $P(IBT,IBP,3)=$S(IBY#6:IBY#6,1:6) S IBZ=$P(IBR(IBY),"^",$P(IBT,IBP,4)) I $L(IBZ) D
     62 .... ;
     63 .... ; xecute code to change external to internal
     64 .... X:$L($P(IBT,IBP,7)) $P(IBT,IBP,7)
     65 .... ;
     66 .... ; put the info in the array for the buffer file
     67 .... S:$D(IBZ) IBB($P(IBT,IBP,5))=IBZ
     68 .. ;
     69 .. ; need to avoid duplicates if possible.
     70 .. I $G(IBB(20.01))["MEDICARE (WNR)" S X=0 F  S X=$O(^DPT(DFN,.312,X)) Q:X<1  I $P($G(^DIC(36,+$P($G(^DPT(DFN,.312,X,0)),"^"),0)),"^")["MEDICARE (WNR)" K IBB Q
     71 .. Q:'$D(IBB)
     72 .. ;
     73 .. ; file in the buffer file & where else needed
     74 .. I IBY#6=0 D
     75 ... I $L($G(IBB(20.01))) D
     76 .... S IBB(.14)=$$IEN^XUAF4(+IBT(IBX))
     77 .... S IBB=$$ADDSTF^IBCNBES($G(IBB(.03),1),DFN,.IBB)
     78 ... I '$D(IB1),$D(IBTYPE),$L($G(IBB(20.01))) D SCH^IBTUTL2(DFN,$G(IBSAVEI),$G(IBSAVEJ)):IBTYPE="TRKR",ADM^IBTUTL($G(IBSAVE1),$G(IBSAVE2),$G(IBSAVE3),$G(IBSAVE4)):IBTYPE="ADM" S IB1=1
     79 ... W:'$D(IBTYPE)&($L($G(IBB(20.01)))) !,$P($G(IBB),"^")," Buffer File entry for ",$G(IBB(20.01))
     80 ... K IBB
     81 ;
     82 ; flag so I don't do this patient again within 90 days
     83 S ^IBT(356,"ARDV",DFN,$$FMADD^XLFDT(DT,90))=""
     84 ;
     85 Q
     86 ;
     87RPC(IBD,IBICN) ; RPC entry for looking up insurance info
     88 N DFN,IBZ,IBX,IBY,IBP,IBI,IBT,IBZ
     89 S DFN=$$DFN^IBARXMU(IBICN) I 'DFN S IBD(0)="-1^ICN Not found" Q
     90 D ALL^IBCNS1(DFN,"IBY",3)
     91 I '$D(IBY) S IBD(0)="-1^No insurance on file" Q
     92 ; set up return format
     93 ; IBD(0)   = # of insurance companies
     94 S IBD(0)=$G(IBY(0))
     95 ;
     96 ; where n starts at 1 and increments 6 for each insurance company
     97 ; IBD(n) = 355.33, zero node format
     98 ; IBD(n+1) = 355.33, 20 node format
     99 ; IBD(n+2) = 355.33, 21 node format
     100 ; IBD(n+3) = 355.33, 40 node format
     101 ; IBD(n+4) = 355.33, 60 node format
     102 ; IBD(n+5) = 355.33, 61 node format
     103 ;
     104 S IBP="|"
     105 S IBI=0 F  S IBI=$O(IBY(IBI))  Q:IBI<1  F IBL=5:1 S IBT=$P($T(MAP+IBL),";",3) Q:IBT=""  D
     106 . S IBZ=$P($G(IBY(IBI,+IBT)),"^",$P(IBT,IBP,2)) ; set the existing data
     107 . I $L($P(IBT,IBP,6)) X $P(IBT,IBP,6) ; output transform
     108 . S $P(IBD(IBI-1*6+$P(IBT,IBP,3)),"^",$P(IBT,IBP,4))=IBZ ; set data IBD
     109 Q
     110 ;
     111MAP ; this is a mapping of data returned from ALL^IBCNS1 to the buffer file
     112 ; format is:  node number | piece | extract node | extract piece
     113 ;             | 355.33 field number | format out code (if any)
     114 ;             | format in code (if any)
     115 ; the extract nodes will be sequential to match buffer file DD
     116 ;;0|1|2|1|20.01|N Z X "F Z=0,.11,.13 S IBY(IBI,36+Z)=$G(^DIC(36,IBZ,Z))" S IBZ=$P(IBY(IBI,36),"^");ins co name
     117 ;;0|2|5|4|60.04;subscriber id
     118 ;;0|4|5|3|60.03;experation date
     119 ;;0|6|5|5|60.05;who's insurance
     120 ;;0|8|5|2|60.02;effective date
     121 ;;0|16|5|6|60.06;pt relationship to insured
     122 ;;0|17|5|7|60.07;name of insured
     123 ;;0|20|5|12|60.12;coordination of benefits
     124 ;;1|3|1|10|.1||I IBZ<$$FMADD^XLFDT(DT,-180) K IBZ;date (last) verified
     125 ;;1|9|1|3|.03;source of information
     126 ;;2|1|6|5|61.05;send bill to employer
     127 ;;2|2|6|6|61.06;employer claims street address (line 1)
     128 ;;2|3|6|7|61.07;employer claims street address line 2
     129 ;;2|4|6|8|61.08;employer claims street address line 3
     130 ;;2|5|6|9|61.09;employer claims city
     131 ;;2|6|6|10|61.1|S IBZ=$$EXTERNAL^DILFD(2.312,2.06,"",IBZ)|N DIC,X,Y S DIC="^DIC(5,",X=IBZ,DIC(0)="OX" D ^DIC K:+Y<1 IBZ S:+Y>0 IBZ=+Y;employer claims state
     132 ;;2|7|6|11|61.11;employer claims zip code
     133 ;;2|8|6|12|61.12;employer claims phone
     134 ;;2|10|6|1|61.01;esghp
     135 ;;2|11|6|3|61.03;employment status
     136 ;;2|12|6|4|61.04;retirement date
     137 ;;3|1|5|8|60.08;insured's dob
     138 ;;3|5|5|9|60.09;insured's ssn
     139 ;;3|12|5|13|60.13;insured's sex
     140 ;;4|1|5|10|60.1;primary care provider
     141 ;;4|2|5|11|60.11;primary provider phone
     142 ;;355.3|2|4|1|40.01;is this a group policy
     143 ;;355.3|3|4|2|40.02;group name
     144 ;;355.3|4|4|3|40.03;group number
     145 ;;355.3|5|4|4|40.04;(is) utilization required
     146 ;;355.3|6|4|5|40.05;(is) pre-certification required
     147 ;;355.3|7|4|7|40.07;exclude pre-existing condition
     148 ;;355.3|8|4|8|40.08;benefits assignable
     149 ;;355.3|9|4|9|40.09;type of plan
     150 ;;355.3|12|4|6|40.06;ambulatory care certification
     151 ;;36|2|2|5|20.05;reimburse
     152 ;;36.11|1|3|1|21.01;street address line 1
     153 ;;36.11|2|3|2|21.02;street address line 2
     154 ;;36.11|3|3|3|21.03;street address line 3
     155 ;;36.11|4|3|4|21.04;city
     156 ;;36.11|5|3|5|21.05|S IBZ=$$EXTERNAL^DILFD(36,.115,"",IBZ)|N DIC,X,Y S DIC="^DIC(5,",X=IBZ,DIC(0)="OX" D ^DIC K:+Y<1 IBZ S:+Y>0 IBZ=+Y;state
     157 ;;36.11|6|3|6|21.06;zip code
     158 ;;36.13|1|2|2|20.02;phone number
     159 ;;36.13|2|2|3|20.03;billing phone number
     160 ;;36.13|3|2|4|20.04;precertification phone number
     161 ;;
     162 ;
     163SEND(IBH,IBX,IBICN,IBRPC) ; called to send off queries
     164 D EN1^XWB2HL7(.IBH,IBX,IBRPC,"",IBICN)
     165 Q
     166 ;
     167CHECK(IBR,IBH) ; called to check the return status of an RPC
     168 D RPCCHK^XWB2HL7(.IBR,IBH)
     169 Q
     170 ;
     171RETURN(IBR,IBH) ; called to get the return data and clear the broker
     172 N IBZ
     173 D RTNDATA^XWBDRPC(.IBR,IBH),CLEAR^XWBDRPC(.IBZ,IBH)
     174 Q
     175 ;
     176TASK ; queue off task job
     177 N ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTSK,ZTSAVE
     178 S ZTRTN="BACKGND^IBCNRDV",ZTDESC="Query Remote Facilities for Insurance",ZTDTH=$$FMADD^XLFDT($$NOW^XLFDT),(ZTIO,ZTSAVE("DFN"),ZTSAVE("IBSAVE*"),ZTSAVE("IBTYPE"))="" D ^%ZTLOAD
     179 Q
     180 ;
     181TRKR(DFN,IBSAVEI,IBSAVEJ,IBDUZ) ; claims tracking entry
     182 N IBTYPE,IBT
     183 Q:$D(^IBT(356,"ARDV",DFN))  ; have already done recently
     184 Q:'$$TFL^IBARXMU(DFN,.IBT)  ; no remote facilities
     185 S IBTYPE="TRKR" D
     186 . I DUZ=.5 N DUZ S DUZ=+$G(IBDUZ),DUZ(2)=+$$SITE^VASITE
     187 . D TASK
     188 Q
     189 ;
     190ADM(DFN,IBSAVE1,IBSAVE2,IBSAVE3,IBSAVE4) ; admit event entry
     191 N IBTYPE S IBTYPE="ADM" D TASK
     192 Q
     193 ;
     194FILE(IBX) ; updates data into the log file
     195 ;IBX = number of insurance co's found
     196 N DIC,DA,DIE,IBM,DO,X,Y,IBZ,DR
     197 S IBM=$E($$DT^XLFDT,1,5)_"00",DA=+$O(^IBA(355.34,"B",IBM,0))
     198 I 'DA K DA L +^IBA(355.34,"B",IBM):10 S X=IBM,DIC="^IBA(355.34,",DIC(0)="F" D FILE^DICN S DA=+Y L -^IBA(355.34,"B",IBM)
     199 L +^IBA(355.34,DA):10
     200 S IBZ=^IBA(355.34,DA,0),DIE="^IBA(355.34,"
     201 S DR=".02///"_($P(IBZ,"^",2)+1)_";.03///"_($P(IBZ,"^",3)+IBX) D ^DIE
     202 L -^IBA(355.34,DA)
     203 Q

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNS1.m

    r613 r623  
    1 IBCNS1  ;ALB/AAS - INSURANCE MANAGEMENT SUPPORTED FUNCTIONS ;22-JULY-91
    2         ;;2.0;INTEGRATED BILLING;**28,60,52,85,107,51,137,240,371**;21-MAR-94;Build 57
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5 INSURED(DFN,IBINDT)     ; -- Is patient insured
    6         ; --Input  DFN     = patient
    7         ;          IBINDT  = (optional) date insured (default = today)
    8         ; -- Output        = 0 - not insured
    9         ;                  = 1 - insured
    10         ;
    11         N J,X,IBINS S IBINS=0,J=0
    12         I '$G(DFN) G INSQ
    13         I '$G(IBINDT) S IBINDT=DT
    14         F  S J=$O(^DPT(DFN,.312,J)) Q:'J  S X=$G(^(J,0)) S IBINS=$$CHK(X,IBINDT) Q:IBINS
    15 INSQ    Q IBINS
    16         ;
    17 PRE(DFN,IBINDT) ; -- is pre-certification required for patient
    18         N X,Y,J,IBPRE
    19         S IBPRE=0,J=0
    20         S:'$G(IBINDT) IBINDT=DT
    21         F  S J=$O(^DPT(DFN,.312,J)) Q:'J  S X=$G(^(J,0)) I $$CHK(X,IBINDT),$P($G(^IBA(355.3,+$P(X,"^",18),0)),"^",6) S IBPRE=1 Q
    22 PREQ    Q IBPRE
    23         ;
    24 UR(DFN,IBINDT)  ; -- is ur required for patient
    25         N X,Y,J,IBPRE
    26         S IBUR=0,J=0
    27         S:'$G(IBINDT) IBINDT=DT
    28         F  S J=$O(^DPT(DFN,.312,J)) Q:'J  S X=$G(^(J,0)) I $$CHK(X,IBINDT),$P($G(^IBA(355.3,+$P(X,"^",18),0)),"^",5) S IBUR=1 Q
    29 URQ     Q IBUR
    30         ;
    31 CHK(X,Z,Y)      ; -- check one entry for active
    32         ; --  Input   X    = Zeroth node of entry in insurance multiple (2.312)
    33         ;             Z    = date to check
    34         ;             Y    = 2 if want will not reimburse
    35         ;                  = 3 if want will not reimburse AND indemnity plans
    36         ;                  = 4 if want will not reimburse, but only if it's
    37         ;                       MEDICARE
    38         ; --  Output  1    = Insurance Active
    39         ;             0    = Inactive
    40         ;
    41         N Z1,X1
    42         S Z1=0,Y=$G(Y)
    43         I Y'=3,$$INDEM(X) G CHKQ ; is an indemnity policy or company
    44         S X1=$G(^DIC(36,+X,0)) G:X1="" CHKQ ;insurance company entry doesn't exist
    45         I $P(X,"^",8) G:Z<$P(X,"^",8) CHKQ ;effective date later than care
    46         I $P(X,"^",4) G:Z>$P(X,"^",4) CHKQ ;care after expiration date
    47         I $P($G(^IBA(355.3,+$P(X,"^",18),0)),"^",11) G CHKQ ;plan is inactive
    48         G:$P(X1,"^",5) CHKQ ;insurance company inactive
    49         I Y<2 G:$P(X1,"^",2)="N" CHKQ ;insurance company will not reimburse
    50         I Y=4,$P(X1,"^",2)="N",'$$MCRWNR^IBEFUNC(+X) G CHKQ ;only MEDICARE WNR
    51         S Z1=1
    52 CHKQ    Q Z1
    53         ;
    54 ACTIVE(IBCIFN)  ; -- is this company active for this patient for this date
    55         ; -- called from input transform and x-refs for fields 101,102,103
    56         ; -- input
    57         N ACTIVE,DFN,IBINDT
    58         S DFN=$P(^DGCR(399,DA,0),"^",2),IBINDT=$S(+$G(^DGCR(399,DA,"U")):+$G(^("U")),1:DT)
    59         ;
    60 ACTIVEQ Q ACTIVE
    61         ;
    62 DD      ;  - called from input transform and x-refs for field 101,102,103
    63         ;  - input requires da=internal entry number in 399
    64         ;  - outputs IBdd(ins co.) array
    65         N DFN S DFN=$P(^DGCR(399,DA,0),"^",2),IBINDT=$S(+$G(^DGCR(399,DA,"U")):+$G(^("U")),1:DT)
    66         D ALLACT
    67 DDQ     K IBINDT Q
    68         ;
    69         ;
    70 ALLACT  ; -- return active insurance zeroth nodes in ibdd(ins co,entry in mult)
    71         N X,X1
    72         S (X1,IBDD)=0
    73         F  S X1=$O(^DPT(DFN,.312,X1)) Q:'X1  S X=$G(^(X,0)) I $$CHK(X,IBINDT) S IBDD(+X,X1)=X
    74         ;
    75 ALLACTQ Q
    76         ;
    77 HDR     W !?4,"Insurance Co.",?22,"Policy #",?40,"Group",?52,"Holder",?60,"Effective",?70,"Expires" S X="",$P(X,"=",IOM-4)="" W !?4,X
    78         Q
    79         ;
    80         ;
    81 D1      N X Q:'$D(IBINS)
    82         W !?4,$S($D(^DIC(36,+IBINS,0)):$E($P(^(0),"^",1),1,16),1:"UNKNOWN")
    83         W ?22,$E($P(IBINS,"^",2),1,16)
    84         W ?40,$E($$GRP^IBCNS($P(IBINS,"^",18)),1,10)
    85         S X=$P(IBINS,"^",6) W ?52,$S(X="v":"SELF",X="s":"SPOUSE",1:"OTHER")
    86         W ?60,$$DAT1^IBOUTL($P(IBINS,"^",8)),?70,$$DAT1^IBOUTL($P(IBINS,"^",4))
    87         Q
    88         ;
    89 ALL(DFN,VAR,ACT,ADT,SOP)        ; -- find all insurance data on a patient
    90         ;
    91         ; -- input DFN  = patient
    92         ;          VAR  = variable to output in format of abc
    93         ;                 or abc(dfn)
    94         ;                 or ^tmp($j,"Insurance")
    95         ;          ACT  = 1 if only active ins. desired
    96         ;               = 2 if active and will not reimburse desired
    97         ;               = 3 if active, will not reimburse, and indemnity are
    98         ;                 all desired (for the $$INSTYP function below)
    99         ;               = 4 if only active and MEDICARE WNR only desired
    100         ;          ADT  = if ACT=1 or 4, then ADT is the internal date to check
    101         ;                 active for, default = dt
    102         ;          SOP  = if SOP=1, then sort policies in COB order
    103         ;
    104         ; -- output var(0)   =: number of entries insurance multiple
    105         ;           var(x,0) =: ^dpt(dfn,.312,x,0)
    106         ;           var(x,1) =: ^dpt(dfn,.312,x,1)
    107         ;           var(x,2) =: ^dpt(dfn,.312,x,2)
    108         ;           var(x,3) =: ^dpt(dfn,.312,x,3)
    109         ;           var(x,4) =: ^dpt(dfn,.312,x,4)
    110         ;           var(x,5) =: ^dpt(dfn,.312,x,5)
    111         ;       var(x,355.3) =: ^iba(355.3,$p(var(x,0),"^",18),0)
    112         ;       var("S",COB sequence,x) =: (null) as an xref for COB
    113         ;
    114         N X,IBMRA,IBSP
    115         S X=0 I $G(ACT),$E($G(ADT),1,7)'?7N S ADT=DT
    116         S (IBMRA,IBSP)=0 ;Flag to say if pt has medicare wnr, spouse has policy
    117         F  S X=$O(^DPT(DFN,.312,X)) Q:'X  I $D(^(X,0)) D
    118         .I $G(ACT),'$$CHK(^DPT(DFN,.312,X,0),ADT,$G(ACT)) Q
    119         .S @VAR@(0)=$G(@VAR@(0))+1
    120         .S @VAR@(X,0)=$$ZND(DFN,X)
    121         .S @VAR@(X,1)=$G(^DPT(DFN,.312,X,1))
    122         .S @VAR@(X,2)=$G(^DPT(DFN,.312,X,2))
    123         .S @VAR@(X,3)=$G(^DPT(DFN,.312,X,3))
    124         .S @VAR@(X,4)=$G(^DPT(DFN,.312,X,4))
    125         .S @VAR@(X,5)=$G(^DPT(DFN,.312,X,5))
    126         .S @VAR@(X,355.3)=$G(^IBA(355.3,+$P($G(^DPT(DFN,.312,X,0)),"^",18),0))
    127         .I $G(SOP) D
    128         ..N COB,WHO
    129         ..S COB=$P(@VAR@(X,0),U,20)
    130         ..S WHO=$P(@VAR@(X,0),U,6) S:WHO="s" IBSP=1
    131         ..I $$MCRWNR^IBEFUNC(+@VAR@(X,0)) D
    132         ... S COB=.5,IBMRA=1
    133         ...
    134         ..S COB=$S(COB'="":COB,WHO="v":1,WHO="s":$S(IBMRA:1,1:2),1:3)
    135         ..S @VAR@("S",COB,X)=""
    136         ..Q
    137         ; Ck for spouse's insurance, move it before any MEDICARE WNR if sorting
    138         I $G(SOP),IBMRA,IBSP D
    139         . ; Shuffle Medicare WNR, if necessary
    140         . S X=0 F  S X=$O(@VAR@("S",.5,X)) Q:'X  S @VAR@("S",2,X)="" K @VAR@("S",.5,X)
    141         . S X=0 F  S X=$O(@VAR@("S",2,X)) Q:'X  I $P(@VAR@(X,0),U,6)="s",'$P(@VAR@(X,0),U,20) S @VAR@("S",1,X)="" K @VAR@("S",2,X)
    142 ALLQ    Q
    143         ;
    144 ALLWNR(DFN,VAR,ADT)     ; Returns 'all active and MEDICARE WNR'
    145         D ALL(DFN,VAR,4,ADT)
    146         Q
    147         ;
    148 ZND(DFN,NODE)   ; -- set group number and group name back into zeroth node of ins. type
    149         N X,Y S (X,Y)=""
    150         I '$G(DFN)!('$G(NODE)) G ZNDQ
    151         S X=$G(^DPT(+DFN,.312,+NODE,0))
    152         S Y=$G(^IBA(355.3,+$P(X,"^",18),0)) I Y="" G ZNDQ
    153         S $P(X,"^",3)=$P(Y,"^",4) ; move group number
    154         S $P(X,"^",15)=$P(Y,"^",3) ; move group name
    155         ;
    156 ZNDQ    Q X
    157         ;
    158 INDEM(X)        ; -- is this an indemnity plan
    159         ; -- input zeroth node if insurance type field
    160         N IBINDEM,IBCTP
    161         S IBINDEM=1
    162         I $P($G(^DIC(36,+X,0)),"^",13)=15 G INDEMQ ; company is indemnity co.
    163         S IBCTP=$P($G(^IBA(355.3,+$P(X,"^",18),0)),"^",9)
    164         I IBCTP,$P($G(^IBE(355.1,+IBCTP,0)),"^",3)=9 G INDEMQ ; plan is an indemnity plan
    165         S IBINDEM=0
    166 INDEMQ  Q IBINDEM
    167         ;
    168         ;
    169 INSTYP(DFN,DATE)        ; -- return type of insurance policy for patient
    170         ;
    171         ; -- input    dfn := pointer to patient file (required)
    172         ;            date := date of insurance (optional, default = today)
    173         ;
    174         ; -- output   Major Category of type of Plan (file 355.1, field .03)
    175         ;             for policy which would be billed first (cob)
    176         ;               null     no insurance found
    177         ;               1        MAJOR MEDICAL (default)
    178         ;               2        DENTAL
    179         ;               3        HMO
    180         ;               4        PPO
    181         ;               5        MEDICARE
    182         ;               6        MEDICAID
    183         ;               7        TRICARE
    184         ;               8        WORKMANS COMP
    185         ;               9        INDEMNITY
    186         ;              10        PRESCRIPTION
    187         ;              11        MEDICARE SUPPLEMENTAL
    188         ;              12        ALL OTHER
    189         ;
    190         N TYPE,POL,IBCPOL
    191         S TYPE=""
    192         I '$G(DFN) G INSTYPQ
    193         I '$G(DATE) S DATE=DT
    194         D ALL(DFN,"POL",3,DATE)
    195         I $G(POL(0))<1 G INSTYPQ
    196         I $G(POL(0))=1 S IBCPOL=+$O(POL(0))
    197         I $G(POL(0))>1 S IBCPOL=$$COB(.POL)
    198         ;
    199         I IBCPOL S TYPE=$P($G(^IBE(355.1,+$P($G(POL(IBCPOL,355.3)),"^",9),0)),"^",3)
    200         I TYPE="" S TYPE=1 ;default is major medical
    201         ;
    202 INSTYPQ Q TYPE
    203         ;
    204 COB(POL)        ; -- find policy with high coordination of benefits
    205         N I,X,IBC,COB,WHO,IBCOB
    206         ;
    207         S IBC=""
    208         S I=0 F  S I=$O(POL(I)) Q:'I  D
    209         .S WHO=$P($G(POL(I,0)),"^",6),COB=$P($G(POL(I,0)),"^",20)
    210         .S X=$S(COB'="":COB,WHO="v":1,WHO="s":2,1:3)
    211         .I 'IBC S IBC=I,IBCOB=X Q
    212         .I X<IBCOB S IBC=I,IBCOB=X
    213         Q IBC
     1IBCNS1 ;ALB/AAS - INSURANCE MANAGEMENT SUPPORTED FUNCTIONS ;22-JULY-91
     2 ;;2.0;INTEGRATED BILLING;**28,60,52,85,107,51,137,240**;21-MAR-94
     3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
     4 ;
     5INSURED(DFN,IBINDT) ; -- Is patient insured
     6 ; --Input  DFN     = patient
     7 ;          IBINDT  = (optional) date insured (default = today)
     8 ; -- Output        = 0 - not insured
     9 ;                  = 1 - insured
     10 ;
     11 N J,X,IBINS S IBINS=0,J=0
     12 I '$G(DFN) G INSQ
     13 I '$G(IBINDT) S IBINDT=DT
     14 F  S J=$O(^DPT(DFN,.312,J)) Q:'J  S X=$G(^(J,0)) S IBINS=$$CHK(X,IBINDT) Q:IBINS
     15INSQ Q IBINS
     16 ;
     17PRE(DFN,IBINDT) ; -- is pre-certification required for patient
     18 N X,Y,J,IBPRE
     19 S IBPRE=0,J=0
     20 S:'$G(IBINDT) IBINDT=DT
     21 F  S J=$O(^DPT(DFN,.312,J)) Q:'J  S X=$G(^(J,0)) I $$CHK(X,IBINDT),$P($G(^IBA(355.3,+$P(X,"^",18),0)),"^",6) S IBPRE=1 Q
     22PREQ Q IBPRE
     23 ;
     24UR(DFN,IBINDT) ; -- is ur required for patient
     25 N X,Y,J,IBPRE
     26 S IBUR=0,J=0
     27 S:'$G(IBINDT) IBINDT=DT
     28 F  S J=$O(^DPT(DFN,.312,J)) Q:'J  S X=$G(^(J,0)) I $$CHK(X,IBINDT),$P($G(^IBA(355.3,+$P(X,"^",18),0)),"^",5) S IBUR=1 Q
     29URQ Q IBUR
     30 ;
     31CHK(X,Z,Y) ; -- check one entry for active
     32 ; --  Input   X    = Zeroth node of entry in insurance multiple (2.312)
     33 ;             Z    = date to check
     34 ;             Y    = 2 if want will not reimburse
     35 ;                  = 3 if want will not reimburse AND indemnity plans
     36 ;                  = 4 if want will not reimburse, but only if it's
     37 ;                       MEDICARE
     38 ; --  Output  1    = Insurance Active
     39 ;             0    = Inactive
     40 ;
     41 N Z1,X1
     42 S Z1=0,Y=$G(Y)
     43 I Y'=3,$$INDEM(X) G CHKQ ; is an indemnity policy or company
     44 S X1=$G(^DIC(36,+X,0)) G:X1="" CHKQ ;insurance company entry doesn't exist
     45 I $P(X,"^",8) G:Z<$P(X,"^",8) CHKQ ;effective date later than care
     46 I $P(X,"^",4) G:Z>$P(X,"^",4) CHKQ ;care after expiration date
     47 I $P($G(^IBA(355.3,+$P(X,"^",18),0)),"^",11) G CHKQ ;plan is inactive
     48 G:$P(X1,"^",5) CHKQ ;insurance company inactive
     49 I Y<2 G:$P(X1,"^",2)="N" CHKQ ;insurance company will not reimburse
     50 I Y=4,$P(X1,"^",2)="N",'$$MCRWNR^IBEFUNC(+X) G CHKQ ;only MEDICARE WNR
     51 S Z1=1
     52CHKQ Q Z1
     53 ;
     54ACTIVE(IBCIFN) ; -- is this company active for this patient for this date
     55 ; -- called from input transform and x-refs for fields 101,102,103
     56 ; -- input
     57 N ACTIVE,DFN,IBINDT
     58 S DFN=$P(^DGCR(399,DA,0),"^",2),IBINDT=$S(+$G(^DGCR(399,DA,"U")):+$G(^("U")),1:DT)
     59 ;
     60ACTIVEQ Q ACTIVE
     61 ;
     62DD ;  - called from input transform and x-refs for field 101,102,103
     63 ;  - input requires da=internal entry number in 399
     64 ;  - outputs IBdd(ins co.) array
     65 N DFN S DFN=$P(^DGCR(399,DA,0),"^",2),IBINDT=$S(+$G(^DGCR(399,DA,"U")):+$G(^("U")),1:DT)
     66 D ALLACT
     67DDQ K IBINDT Q
     68 ;
     69 ;
     70ALLACT ; -- return active insurance zeroth nodes in ibdd(ins co,entry in mult)
     71 N X,X1
     72 S (X1,IBDD)=0
     73 F  S X1=$O(^DPT(DFN,.312,X1)) Q:'X1  S X=$G(^(X,0)) I $$CHK(X,IBINDT) S IBDD(+X,X1)=X
     74 ;
     75ALLACTQ Q
     76 ;
     77HDR W !?4,"Insurance Co.",?22,"Policy #",?40,"Group",?52,"Holder",?60,"Effective",?70,"Expires" S X="",$P(X,"=",IOM-4)="" W !?4,X
     78 Q
     79 ;
     80 ;
     81D1 N X Q:'$D(IBINS)
     82 W !?4,$S($D(^DIC(36,+IBINS,0)):$E($P(^(0),"^",1),1,16),1:"UNKNOWN")
     83 W ?22,$E($P(IBINS,"^",2),1,16)
     84 W ?40,$E($$GRP^IBCNS($P(IBINS,"^",18)),1,10)
     85 S X=$P(IBINS,"^",6) W ?52,$S(X="v":"SELF",X="s":"SPOUSE",1:"OTHER")
     86 W ?60,$$DAT1^IBOUTL($P(IBINS,"^",8)),?70,$$DAT1^IBOUTL($P(IBINS,"^",4))
     87 Q
     88 ;
     89ALL(DFN,VAR,ACT,ADT,SOP) ; -- find all insurance data on a patient
     90 ;
     91 ; -- input DFN  = patient
     92 ;          VAR  = variable to output in format of abc
     93 ;                 or abc(dfn)
     94 ;                 or ^tmp($j,"Insurance")
     95 ;          ACT  = 1 if only active ins. desired
     96 ;               = 2 if active and will not reimburse desired
     97 ;               = 3 if active, will not reimburse, and indemnity are
     98 ;                 all desired (for the $$INSTYP function below)
     99 ;               = 4 if only active and MEDICARE WNR only desired
     100 ;          ADT  = if ACT=1 or 4, then ADT is the internal date to check
     101 ;                 active for, default = dt
     102 ;          SOP  = if SOP=1, then sort policies in COB order
     103 ;
     104 ; -- output var(0)   =: number of entries insurance multiple
     105 ;           var(x,0) =: ^dpt(dfn,.312,x,0)
     106 ;           var(x,1) =: ^dpt(dfn,.312,x,1)
     107 ;           var(x,2) =: ^dpt(dfn,.312,x,2)
     108 ;           var(x,3) =: ^dpt(dfn,.312,x,3)
     109 ;           var(x,4) =: ^dpt(dfn,.312,x,4)
     110 ;       var(x,355.3) =: ^iba(355.3,$p(var(x,0),"^",18),0)
     111 ;       var("S",COB sequence,x) =: (null) as an xref for COB
     112 ;
     113 N X,IBMRA,IBSP
     114 S X=0 I $G(ACT),$E($G(ADT),1,7)'?7N S ADT=DT
     115 S (IBMRA,IBSP)=0 ;Flag to say if pt has medicare wnr, spouse has policy
     116 F  S X=$O(^DPT(DFN,.312,X)) Q:'X  I $D(^(X,0)) D
     117 .I $G(ACT),'$$CHK(^DPT(DFN,.312,X,0),ADT,$G(ACT)) Q
     118 .S @VAR@(0)=$G(@VAR@(0))+1
     119 .S @VAR@(X,0)=$$ZND(DFN,X)
     120 .S @VAR@(X,1)=$G(^DPT(DFN,.312,X,1))
     121 .S @VAR@(X,2)=$G(^DPT(DFN,.312,X,2))
     122 .S @VAR@(X,3)=$G(^DPT(DFN,.312,X,3))
     123 .S @VAR@(X,4)=$G(^DPT(DFN,.312,X,4))
     124 .S @VAR@(X,355.3)=$G(^IBA(355.3,+$P($G(^DPT(DFN,.312,X,0)),"^",18),0))
     125 .I $G(SOP) D
     126 ..N COB,WHO
     127 ..S COB=$P(@VAR@(X,0),U,20)
     128 ..S WHO=$P(@VAR@(X,0),U,6) S:WHO="s" IBSP=1
     129 ..I $$MCRWNR^IBEFUNC(+@VAR@(X,0)) D
     130 ... S COB=.5,IBMRA=1
     131 ...
     132 ..S COB=$S(COB'="":COB,WHO="v":1,WHO="s":$S(IBMRA:1,1:2),1:3)
     133 ..S @VAR@("S",COB,X)=""
     134 ..Q
     135 ; Ck for spouse's insurance, move it before any MEDICARE WNR if sorting
     136 I $G(SOP),IBMRA,IBSP D
     137 . ; Shuffle Medicare WNR, if necessary
     138 . S X=0 F  S X=$O(@VAR@("S",.5,X)) Q:'X  S @VAR@("S",2,X)="" K @VAR@("S",.5,X)
     139 . S X=0 F  S X=$O(@VAR@("S",2,X)) Q:'X  I $P(@VAR@(X,0),U,6)="s",'$P(@VAR@(X,0),U,20) S @VAR@("S",1,X)="" K @VAR@("S",2,X)
     140ALLQ Q
     141 ;
     142ALLWNR(DFN,VAR,ADT) ; Returns 'all active and MEDICARE WNR'
     143 D ALL(DFN,VAR,4,ADT)
     144 Q
     145 ;
     146ZND(DFN,NODE) ; -- set group number and group name back into zeroth node of ins. type
     147 N X,Y S (X,Y)=""
     148 I '$G(DFN)!('$G(NODE)) G ZNDQ
     149 S X=$G(^DPT(+DFN,.312,+NODE,0))
     150 S Y=$G(^IBA(355.3,+$P(X,"^",18),0)) I Y="" G ZNDQ
     151 S $P(X,"^",3)=$P(Y,"^",4) ; move group number
     152 S $P(X,"^",15)=$P(Y,"^",3) ; move group name
     153 ;
     154ZNDQ Q X
     155 ;
     156INDEM(X) ; -- is this an indemnity plan
     157 ; -- input zeroth node if insurance type field
     158 N IBINDEM,IBCTP
     159 S IBINDEM=1
     160 I $P($G(^DIC(36,+X,0)),"^",13)=15 G INDEMQ ; company is indemnity co.
     161 S IBCTP=$P($G(^IBA(355.3,+$P(X,"^",18),0)),"^",9)
     162 I IBCTP,$P($G(^IBE(355.1,+IBCTP,0)),"^",3)=9 G INDEMQ ; plan is an indemnity plan
     163 S IBINDEM=0
     164INDEMQ Q IBINDEM
     165 ;
     166 ;
     167INSTYP(DFN,DATE) ; -- return type of insurance policy for patient
     168 ;
     169 ; -- input    dfn := pointer to patient file (required)
     170 ;            date := date of insurance (optional, default = today)
     171 ;
     172 ; -- output   Major Category of type of Plan (file 355.1, field .03)
     173 ;             for policy which would be billed first (cob)
     174 ;               null     no insurance found
     175 ;               1        MAJOR MEDICAL (default)
     176 ;               2        DENTAL
     177 ;               3        HMO
     178 ;               4        PPO
     179 ;               5        MEDICARE
     180 ;               6        MEDICAID
     181 ;               7        TRICARE
     182 ;               8        WORKMANS COMP
     183 ;               9        INDEMNITY
     184 ;              10        PRESCRIPTION
     185 ;              11        MEDICARE SUPPLEMENTAL
     186 ;              12        ALL OTHER
     187 ;
     188 N TYPE,POL,IBCPOL
     189 S TYPE=""
     190 I '$G(DFN) G INSTYPQ
     191 I '$G(DATE) S DATE=DT
     192 D ALL(DFN,"POL",3,DATE)
     193 I $G(POL(0))<1 G INSTYPQ
     194 I $G(POL(0))=1 S IBCPOL=+$O(POL(0))
     195 I $G(POL(0))>1 S IBCPOL=$$COB(.POL)
     196 ;
     197 I IBCPOL S TYPE=$P($G(^IBE(355.1,+$P($G(POL(IBCPOL,355.3)),"^",9),0)),"^",3)
     198 I TYPE="" S TYPE=1 ;default is major medical
     199 ;
     200INSTYPQ Q TYPE
     201 ;
     202COB(POL) ; -- find policy with high coordination of benefits
     203 N I,X,IBC,COB,WHO,IBCOB
     204 ;
     205 S IBC=""
     206 S I=0 F  S I=$O(POL(I)) Q:'I  D
     207 .S WHO=$P($G(POL(I,0)),"^",6),COB=$P($G(POL(I,0)),"^",20)
     208 .S X=$S(COB'="":COB,WHO="v":1,WHO="s":2,1:3)
     209 .I 'IBC S IBC=I,IBCOB=X Q
     210 .I X<IBCOB S IBC=I,IBCOB=X
     211 Q IBC

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSC.m

    r613 r623  
    1 IBCNSC  ;ALB/NLR - INSURANCE COMPANY EDIT ;6/1/05 9:42am
    2         ;;2.0;INTEGRATED BILLING;**46,137,184,276,320,371**;21-MAR-94;Build 57
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5         ;also used for IA #4694
    6         ;
    7 EN      ; -- main entry point for IBCNS INSURANCE COMPANY, IBCNS VIEW INS CO
    8         NEW IB1ST
    9         K IBFASTXT,VALMQUIT,VALMEVL,XQORS,^TMP("XQORS",$J),IBCNS
    10         S IBCHANGE="OKAY"
    11         I '$G(IBVIEW) D EN^VALM("IBCNS INSURANCE COMPANY") G ENQ
    12         D EN^VALM("IBCNS VIEW INS CO")
    13 ENQ     Q
    14         ;
    15 HDR     ; -- header code
    16         S VALMHDR(1)="Insurance Company Information for: "_$E($P(^DIC(36,IBCNS,0),"^"),1,30)
    17         S VALMHDR(2)="Type of Company: "_$E($P($G(^IBE(355.2,+$P($G(^DIC(36,+IBCNS,0)),"^",13),0)),"^"),1,20)_"                     Currently "_$S(+($P($G(^DIC(36,+IBCNS,0)),"^",5)):"Inactive",1:"Active")
    18         Q
    19         ;
    20 INIT    ; -- init variables and list array
    21         K VALMQUIT
    22         S VALMCNT=0,VALMBG=1
    23         I '$D(IBCNS) D INSCO Q:$D(VALMQUIT)
    24         D BLD,HDR
    25         Q
    26 BLD     ; -- list builder
    27         NEW BLNKI
    28         K ^TMP("IBCNSC",$J)
    29         D KILL^VALM10()    ; delete all video attributes
    30         F BLNKI=1:1:54 D BLANK(.BLNKI)     ; 54 blank lines to start with
    31         D PARAM^IBCNSC01      ; billing parameters
    32         D MAIN^IBCNSC01       ; main mailing address
    33         D CLAIMS1^IBCNSC0     ; inpatient claims office
    34         D CLAIMS2^IBCNSC0     ; outpatient claims office
    35         D PRESCR^IBCNSC1      ; prescription claims office
    36         D APPEALS             ; appeals office
    37         D INQUIRY             ; inquiry office
    38         D DISP^IBCNSC02       ; parent/child associations (ESG 11/3/05)
    39         D PROVID^IBCNSC1      ; provider IDs
    40         D PAYER^IBCNSC01      ; payer/payer apps (ESG 7/29/02 IIV project)
    41         D REMARKS^IBCNSC01    ; remarks
    42         D SYN^IBCNSC01        ; synonyms
    43         S VALMCNT=+$O(^TMP("IBCNSC",$J,""),-1)
    44         Q
    45         ;
    46 APPEALS ;
    47         N OFFSET,START,IBCNS14,IBADD
    48         S IBCNS14=$$ADDRESS^IBCNSC0(IBCNS,.14,7)
    49         S START=48,OFFSET=2
    50         D SET^IBCNSP(START,OFFSET+25," Appeals Office Information ",IORVON,IORVOFF)
    51         D SET^IBCNSP(START+1,OFFSET," Company Name: "_$P($G(^DIC(36,+$P(IBCNS14,"^",7),0)),"^",1))
    52         D SET^IBCNSP(START+2,OFFSET,"       Street: "_$P(IBCNS14,"^",1))
    53         D SET^IBCNSP(START+3,OFFSET,"     Street 2: "_$P(IBCNS14,"^",2))
    54         N OFFSET S OFFSET=45
    55         D SET^IBCNSP(START+1,OFFSET,"     Street 3: "_$P(IBCNS14,"^",3)) S IBADD=1
    56         D SET^IBCNSP(START+1+IBADD,OFFSET,"   City/State: "_$E($P(IBCNS14,"^",4),1,15)_$S($P(IBCNS14,"^",4)="":"",1:", ")_$P($G(^DIC(5,+$P(IBCNS14,"^",5),0)),"^",2)_" "_$E($P(IBCNS14,"^",6),1,5))
    57         D SET^IBCNSP(START+2+IBADD,OFFSET,"        Phone: "_$P(IBCNS14,"^",8))
    58         D SET^IBCNSP(START+3+IBADD,OFFSET,"          Fax: "_$P(IBCNS14,"^",9))
    59         Q
    60         ;
    61 INQUIRY ;
    62         ;
    63         N OFFSET,START,IBCNS15,IBADD
    64         S IBCNS15=$$ADDRESS^IBCNSC0(IBCNS,.15,8)
    65         S START=55,OFFSET=2
    66         D SET^IBCNSP(START,OFFSET+25," Inquiry Office Information ",IORVON,IORVOFF)
    67         D SET^IBCNSP(START+1,OFFSET," Company Name: "_$P($G(^DIC(36,+$P(IBCNS15,"^",7),0)),"^",1))
    68         D SET^IBCNSP(START+2,OFFSET,"       Street: "_$P(IBCNS15,"^"))
    69         D SET^IBCNSP(START+3,OFFSET,"     Street 2: "_$P(IBCNS15,"^",2))
    70         N OFFSET S OFFSET=45
    71         D SET^IBCNSP(START+1,OFFSET,"     Street 3: "_$P(IBCNS15,"^",3)) S IBADD=1
    72         D SET^IBCNSP(START+1+IBADD,OFFSET,"   City/State: "_$E($P(IBCNS15,"^",4),1,15)_$S($P(IBCNS15,"^",4)="":"",1:", ")_$P($G(^DIC(5,+$P(IBCNS15,"^",5),0)),"^",2)_" "_$E($P(IBCNS15,"^",6),1,5))
    73         D SET^IBCNSP(START+2+IBADD,OFFSET,"        Phone: "_$P(IBCNS15,"^",8))
    74         D SET^IBCNSP(START+3+IBADD,OFFSET,"          Fax: "_$P(IBCNS15,"^",9))
    75         Q
    76         ;
    77 HELP    ; -- help code
    78         S X="?" D DISP^XQORM1 W !!
    79         Q
    80         ;
    81 EXIT    ; -- exit code
    82         K VALMQUIT,IBCNS,IBCHANGE,IBFASTXT
    83         D CLEAN^VALM10
    84         Q
    85         ;
    86 INSCO   ; -- select insurance company
    87         NEW DLAYGO,DIC,X,Y,DTOUT,DUOUT
    88         I '$D(IBCNS) D  G:$D(VALMQUIT) INSCOQ
    89         .S DIC="^DIC(36,",DIC(0)="AEQMZ",DIC("S")="I '$G(^(5))"
    90         .I '$G(IBVIEW) S DLAYGO=36,DIC(0)=DIC(0)_"L"
    91         .D ^DIC K DIC
    92         .S IBCNS=+Y
    93         I $G(IBCNS)<1 K IBCNS S VALMQUIT="" G INSCOQ
    94 INSCOQ  ;
    95         K DIC
    96         Q
    97         ;
    98 BLANK(LINE)     ; -- Build blank line
    99         D SET^VALM10(.LINE,$J("",80))
    100         Q
    101         ;
    102 EDIKEY()        ; input transform code to determine if user is allowed to edit
    103         ; certain fields in the insurance company file
    104         NEW OK S OK=0
    105         I $$KCHK^XUSRB("IB EDI INSURANCE EDIT") S OK=1 G EDIKEYX
    106         D EN^DDIOL("You must hold the IB EDI INSURANCE EDIT security key to edit this field.",,"!!")
    107         D EN^DDIOL("",,"!!?5")
    108 EDIKEYX ;
    109         Q OK
    110         ;
    111 DUPQUAL(IBCNS,QUAL,FIELD)       ; input transform to make sure that the sam qualifier is not used twice for
    112         ; payer secondary IDs.  There are two sets of fields in file 36 that can not be duplicated.
    113         ; 6.01 EDI INST SECONDARY ID QUAL(1) can not be the same as 6.03 EDI INST SECONDARY ID QUAL(2)
    114         ; 6.05 EDI PROF SECONDARY ID QUAL(1) can not be the same as 6.07 EDI PROF SECONDARY ID QUAL(2)
    115         ;
    116         ; Input:
    117         ; IBCNS is the insurance company internal number
    118         ; QUAL  is the internal code of the value being input.
    119         ; FIELD is the field it is being compare with.
    120         ;
    121         ; Returns:
    122         ; TRUE/1 if they are the same (duplicate)
    123         ; FALSE/0 if they are not
    124         ;
    125         Q:$G(QUAL)="" 0  ; should not happen because this is invoked as an input transform
    126         Q:'+$G(IBCNS) 1  ; stop from editing through fileman
    127         N DUP
    128         S DUP=$$GET1^DIQ(36,+$G(IBCNS)_",",+$G(FIELD),"I")
    129         D CLEAN^DILF
    130         Q QUAL=DUP
     1IBCNSC ;ALB/NLR - INSURANCE COMPANY EDIT ; 6/1/05 9:42am
     2 ;;2.0;INTEGRATED BILLING;**46,137,184,276,320**;21-MAR-94
     3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
     4 ;
     5 ;also used for IA #4694
     6 ;
     7EN ; -- main entry point for IBCNS INSURANCE COMPANY, IBCNS VIEW INS CO
     8 NEW IB1ST
     9 K IBFASTXT,VALMQUIT,VALMEVL,XQORS,^TMP("XQORS",$J),IBCNS
     10 S IBCHANGE="OKAY"
     11 I '$G(IBVIEW) D EN^VALM("IBCNS INSURANCE COMPANY") G ENQ
     12 D EN^VALM("IBCNS VIEW INS CO")
     13ENQ Q
     14 ;
     15HDR ; -- header code
     16 S VALMHDR(1)="Insurance Company Information for: "_$E($P(^DIC(36,IBCNS,0),"^"),1,30)
     17 S VALMHDR(2)="Type of Company: "_$E($P($G(^IBE(355.2,+$P($G(^DIC(36,+IBCNS,0)),"^",13),0)),"^"),1,20)_"                     Currently "_$S(+($P($G(^DIC(36,+IBCNS,0)),"^",5)):"Inactive",1:"Active")
     18 Q
     19 ;
     20INIT ; -- init variables and list array
     21 K VALMQUIT
     22 S VALMCNT=0,VALMBG=1
     23 I '$D(IBCNS) D INSCO Q:$D(VALMQUIT)
     24 D BLD,HDR
     25 Q
     26BLD ; -- list builder
     27 NEW BLNKI
     28 K ^TMP("IBCNSC",$J)
     29 D KILL^VALM10()    ; delete all video attributes
     30 F BLNKI=1:1:54 D BLANK(.BLNKI)     ; 54 blank lines to start with
     31 D PARAM^IBCNSC01      ; billing parameters
     32 D MAIN^IBCNSC01       ; main mailing address
     33 D CLAIMS1^IBCNSC0     ; inpatient claims office
     34 D CLAIMS2^IBCNSC0     ; outpatient claims office
     35 D PRESCR^IBCNSC1      ; prescription claims office
     36 D APPEALS             ; appeals office
     37 D INQUIRY             ; inquiry office
     38 D DISP^IBCNSC02       ; parent/child associations (ESG 11/3/05)
     39 D PROVID^IBCNSC1      ; provider IDs
     40 D PAYER^IBCNSC01      ; payer/payer apps (ESG 7/29/02 IIV project)
     41 D REMARKS^IBCNSC01    ; remarks
     42 D SYN^IBCNSC01        ; synonyms
     43 S VALMCNT=+$O(^TMP("IBCNSC",$J,""),-1)
     44 Q
     45 ;
     46APPEALS ;
     47 N OFFSET,START,IBCNS14,IBADD
     48 S IBCNS14=$$ADDRESS^IBCNSC0(IBCNS,.14,7)
     49 S START=40,OFFSET=2
     50 D SET^IBCNSP(START,OFFSET+25," Appeals Office Information ",IORVON,IORVOFF)
     51 D SET^IBCNSP(START+1,OFFSET," Company Name: "_$P($G(^DIC(36,+$P(IBCNS14,"^",7),0)),"^",1))
     52 D SET^IBCNSP(START+2,OFFSET,"       Street: "_$P(IBCNS14,"^",1))
     53 D SET^IBCNSP(START+3,OFFSET,"     Street 2: "_$P(IBCNS14,"^",2))
     54 N OFFSET S OFFSET=45
     55 D SET^IBCNSP(START+1,OFFSET,"     Street 3: "_$P(IBCNS14,"^",3)) S IBADD=1
     56 D SET^IBCNSP(START+1+IBADD,OFFSET,"   City/State: "_$E($P(IBCNS14,"^",4),1,15)_$S($P(IBCNS14,"^",4)="":"",1:", ")_$P($G(^DIC(5,+$P(IBCNS14,"^",5),0)),"^",2)_" "_$E($P(IBCNS14,"^",6),1,5))
     57 D SET^IBCNSP(START+2+IBADD,OFFSET,"        Phone: "_$P(IBCNS14,"^",8))
     58 D SET^IBCNSP(START+3+IBADD,OFFSET,"          Fax: "_$P(IBCNS14,"^",9))
     59 Q
     60 ;
     61INQUIRY ;
     62 ;
     63 N OFFSET,START,IBCNS15,IBADD
     64 S IBCNS15=$$ADDRESS^IBCNSC0(IBCNS,.15,8)
     65 S START=47,OFFSET=2
     66 D SET^IBCNSP(START,OFFSET+25," Inquiry Office Information ",IORVON,IORVOFF)
     67 D SET^IBCNSP(START+1,OFFSET," Company Name: "_$P($G(^DIC(36,+$P(IBCNS15,"^",7),0)),"^",1))
     68 D SET^IBCNSP(START+2,OFFSET,"       Street: "_$P(IBCNS15,"^"))
     69 D SET^IBCNSP(START+3,OFFSET,"     Street 2: "_$P(IBCNS15,"^",2))
     70 N OFFSET S OFFSET=45
     71 D SET^IBCNSP(START+1,OFFSET,"     Street 3: "_$P(IBCNS15,"^",3)) S IBADD=1
     72 D SET^IBCNSP(START+1+IBADD,OFFSET,"   City/State: "_$E($P(IBCNS15,"^",4),1,15)_$S($P(IBCNS15,"^",4)="":"",1:", ")_$P($G(^DIC(5,+$P(IBCNS15,"^",5),0)),"^",2)_" "_$E($P(IBCNS15,"^",6),1,5))
     73 D SET^IBCNSP(START+2+IBADD,OFFSET,"        Phone: "_$P(IBCNS15,"^",8))
     74 D SET^IBCNSP(START+3+IBADD,OFFSET,"          Fax: "_$P(IBCNS15,"^",9))
     75 Q
     76 ;
     77HELP ; -- help code
     78 S X="?" D DISP^XQORM1 W !!
     79 Q
     80 ;
     81EXIT ; -- exit code
     82 K VALMQUIT,IBCNS,IBCHANGE,IBFASTXT
     83 D CLEAN^VALM10
     84 Q
     85 ;
     86INSCO ; -- select insurance company
     87 NEW DLAYGO,DIC,X,Y,DTOUT,DUOUT
     88 I '$D(IBCNS) D  G:$D(VALMQUIT) INSCOQ
     89 .S DIC="^DIC(36,",DIC(0)="AEQMZ",DIC("S")="I '$G(^(5))"
     90 .I '$G(IBVIEW) S DLAYGO=36,DIC(0)=DIC(0)_"L"
     91 .D ^DIC K DIC
     92 .S IBCNS=+Y
     93 I $G(IBCNS)<1 K IBCNS S VALMQUIT="" G INSCOQ
     94INSCOQ ;
     95 K DIC
     96 Q
     97 ;
     98BLANK(LINE) ; -- Build blank line
     99 D SET^VALM10(.LINE,$J("",80))
     100 Q
     101 ;
     102EDIKEY() ; input transform code to determine if user is allowed to edit
     103 ; certain fields in the insurance company file
     104 NEW OK S OK=0
     105 I $$KCHK^XUSRB("IB EDI INSURANCE EDIT") S OK=1 G EDIKEYX
     106 D EN^DDIOL("You must hold the IB EDI INSURANCE EDIT security key to edit this field.",,"!!")
     107 D EN^DDIOL("",,"!!?5")
     108EDIKEYX ;
     109 Q OK
     110 ;

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSC0.m

    r613 r623  
    1 IBCNSC0 ;ALB/NLR - INSURANCE COMPANY EDIT -  ;12-MAR-1993
    2         ;;2.0; INTEGRATED BILLING ;**371**; 21-MAR-94;Build 57
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5 CLAIMS1 ; display Inpatient Claims information
    6         N OFFSET,START,IBCNS12,IBADD
    7         S START=27,OFFSET=2
    8         D SET^IBCNSP(START,OFFSET+20," Inpatient Claims Office Information ",IORVON,IORVOFF)
    9         S IBCNS12=$$ADDRESS(IBCNS,.12,5)
    10         D SET^IBCNSP(START+1,OFFSET," Company Name: "_$P($G(^DIC(36,+$P(IBCNS12,"^",7),0)),"^",1))
    11         D SET^IBCNSP(START+2,OFFSET,"       Street: "_$P(IBCNS12,"^",1))
    12         D SET^IBCNSP(START+3,OFFSET,"     Street 2: "_$P(IBCNS12,"^",2))
    13         N OFFSET S OFFSET=45
    14         D SET^IBCNSP(START+1,OFFSET,"     Street 3: "_$P(IBCNS12,"^",3)) S IBADD=1
    15         D SET^IBCNSP(START+1+IBADD,OFFSET,"   City/State: "_$E($P(IBCNS12,"^",4),1,15)_$S($P(IBCNS12,"^",4)="":"",1:", ")_$P($G(^DIC(5,+$P(IBCNS12,"^",5),0)),"^",2)_" "_$E($P(IBCNS12,"^",6),1,5))
    16         D SET^IBCNSP(START+2+IBADD,OFFSET,"        Phone: "_$P(IBCNS12,"^",8))
    17         D SET^IBCNSP(START+3+IBADD,OFFSET,"          Fax: "_$P(IBCNS12,"^",9))
    18         Q
    19         ;
    20 R1Q     Q
    21 CLAIMS2 ; display Outpatient Claims information
    22         ;
    23         N OFFSET,START,IBCNS16,IBADD
    24         S START=34,OFFSET=2
    25         D SET^IBCNSP(START,OFFSET+20," Outpatient Claims Office Information ",IORVON,IORVOFF)
    26         S IBCNS16=$$ADDRESS(IBCNS,.16,6)
    27         D SET^IBCNSP(START+1,OFFSET," Company Name: "_$P($G(^DIC(36,+$P(IBCNS16,"^",7),0)),"^",1))
    28         D SET^IBCNSP(START+2,OFFSET,"       Street: "_$P(IBCNS16,"^",1))
    29         D SET^IBCNSP(START+3,OFFSET,"     Street 2: "_$P(IBCNS16,"^",2))
    30         N OFFSET S OFFSET=45
    31         D SET^IBCNSP(START+1,OFFSET,"     Street 3: "_$P(IBCNS16,"^",3)) S IBADD=1
    32         D SET^IBCNSP(START+1+IBADD,OFFSET,"   City/State: "_$E($P(IBCNS16,"^",4),1,15)_$S($P(IBCNS16,"^",4)="":"",1:", ")_$P($G(^DIC(5,+$P(IBCNS16,"^",5),0)),"^",2)_" "_$E($P(IBCNS16,"^",6),1,5))
    33         D SET^IBCNSP(START+2+IBADD,OFFSET,"        Phone: "_$P(IBCNS16,"^",8))
    34         D SET^IBCNSP(START+3+IBADD,OFFSET,"          Fax: "_$P(IBCNS16,"^",9))
    35         Q
    36         ;
    37 ADDRESS(INS,NODE,PH)    ; -- generic find address
    38         ;
    39         N IBX,INSSAVE,IBPH,IBFX,IBCNT,IBA
    40         S IBX="" ;S IBPH="",IBFX="",IBA=""
    41         ;
    42 REDO    ; gather insurance carrier's main address information
    43         S IBX=$G(^DIC(36,+INS,.11)),IBPH=$P($G(^DIC(36,+INS,.13)),"^",1),IBFX=$P(IBX,"^",9)
    44         ;S IBCNT=$G(IBCNT)+1
    45         ;
    46         ; -- if process the same co. more than once you are in an infinite loop
    47         ;I $D(IBCNT(IBCNS)) G ADDREQ
    48         ;S IBCNT(IBCNS)=""
    49         ;
    50         ; -- gather address information from specific office (Claims, Appeals, Inquiry)
    51         ;
    52         I $P($G(^DIC(36,+INS,+NODE)),"^",5) S IBX=$G(^DIC(36,+INS,+NODE)),IBPH=$P($G(^DIC(36,+INS,.13)),"^",PH),IBFX=$P($G(IBX),"^",9)
    53         I $P($G(^DIC(36,+INS,+NODE)),"^",7) S INSSAVE=INS,INS=$P($G(^DIC(36,+INS,+NODE)),"^",7) I INSSAVE'=INS G REDO
    54         ;
    55 ADDRESQ ; concatenate company name, address, phone and fax
    56         S $P(IBA,"^",1,6)=$P($G(IBX),"^",1,6)
    57         S $P(IBA,"^",7)=INS
    58         S $P(IBA,"^",8)=IBPH
    59         S $P(IBA,"^",9)=IBFX
    60 ADDREQ  Q IBA
     1IBCNSC0 ;ALB/NLR - INSURANCE COMPANY EDIT -  ; 12-MAR-1993
     2 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
     3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
     4 ;
     5CLAIMS1 ; display Inpatient Claims information
     6 N OFFSET,START,IBCNS12,IBADD
     7 S START=21,OFFSET=2
     8 D SET^IBCNSP(START,OFFSET+20," Inpatient Claims Office Information ",IORVON,IORVOFF)
     9 S IBCNS12=$$ADDRESS(IBCNS,.12,5)
     10 D SET^IBCNSP(START+1,OFFSET," Company Name: "_$P($G(^DIC(36,+$P(IBCNS12,"^",7),0)),"^",1))
     11 D SET^IBCNSP(START+2,OFFSET,"       Street: "_$P(IBCNS12,"^",1))
     12 D SET^IBCNSP(START+3,OFFSET,"     Street 2: "_$P(IBCNS12,"^",2))
     13 N OFFSET S OFFSET=45
     14 D SET^IBCNSP(START+1,OFFSET,"     Street 3: "_$P(IBCNS12,"^",3)) S IBADD=1
     15 D SET^IBCNSP(START+1+IBADD,OFFSET,"   City/State: "_$E($P(IBCNS12,"^",4),1,15)_$S($P(IBCNS12,"^",4)="":"",1:", ")_$P($G(^DIC(5,+$P(IBCNS12,"^",5),0)),"^",2)_" "_$E($P(IBCNS12,"^",6),1,5))
     16 D SET^IBCNSP(START+2+IBADD,OFFSET,"        Phone: "_$P(IBCNS12,"^",8))
     17 D SET^IBCNSP(START+3+IBADD,OFFSET,"          Fax: "_$P(IBCNS12,"^",9))
     18 Q
     19 ;
     20R1Q Q
     21CLAIMS2 ; display Outpatient Claims information
     22 ;
     23 N OFFSET,START,IBCNS16,IBADD
     24 S START=27,OFFSET=2
     25 D SET^IBCNSP(START,OFFSET+20," Outpatient Claims Office Information ",IORVON,IORVOFF)
     26 S IBCNS16=$$ADDRESS(IBCNS,.16,6)
     27 D SET^IBCNSP(START+1,OFFSET," Company Name: "_$P($G(^DIC(36,+$P(IBCNS16,"^",7),0)),"^",1))
     28 D SET^IBCNSP(START+2,OFFSET,"       Street: "_$P(IBCNS16,"^",1))
     29 D SET^IBCNSP(START+3,OFFSET,"     Street 2: "_$P(IBCNS16,"^",2))
     30 N OFFSET S OFFSET=45
     31 D SET^IBCNSP(START+1,OFFSET,"     Street 3: "_$P(IBCNS16,"^",3)) S IBADD=1
     32 D SET^IBCNSP(START+1+IBADD,OFFSET,"   City/State: "_$E($P(IBCNS16,"^",4),1,15)_$S($P(IBCNS16,"^",4)="":"",1:", ")_$P($G(^DIC(5,+$P(IBCNS16,"^",5),0)),"^",2)_" "_$E($P(IBCNS16,"^",6),1,5))
     33 D SET^IBCNSP(START+2+IBADD,OFFSET,"        Phone: "_$P(IBCNS16,"^",8))
     34 D SET^IBCNSP(START+3+IBADD,OFFSET,"          Fax: "_$P(IBCNS16,"^",9))
     35 Q
     36 ;
     37ADDRESS(INS,NODE,PH) ; -- generic find address
     38 ;
     39 N IBX,INSSAVE,IBPH,IBFX,IBCNT,IBA
     40 S IBX="" ;S IBPH="",IBFX="",IBA=""
     41 ;
     42REDO ; gather insurance carrier's main address information
     43 S IBX=$G(^DIC(36,+INS,.11)),IBPH=$P($G(^DIC(36,+INS,.13)),"^",1),IBFX=$P(IBX,"^",9)
     44 ;S IBCNT=$G(IBCNT)+1
     45 ;
     46 ; -- if process the same co. more than once you are in an infinite loop
     47 ;I $D(IBCNT(IBCNS)) G ADDREQ
     48 ;S IBCNT(IBCNS)=""
     49 ;
     50 ; -- gather address information from specific office (Claims, Appeals, Inquiry)
     51 ;
     52 I $P($G(^DIC(36,+INS,+NODE)),"^",5) S IBX=$G(^DIC(36,+INS,+NODE)),IBPH=$P($G(^DIC(36,+INS,.13)),"^",PH),IBFX=$P($G(IBX),"^",9)
     53 I $P($G(^DIC(36,+INS,+NODE)),"^",7) S INSSAVE=INS,INS=$P($G(^DIC(36,+INS,+NODE)),"^",7) I INSSAVE'=INS G REDO
     54 ;
     55ADDRESQ ; concatenate company name, address, phone and fax
     56 S $P(IBA,"^",1,6)=$P($G(IBX),"^",1,6)
     57 S $P(IBA,"^",7)=INS
     58 S $P(IBA,"^",8)=IBPH
     59 S $P(IBA,"^",9)=IBFX
     60ADDREQ Q IBA

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSC01.m

    r613 r623  
    1 IBCNSC01        ;ALB/NLR - INSURANCE COMPANY EDIT ;6/1/05 10:06am
    2         ;;2.0;INTEGRATED BILLING;**52,137,191,184,232,320,349,371**;21-MAR-94;Build 57
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5 PARAM   ; -- Insurance company parameters region
    6         N OFFSET,START,IBCNS0,IBCNS03,IBCNS06,IBCNS08,IBCNS13,IBCNS3
    7         S IBCNS0=$G(^DIC(36,+IBCNS,0)),IBCNS3=$G(^(3))
    8         S IBCNS03=$P(IBCNS0,"^",3),IBCNS06=$P(IBCNS0,"^",6),IBCNS08=$P(IBCNS0,"^",8)
    9         S IBCNS13=$G(^DIC(36,+IBCNS,.13))
    10         S START=1,OFFSET=2
    11         D SET^IBCNSP(START,OFFSET+25," Billing Parameters ",IORVON,IORVOFF)
    12         ;
    13         D SET^IBCNSP(START+1,OFFSET+1,"Signature Required?: "_$S(+IBCNS03:"YES",1:"NO"))
    14         D SET^IBCNSP(START+2,OFFSET+10,"Reimburse?: "_$E($$EXPAND^IBTRE(36,1,$P(IBCNS0,"^",2)),1,21))
    15         D SET^IBCNSP(START+3,OFFSET+3,"Mult. Bedsections: "_$S(+IBCNS06:"YES",IBCNS06=0:"NO",1:""))
    16         D SET^IBCNSP(START+4,OFFSET+4,"Diff. Rev. Codes: "_$P(IBCNS0,"^",7))
    17         D SET^IBCNSP(START+5,OFFSET+6,"One Opt. Visit: "_$S(+IBCNS08:"YES",1:"NO"))
    18         D SET^IBCNSP(START+6,OFFSET+1,"Amb. Sur. Rev. Code: "_$P(IBCNS0,"^",9))
    19         D SET^IBCNSP(START+7,OFFSET+1,"Rx Refill Rev. Code: "_$P(IBCNS0,"^",15))
    20         ;
    21         S OFFSET=45
    22         D SET^IBCNSP(START+1,OFFSET+3,"Filing Time Frame: "_$P(IBCNS0,"^",12))
    23         D SET^IBCNSP(START+2,OFFSET+4,"Type Of Coverage: "_$$EXPAND^IBTRE(36,.13,+$P(IBCNS0,U,13)))
    24         D SET^IBCNSP(START+3,OFFSET+7,"Billing Phone: "_$P(IBCNS13,"^",2))
    25         D SET^IBCNSP(START+4,OFFSET+2,"Verification Phone: "_$P(IBCNS13,"^",4))
    26         D SET^IBCNSP(START+5,OFFSET+2,"Precert Comp. Name: "_$P($G(^DIC(36,+$P(IBCNS13,"^",9),0)),"^",1))
    27         D SET^IBCNSP(START+6,OFFSET+7,"Precert Phone: "_$$PHONE(IBCNS13))
    28         I +IBCNS3=2 D SET^IBCNSP(START+7,OFFSET,"Max # Test Bills/Day: "_$P(IBCNS3,U,6))
    29         ;
    30         S START=11,OFFSET=2
    31         D SET^IBCNSP(START,OFFSET+28," EDI Parameters ",IORVON,IORVOFF)
    32         D SET^IBCNSP(START+1,OFFSET+13,"Transmit?: "_$S(+IBCNS3=1:"YES-LIVE",+IBCNS3=2:"TEST ONLY",1:"NO"))
    33         D SET^IBCNSP(START+2,OFFSET+1,"Inst Payer Primary ID: "_$P(IBCNS3,U,4))
    34         D SET^IBCNSP(START+3,OFFSET,"Inst Payer Sec ID Qual: "_$$GET1^DIQ(36,+IBCNS,6.01))
    35         D SET^IBCNSP(START+4,OFFSET+5,"Inst Payer Sec ID: "_$$GET1^DIQ(36,+IBCNS,6.02))
    36         D SET^IBCNSP(START+5,OFFSET,"Inst Payer Sec ID Qual: "_$$GET1^DIQ(36,+IBCNS,6.03))
    37         D SET^IBCNSP(START+6,OFFSET+5,"Inst Payer Sec ID: "_$$GET1^DIQ(36,+IBCNS,6.04))
    38         D SET^IBCNSP(START+7,OFFSET+12,"Bin Number: "_$P($G(^DIC(36,+IBCNS,3)),"^",3)) ;
    39         ;
    40         S OFFSET=41
    41         D SET^IBCNSP(START+1,OFFSET+8," Insurance Type: "_$$EXPAND^IBTRE(36,3.09,+$P(IBCNS3,U,9)))
    42         D SET^IBCNSP(START+2,OFFSET+1," Prof Payer Primary ID: "_$P(IBCNS3,U,2))
    43         D SET^IBCNSP(START+3,OFFSET," Prof Payer Sec ID Qual: "_$$GET1^DIQ(36,+IBCNS,6.05))
    44         D SET^IBCNSP(START+4,OFFSET+5," Prof Payer Sec ID: "_$$GET1^DIQ(36,+IBCNS,6.06))
    45         D SET^IBCNSP(START+5,OFFSET," Prof Payer Sec ID Qual: "_$$GET1^DIQ(36,+IBCNS,6.07))
    46         D SET^IBCNSP(START+6,OFFSET+5," Prof Payer Sec ID: "_$$GET1^DIQ(36,+IBCNS,6.08))
    47         Q
    48         ;
    49 PHONE(IBCNS13)  ; -- Compute precert company phone
    50         N IBX,IBSAVE,IBCNT S IBX=""
    51         I '$P(IBCNS13,"^",9) S IBX=$P(IBCNS13,"^",3) G PHONEQ
    52 REDOX   S IBSAVE=+$P(IBCNS13,"^",9)
    53         S IBCNT=$G(IBCNT)+1
    54         ; -- if you process the same co. more than once you are in an infinite loop
    55         I $D(IBCNT(IBCNS)) G PHONEQ
    56         S IBCNT(IBCNS)=""
    57         S IBCNS13=$G(^DIC(36,+$P(IBCNS13,"^",9),.13))
    58         S IBX=$P(IBCNS13,"^") S:$L($P(IBCNS13,"^",3)) IBX=$P(IBCNS13,"^",3)
    59         ; -- if process the same co. more than once you are in an infinite loop
    60         I $P(IBCNS13,"^",9),$P(IBCNS13,"^",9)'=IBSAVE G REDOX
    61 PHONEQ  Q IBX
    62         ;
    63 MAIN    ; -- Insurance company main address
    64         N OFFSET,START,IBCNS11,IBCNS13,IBADD
    65         S IBCNS11=$G(^DIC(36,+IBCNS,.11))
    66         S IBCNS13=$G(^DIC(36,+IBCNS,.13))
    67         S START=21,OFFSET=25
    68         D SET^IBCNSP(START,OFFSET," Main Mailing Address ",IORVON,IORVOFF)
    69         N OFFSET S OFFSET=2
    70         D SET^IBCNSP(START+1,OFFSET,"       Street: "_$P(IBCNS11,"^",1)) S IBADD=1
    71         D SET^IBCNSP(START+2,OFFSET,"     Street 2: "_$P(IBCNS11,"^",2)) S IBADD=2
    72         D SET^IBCNSP(START+3,OFFSET,"     Street 3: "_$P(IBCNS11,"^",3)) S IBADD=3
    73         ; D SET^IBCNSP(START+4,OFFSET,"Claim Off. ID: "_$P(IBCNS11,U,11))
    74         N OFFSET S OFFSET=45
    75         D SET^IBCNSP(START+1,OFFSET,"   City/State: "_$E($P(IBCNS11,"^",4),1,15)_$S($P(IBCNS11,"^",4)="":"",1:", ")_$P($G(^DIC(5,+$P(IBCNS11,"^",5),0)),"^",2)_" "_$E($P(IBCNS11,"^",6),1,5))
    76         D SET^IBCNSP(START+2,OFFSET,"        Phone: "_$P(IBCNS13,"^",1))
    77         D SET^IBCNSP(START+3,OFFSET,"          Fax: "_$P(IBCNS11,"^",9))
    78         Q
    79         ;
    80         ;
    81 PAYER   ; This procedure builds the display for the payer associated with
    82         ; this insurance company.
    83         ; ESG - 7/29/02 - IIV project
    84         ;
    85         NEW PAYERIEN,PAYR,APPDATA,APP,DATA,APPNAME,A1,A2,A3,A4,A5,A6,A7,A8
    86         NEW START,TITLE,OFFSET,IBLINE
    87         S PAYERIEN=$P($G(^DIC(36,+IBCNS,3)),U,10),PAYR="",APPDATA=0
    88         I PAYERIEN D
    89         . S PAYR=$G(^IBE(365.12,PAYERIEN,0))
    90         . S APP=0
    91         . F  S APP=$O(^IBE(365.12,PAYERIEN,1,APP)) Q:'APP  D
    92         .. S DATA=$G(^IBE(365.12,PAYERIEN,1,APP,0))
    93         .. S APPNAME=$$EXTERNAL^DILFD(365.121,.01,"",$P(DATA,U,1))
    94         .. I APPNAME="" Q
    95         .. I $D(APPDATA(APPNAME)) Q
    96         .. S (A1,A2,A3,A4,A5,A6,A7)="NO",A8=""
    97         .. I $P(DATA,U,2) S A1="YES"      ; national active
    98         .. I $P(DATA,U,3) S A2="YES"      ; local active
    99         .. I $P(DATA,U,7) S A3="YES"      ; auto-accept
    100         .. I $P(DATA,U,8) S A4="YES"      ; ident inquiries require subscr ID
    101         .. I $P(DATA,U,9) S A5="YES"      ; use SSN for subscriber ID
    102         .. I $P(DATA,U,10) S A6="YES"     ; transmit SSN
    103         .. I $P(DATA,U,11) S A7="YES"     ; deactivated?
    104         .. ; A8 = deactivation date
    105         .. I $P(DATA,U,12) S A8=$P($$FMTE^XLFDT($P(DATA,U,12),"5Z"),"@",1)
    106         .. S APPDATA(APPNAME)=A1_U_A2_U_A3_U_A4_U_A5_U_A6_U_A7_U_A8
    107         .. S APPDATA=APPDATA+1
    108         .. Q
    109         . Q
    110         ;
    111         S START=$O(^TMP("IBCNSC",$J,""),-1)+1
    112         S IB1ST("PAYER")=START
    113         S TITLE=" Payer Information/Electronic Insurance Verification "
    114         S OFFSET=(40-($L(TITLE)/2))\1+1
    115         D SET^IBCNSP(START,OFFSET,TITLE,IORVON,IORVOFF)
    116         D SET^IBCNSP(START+1,9,"Payer Name: "_$P(PAYR,U,1))
    117         D SET^IBCNSP(START+2,5,"VA National ID: "_$P(PAYR,U,2))
    118         D SET^IBCNSP(START+2,51,"CMS National ID: "_$P(PAYR,U,3))
    119         S IBLINE=START+2
    120         ;
    121         ; Handle the case where no application data is defined
    122         I 'APPDATA D  G PAYERX
    123         . S IBLINE=IBLINE+1
    124         . D SET^IBCNSP(IBLINE,2," ")    ; blank line
    125         . S IBLINE=IBLINE+1
    126         . D SET^IBCNSP(IBLINE,16,"Payer Application data is not defined!")
    127         . Q
    128         ;
    129         ; Display all the applications
    130         S APPNAME=""
    131         F  S APPNAME=$O(APPDATA(APPNAME)) Q:APPNAME=""  D
    132         . S IBLINE=IBLINE+1
    133         . D SET^IBCNSP(IBLINE,2," ")    ; blank line
    134         . ;
    135         . S IBLINE=IBLINE+1
    136         . D SET^IBCNSP(IBLINE,2,"Payer Application: "_APPNAME)
    137         . D SET^IBCNSP(IBLINE,50,"Auto-Accept Info: "_$P(APPDATA(APPNAME),U,3))
    138         . ;
    139         . S IBLINE=IBLINE+1
    140         . D SET^IBCNSP(IBLINE,4,"National Active: "_$P(APPDATA(APPNAME),U,1))
    141         . D SET^IBCNSP(IBLINE,47,"Ident Req Subscr ID: "_$P(APPDATA(APPNAME),U,4))
    142         . ;
    143         . S IBLINE=IBLINE+1
    144         . D SET^IBCNSP(IBLINE,7,"Local Active: "_$P(APPDATA(APPNAME),U,2))
    145         . D SET^IBCNSP(IBLINE,51,"SSN = Subscr ID: "_$P(APPDATA(APPNAME),U,5))
    146         . ;
    147         . S IBLINE=IBLINE+1
    148         . D SET^IBCNSP(IBLINE,8,"Deactivated: "_$P(APPDATA(APPNAME),U,7))
    149         . D SET^IBCNSP(IBLINE,54,"Transmit SSN: "_$P(APPDATA(APPNAME),U,6))
    150         . ;
    151         . ; If no deactivated date, then exit
    152         . I $P(APPDATA(APPNAME),U,8)="" Q
    153         . ;
    154         . S IBLINE=IBLINE+1
    155         . D SET^IBCNSP(IBLINE,13,"D-Date: "_$P(APPDATA(APPNAME),U,8))
    156         . ;
    157         . Q
    158 PAYERX  ;
    159         ; Two trailing blank lines after payer information display
    160         S IBLINE=IBLINE+1
    161         D SET^IBCNSP(IBLINE,2," ")    ; blank line
    162         S IBLINE=IBLINE+1
    163         D SET^IBCNSP(IBLINE,2," ")    ; blank line
    164         Q
    165         ;
    166         ;
    167 REMARKS ;
    168         ;
    169         N OFFSET,START,IBLCNT,IBI
    170         S START=$O(^TMP("IBCNSC",$J,""),-1)+1,OFFSET=2
    171         S IB1ST("REM")=START
    172         ;
    173         D SET^IBCNSP(START,OFFSET," Remarks ",IORVON,IORVOFF)
    174         S (IBLCNT,IBI)=0 F  S IBI=$O(^DIC(36,+IBCNS,11,IBI)) Q:IBI<1  D
    175         . S IBLCNT=IBLCNT+1
    176         . D SET^IBCNSP(START+IBLCNT,OFFSET,"  "_$E($G(^DIC(36,+IBCNS,11,IBI,0)),1,80))
    177         . Q
    178         D SET^IBCNSP(START+IBLCNT+1,OFFSET," ")   ; blank line after remarks
    179         Q
    180         ;
    181 SYN     ;
    182         N OFFSET,START,SYN,SYNOI
    183         S START=$O(^TMP("IBCNSC",$J,""),-1)+1,OFFSET=2
    184         S IB1ST("SYN")=START
    185         D SET^IBCNSP(START,OFFSET," Synonyms ",IORVON,IORVOFF)
    186         S SYN="" F SYNOI=1:1:8 S SYN=$O(^DIC(36,+IBCNS,10,"B",SYN)) Q:SYN=""  D SET^IBCNSP(START+SYNOI,OFFSET,$S(SYNOI>7:"  ...edit to see more...",1:"  "_SYN))
    187         Q
    188         ;
     1IBCNSC01 ;ALB/NLR - INSURANCE COMPANY EDIT ; 6/1/05 10:06am
     2 ;;2.0;INTEGRATED BILLING;**52,137,191,184,232,320,349**;21-MAR-94;Build 46
     3 ;;Per VHA Directive 2004-038, this routine should not be modified.
     4 ;
     5PARAM ; -- Insurance company parameters region
     6 N OFFSET,START,IBCNS0,IBCNS03,IBCNS06,IBCNS08,IBCNS13,IBCNS3
     7 S IBCNS0=$G(^DIC(36,+IBCNS,0)),IBCNS3=$G(^(3))
     8 S IBCNS03=$P(IBCNS0,"^",3),IBCNS06=$P(IBCNS0,"^",6),IBCNS08=$P(IBCNS0,"^",8)
     9 S IBCNS13=$G(^DIC(36,+IBCNS,.13))
     10 S START=1,OFFSET=2
     11 D SET^IBCNSP(START,OFFSET+25," Billing Parameters ",IORVON,IORVOFF)
     12 ;
     13 D SET^IBCNSP(START+1,OFFSET+1,"Signature Required?: "_$S(+IBCNS03:"YES",1:"NO"))
     14 D SET^IBCNSP(START+2,OFFSET+10,"Reimburse?: "_$E($$EXPAND^IBTRE(36,1,$P(IBCNS0,"^",2)),1,21))
     15 D SET^IBCNSP(START+3,OFFSET+3,"Mult. Bedsections: "_$S(+IBCNS06:"YES",IBCNS06=0:"NO",1:""))
     16 D SET^IBCNSP(START+4,OFFSET+4,"Diff. Rev. Codes: "_$P(IBCNS0,"^",7))
     17 D SET^IBCNSP(START+5,OFFSET+6,"One Opt. Visit: "_$S(+IBCNS08:"YES",1:"NO"))
     18 D SET^IBCNSP(START+6,OFFSET+1,"Amb. Sur. Rev. Code: "_$P(IBCNS0,"^",9))
     19 D SET^IBCNSP(START+7,OFFSET+1,"Rx Refill Rev. Code: "_$P(IBCNS0,"^",15))
     20 D SET^IBCNSP(START+8,OFFSET+3,"Filing Time Frame: "_$P(IBCNS0,"^",12))
     21 D SET^IBCNSP(START+9,OFFSET+4,"Type Of Coverage: "_$$EXPAND^IBTRE(36,.13,+$P(IBCNS0,U,13)))
     22 D SET^IBCNSP(START+10,OFFSET+3,"Primary Form Type: "_$$EXPAND^IBTRE(36,.14,$P(IBCNS0,"^",14)))
     23 ;
     24 N START,OFFSET
     25 S START=1,OFFSET=45
     26 D SET^IBCNSP(START+1,OFFSET+7,"Billing Phone: "_$P(IBCNS13,"^",2))
     27 D SET^IBCNSP(START+2,OFFSET+2,"Verification Phone: "_$P(IBCNS13,"^",4))
     28 D SET^IBCNSP(START+3,OFFSET+2,"Precert Comp. Name: "_$P($G(^DIC(36,+$P(IBCNS13,"^",9),0)),"^",1))
     29 D SET^IBCNSP(START+4,OFFSET+7,"Precert Phone: "_$$PHONE(IBCNS13))
     30 D SET^IBCNSP(START+5,OFFSET+6,"   *** EDI Parameters ***   ",IOINHI,IOINORM)
     31 D SET^IBCNSP(START+6,OFFSET+11,"Transmit?: "_$S(+IBCNS3=1:"YES-LIVE",+IBCNS3=2:"TEST ONLY",1:"NO"))
     32 D SET^IBCNSP(START+7,OFFSET+7,"Inst Payer ID: "_$P(IBCNS3,U,4))
     33 D SET^IBCNSP(START+8,OFFSET+7,"Prof Payer ID: "_$P(IBCNS3,U,2))
     34 D SET^IBCNSP(START+9,OFFSET+6,"Insurance Type: "_$$EXPAND^IBTRE(36,3.09,+$P(IBCNS3,U,9)))
     35 D SET^IBCNSP(START+10,OFFSET+10,"Bin Number: "_$P($G(^DIC(36,+IBCNS,3)),"^",3))
     36 I +IBCNS3=2 D SET^IBCNSP(START+11,OFFSET,"Max # Test Bills/Day: "_$P(IBCNS3,U,6))
     37 Q
     38 ;
     39PHONE(IBCNS13) ; -- Compute precert company phone
     40 N IBX,IBSAVE,IBCNT S IBX=""
     41 I '$P(IBCNS13,"^",9) S IBX=$P(IBCNS13,"^",3) G PHONEQ
     42REDOX S IBSAVE=+$P(IBCNS13,"^",9)
     43 S IBCNT=$G(IBCNT)+1
     44 ; -- if you process the same co. more than once you are in an infinite loop
     45 I $D(IBCNT(IBCNS)) G PHONEQ
     46 S IBCNT(IBCNS)=""
     47 S IBCNS13=$G(^DIC(36,+$P(IBCNS13,"^",9),.13))
     48 S IBX=$P(IBCNS13,"^") S:$L($P(IBCNS13,"^",3)) IBX=$P(IBCNS13,"^",3)
     49 ; -- if process the same co. more than once you are in an infinite loop
     50 I $P(IBCNS13,"^",9),$P(IBCNS13,"^",9)'=IBSAVE G REDOX
     51PHONEQ Q IBX
     52 ;
     53MAIN ; -- Insurance company main address
     54 N OFFSET,START,IBCNS11,IBCNS13,IBADD
     55 S IBCNS11=$G(^DIC(36,+IBCNS,.11))
     56 S IBCNS13=$G(^DIC(36,+IBCNS,.13))
     57 S START=15,OFFSET=25
     58 D SET^IBCNSP(START,OFFSET," Main Mailing Address ",IORVON,IORVOFF)
     59 N OFFSET S OFFSET=2
     60 D SET^IBCNSP(START+1,OFFSET,"       Street: "_$P(IBCNS11,"^",1)) S IBADD=1
     61 D SET^IBCNSP(START+2,OFFSET,"     Street 2: "_$P(IBCNS11,"^",2)) S IBADD=2
     62 D SET^IBCNSP(START+3,OFFSET,"     Street 3: "_$P(IBCNS11,"^",3)) S IBADD=3
     63 ; D SET^IBCNSP(START+4,OFFSET,"Claim Off. ID: "_$P(IBCNS11,U,11))
     64 N OFFSET S OFFSET=45
     65 D SET^IBCNSP(START+1,OFFSET,"   City/State: "_$E($P(IBCNS11,"^",4),1,15)_$S($P(IBCNS11,"^",4)="":"",1:", ")_$P($G(^DIC(5,+$P(IBCNS11,"^",5),0)),"^",2)_" "_$E($P(IBCNS11,"^",6),1,5))
     66 D SET^IBCNSP(START+2,OFFSET,"        Phone: "_$P(IBCNS13,"^",1))
     67 D SET^IBCNSP(START+3,OFFSET,"          Fax: "_$P(IBCNS11,"^",9))
     68 Q
     69 ;
     70 ;
     71PAYER ; This procedure builds the display for the payer associated with
     72 ; this insurance company.
     73 ; ESG - 7/29/02 - IIV project
     74 ;
     75 NEW PAYERIEN,PAYR,APPDATA,APP,DATA,APPNAME,A1,A2,A3,A4,A5,A6,A7,A8
     76 NEW START,TITLE,OFFSET,IBLINE
     77 S PAYERIEN=$P($G(^DIC(36,+IBCNS,3)),U,10),PAYR="",APPDATA=0
     78 I PAYERIEN D
     79 . S PAYR=$G(^IBE(365.12,PAYERIEN,0))
     80 . S APP=0
     81 . F  S APP=$O(^IBE(365.12,PAYERIEN,1,APP)) Q:'APP  D
     82 .. S DATA=$G(^IBE(365.12,PAYERIEN,1,APP,0))
     83 .. S APPNAME=$$EXTERNAL^DILFD(365.121,.01,"",$P(DATA,U,1))
     84 .. I APPNAME="" Q
     85 .. I $D(APPDATA(APPNAME)) Q
     86 .. S (A1,A2,A3,A4,A5,A6,A7)="NO",A8=""
     87 .. I $P(DATA,U,2) S A1="YES"      ; national active
     88 .. I $P(DATA,U,3) S A2="YES"      ; local active
     89 .. I $P(DATA,U,7) S A3="YES"      ; auto-accept
     90 .. I $P(DATA,U,8) S A4="YES"      ; ident inquiries require subscr ID
     91 .. I $P(DATA,U,9) S A5="YES"      ; use SSN for subscriber ID
     92 .. I $P(DATA,U,10) S A6="YES"     ; transmit SSN
     93 .. I $P(DATA,U,11) S A7="YES"     ; deactivated?
     94 .. ; A8 = deactivation date
     95 .. I $P(DATA,U,12) S A8=$P($$FMTE^XLFDT($P(DATA,U,12),"5Z"),"@",1)
     96 .. S APPDATA(APPNAME)=A1_U_A2_U_A3_U_A4_U_A5_U_A6_U_A7_U_A8
     97 .. S APPDATA=APPDATA+1
     98 .. Q
     99 . Q
     100 ;
     101 S START=$O(^TMP("IBCNSC",$J,""),-1)+1
     102 S IB1ST("PAYER")=START
     103 S TITLE=" Payer Information/Electronic Insurance Verification "
     104 S OFFSET=(40-($L(TITLE)/2))\1+1
     105 D SET^IBCNSP(START,OFFSET,TITLE,IORVON,IORVOFF)
     106 D SET^IBCNSP(START+1,9,"Payer Name: "_$P(PAYR,U,1))
     107 D SET^IBCNSP(START+2,5,"VA National ID: "_$P(PAYR,U,2))
     108 D SET^IBCNSP(START+2,51,"CMS National ID: "_$P(PAYR,U,3))
     109 S IBLINE=START+2
     110 ;
     111 ; Handle the case where no application data is defined
     112 I 'APPDATA D  G PAYERX
     113 . S IBLINE=IBLINE+1
     114 . D SET^IBCNSP(IBLINE,2," ")    ; blank line
     115 . S IBLINE=IBLINE+1
     116 . D SET^IBCNSP(IBLINE,16,"Payer Application data is not defined!")
     117 . Q
     118 ;
     119 ; Display all the applications
     120 S APPNAME=""
     121 F  S APPNAME=$O(APPDATA(APPNAME)) Q:APPNAME=""  D
     122 . S IBLINE=IBLINE+1
     123 . D SET^IBCNSP(IBLINE,2," ")    ; blank line
     124 . ;
     125 . S IBLINE=IBLINE+1
     126 . D SET^IBCNSP(IBLINE,2,"Payer Application: "_APPNAME)
     127 . D SET^IBCNSP(IBLINE,50,"Auto-Accept Info: "_$P(APPDATA(APPNAME),U,3))
     128 . ;
     129 . S IBLINE=IBLINE+1
     130 . D SET^IBCNSP(IBLINE,4,"National Active: "_$P(APPDATA(APPNAME),U,1))
     131 . D SET^IBCNSP(IBLINE,47,"Ident Req Subscr ID: "_$P(APPDATA(APPNAME),U,4))
     132 . ;
     133 . S IBLINE=IBLINE+1
     134 . D SET^IBCNSP(IBLINE,7,"Local Active: "_$P(APPDATA(APPNAME),U,2))
     135 . D SET^IBCNSP(IBLINE,51,"SSN = Subscr ID: "_$P(APPDATA(APPNAME),U,5))
     136 . ;
     137 . S IBLINE=IBLINE+1
     138 . D SET^IBCNSP(IBLINE,8,"Deactivated: "_$P(APPDATA(APPNAME),U,7))
     139 . D SET^IBCNSP(IBLINE,54,"Transmit SSN: "_$P(APPDATA(APPNAME),U,6))
     140 . ;
     141 . ; If no deactivated date, then exit
     142 . I $P(APPDATA(APPNAME),U,8)="" Q
     143 . ;
     144 . S IBLINE=IBLINE+1
     145 . D SET^IBCNSP(IBLINE,13,"D-Date: "_$P(APPDATA(APPNAME),U,8))
     146 . ;
     147 . Q
     148PAYERX ;
     149 ; Two trailing blank lines after payer information display
     150 S IBLINE=IBLINE+1
     151 D SET^IBCNSP(IBLINE,2," ")    ; blank line
     152 S IBLINE=IBLINE+1
     153 D SET^IBCNSP(IBLINE,2," ")    ; blank line
     154 Q
     155 ;
     156 ;
     157REMARKS ;
     158 ;
     159 N OFFSET,START,IBLCNT,IBI
     160 S START=$O(^TMP("IBCNSC",$J,""),-1)+1,OFFSET=2
     161 S IB1ST("REM")=START
     162 ;
     163 D SET^IBCNSP(START,OFFSET," Remarks ",IORVON,IORVOFF)
     164 S (IBLCNT,IBI)=0 F  S IBI=$O(^DIC(36,+IBCNS,11,IBI)) Q:IBI<1  D
     165 . S IBLCNT=IBLCNT+1
     166 . D SET^IBCNSP(START+IBLCNT,OFFSET,"  "_$E($G(^DIC(36,+IBCNS,11,IBI,0)),1,80))
     167 . Q
     168 D SET^IBCNSP(START+IBLCNT+1,OFFSET," ")   ; blank line after remarks
     169 Q
     170 ;
     171SYN ;
     172 N OFFSET,START,SYN,SYNOI
     173 S START=$O(^TMP("IBCNSC",$J,""),-1)+1,OFFSET=2
     174 S IB1ST("SYN")=START
     175 D SET^IBCNSP(START,OFFSET," Synonyms ",IORVON,IORVOFF)
     176 S SYN="" F SYNOI=1:1:8 S SYN=$O(^DIC(36,+IBCNS,10,"B",SYN)) Q:SYN=""  D SET^IBCNSP(START+SYNOI,OFFSET,$S(SYNOI>7:"  ...edit to see more...",1:"  "_SYN))
     177 Q
     178 ;

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSC02.m

    r613 r623  
    1 IBCNSC02        ;ALB/ESG - Insurance Company parent/child management ;01-NOV-2005
    2         ;;2.0;INTEGRATED BILLING;**320,371**;21-MAR-94;Build 57
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5         Q
    6         ;
    7 DISP    ; entry point for display of parent/child companies
    8         NEW PCFLG,PARENT,PCDESC,TITLE,START,IBLINE,OFFSET,INSDATA,CNT,TXT
    9         S PCFLG=$P($G(^DIC(36,+IBCNS,3)),U,13),PARENT=""
    10         I PCFLG="C" S PARENT=$P($G(^DIC(36,+IBCNS,3)),U,14),PCDESC="Child"
    11         I PCFLG="P" S PCDESC="Parent"
    12         S TITLE=" Associated Insurance Companies "
    13         S (START,IBLINE)=62
    14         S OFFSET=(40-($L(TITLE)/2))\1+1
    15         D SET^IBCNSP(START,OFFSET,TITLE,IORVON,IORVOFF)
    16         ;
    17         ; no link - display this and get out
    18         I PCFLG="" D  G DISPX
    19         . S IBLINE=IBLINE+1
    20         . D SET^IBCNSP(IBLINE,3,"This insurance company is not defined as either a Parent or a Child.")
    21         . Q
    22         ;
    23         ; display for either parent or child
    24         S IBLINE=IBLINE+1
    25         D SET^IBCNSP(IBLINE,3,"This insurance company is defined as a "_PCDESC_" Insurance Company.")
    26         ;
    27         ; child display
    28         I PCFLG="C" D  G DISPX
    29         . S IBLINE=IBLINE+1
    30         . D SET^IBCNSP(IBLINE,3,"It is associated with the following Parent Insurance Company:")
    31         . S IBLINE=IBLINE+1
    32         . D SET^IBCNSP(IBLINE,2," ")    ; blank line
    33         . S INSDATA=""
    34         . I 'PARENT S INSDATA="*** Parent Insurance Company not defined ***"
    35         . I PARENT D
    36         .. N AD S AD=$$INSADD(PARENT)   ; get parent ins co data
    37         .. S INSDATA=$P(AD,U,1)_"  "_$P(AD,U,2)_"  "_$P(AD,U,6)
    38         .. Q
    39         . S IBLINE=IBLINE+1
    40         . D SET^IBCNSP(IBLINE,8,INSDATA)
    41         . Q
    42         ;
    43         ; parent display
    44         S CNT=$$PCNT(IBCNS)    ; count # of children
    45         S TXT="There are "_CNT_" Child Insurance Companies"
    46         I CNT=1 S TXT="There is 1 Child Insurance Company"
    47         S TXT=TXT_" associated with it."
    48         S IBLINE=IBLINE+1
    49         D SET^IBCNSP(IBLINE,3,TXT)
    50         S IBLINE=IBLINE+1
    51         D SET^IBCNSP(IBLINE,3,"Select the ""AC  Associate Companies"" action to enter/edit the children.")
    52         ;
    53 DISPX   ; end with 2 blank lines
    54         S IBLINE=IBLINE+1
    55         D SET^IBCNSP(IBLINE,2," ")    ; blank line
    56         S IBLINE=IBLINE+1
    57         D SET^IBCNSP(IBLINE,2," ")    ; blank line
    58         Q
    59         ;
    60 PARENT(IBCNS)   ; Insurance company parent/child management
    61         ; Calls ListMan screen for parent insurance companies
    62         NEW PCFLG
    63         I '$G(IBCNS) G PARENTX
    64         S PCFLG=$P($G(^DIC(36,IBCNS,3)),U,13)
    65         ;
    66         ; special check to remove 3.13 field if 3.14 field is nil
    67         I PCFLG="C",'$P($G(^DIC(36,IBCNS,3)),U,14) D
    68         . N DIE,DA,DR S DIE=36,DA=IBCNS,DR="3.13////@" D ^DIE
    69         . Q
    70         ;
    71         ; get out if not a parent insurance company
    72         I PCFLG'="P" G PARENTX
    73         ;
    74         ; call ListMan for parent/children management
    75         D EN^VALM("IBCNS ASSOCIATIONS LIST")
    76         KILL ^TMP($J,"IBCNSL")
    77 PARENTX ;
    78         Q
    79         ;
    80 HDR     ; List header info
    81         S VALMHDR(1)="Parent Insurance Company:"
    82         S VALMHDR(2)="     "_$$INSCO(IBCNS)
    83         S VALMHDR(3)=""
    84 HDRX    ;
    85         Q
    86         ;
    87 BLD     ; Build list contents
    88         NEW C,INSDATA,INSNAME,STCITY,ENTRY,NM,ST,IEN,X
    89         KILL ^TMP($J,"IBCNSL")
    90         S C=0
    91         F  S C=$O(^DIC(36,"APC",IBCNS,C)) Q:'C  D
    92         . S INSDATA=$$INSADD(C)
    93         . S INSNAME=$P(INSDATA,U,1)
    94         . I INSNAME="" S INSNAME="~UNKNOWN"
    95         . S STCITY=$P(INSDATA,U,7)
    96         . I STCITY="" S STCITY="~UNKNOWN"
    97         . S ^TMP($J,"IBCNSL",1,INSNAME,STCITY,C)=""
    98         . Q
    99         ;
    100         I '$D(^TMP($J,"IBCNSL",1)) D  G BLDX
    101         . ; no children insurance companies found
    102         . S ^TMP($J,"IBCNSL",2,1,0)=""
    103         . S ^TMP($J,"IBCNSL",2,2,0)="     No Children Insurance Companies Found"
    104         . S VALMCNT=2
    105         . Q
    106         ;
    107         S VALMCNT=0,ENTRY=0
    108         S NM=""
    109         F  S NM=$O(^TMP($J,"IBCNSL",1,NM)) Q:NM=""  D
    110         . S ST=""
    111         . F  S ST=$O(^TMP($J,"IBCNSL",1,NM,ST)) Q:ST=""  D
    112         .. S IEN=0
    113         .. F  S IEN=$O(^TMP($J,"IBCNSL",1,NM,ST,IEN)) Q:'IEN  D
    114         ... S VALMCNT=VALMCNT+1,ENTRY=ENTRY+1
    115         ... S X=$$FO^IBCNEUT1($J(ENTRY,3),5)_$$INSCO(IEN)
    116         ... S ^TMP($J,"IBCNSL",2,VALMCNT,0)=X
    117         ... S ^TMP($J,"IBCNSL",2,"IDX",VALMCNT,ENTRY)=""
    118         ... S ^TMP($J,"IBCNSL",3,ENTRY)=IEN_U_VALMCNT
    119         ... Q
    120         .. Q
    121         . Q
    122 BLDX    ;
    123         Q
    124         ;
    125 LINK    ; action protocol IBCNSL LINK used to associate children insurance
    126         ; companies to the current parent ins co for the list
    127         NEW DIC,X,Y,DIE,DR,DA,NEWINS,IBSTOP,PAR,DIR,DIRUT,DTOUT,DUOUT,DIROUT
    128         D FULL^VALM1
    129         I '$$KCHK^XUSRB("IB EDI INSURANCE EDIT") D  G LINKX
    130         . W !!?5,"You must hold the IB EDI INSURANCE EDIT key to access this option."
    131         . D PAUSE^VALM1
    132         . Q
    133         ;
    134         ; lookup ins company
    135         W !
    136         S DIC=36,DIC(0)="AEMQ",DIC("A")="Select Insurance Company: "
    137         S DIC("W")="D INSLIST^IBCNSC02(Y)"
    138         ; screen - ins co Y is not a parent and also it is not already in the list of children
    139         S DIC("S")="I $P($G(^DIC(36,Y,3)),U,13)'=""P""&'$D(^DIC(36,""APC"",IBCNS,Y))"
    140         D ^DIC K DIC
    141         I +Y'>0 G LINKX
    142         S NEWINS=+Y
    143         ;
    144         ; check to see if this selected insurance company is already a child
    145         ; for some other parent
    146         S PAR=+$P($G(^DIC(36,NEWINS,3)),U,14),IBSTOP=0
    147         I PAR,PAR'=IBCNS D
    148         . W !
    149         . S DIR(0)="YO",DIR("B")="No"
    150         . S DIR("A",1)="Please Note:  The insurance company you selected is currently identified"
    151         . S DIR("A",2)="as a Child insurance company associated with the following Parent:"
    152         . S DIR("A",3)=""
    153         . S DIR("A",4)="     "_$$INSCO(PAR)
    154         . S DIR("A",5)=""
    155         . S DIR("A")="OK to proceed and make this switch"
    156         . D ^DIR K DIR
    157         . I Y'=1 S IBSTOP=1 Q
    158         . Q
    159         I IBSTOP G LINKX
    160         ;
    161         ; lock the potential new child ins company
    162         L +^DIC(36,NEWINS):0 I '$T D LOCKED^IBTRCD1 G LINKX
    163         ;
    164         ; update selected child
    165         S DIE=36,DA=NEWINS,DR="3.13////C;3.14////"_IBCNS D ^DIE
    166         ;
    167         ; Copy the IDs from the parent
    168         D COPY^IBCEPCID(NEWINS)
    169         ;
    170         ; unlock
    171         L -^DIC(36,NEWINS)
    172         ;
    173         D BLD   ; rebuild list of children
    174 LINKX   ;
    175         S VALMBCK="R"
    176         Q
    177         ;
    178 UNLINK  ; action protocol IBCNSL UNLINK used to disassociate selected children
    179         ; insurance companies from the list.
    180         NEW DIR,X,Y,DIRUT,DTOUT,DUOUT,DIROUT,IBLST,IBSUB,IBPCE,IBSEL,DA,DIE,DR
    181         D FULL^VALM1
    182         I '$$KCHK^XUSRB("IB EDI INSURANCE EDIT") D  G UNLINKX
    183         . W !!?5,"You must hold the IB EDI INSURANCE EDIT key to access this option."
    184         . D PAUSE^VALM1
    185         . Q
    186         ;
    187         I '$D(^TMP($J,"IBCNSL",3)) D  G UNLINKX
    188         . W !!?5,"There are no insurance companies to select." D PAUSE^VALM1
    189         . Q
    190         S DIR(0)="LO^1:"_+$O(^TMP($J,"IBCNSL",3,""),-1)
    191         S DIR("A")="Select Insurance Company(s)"
    192         W ! D ^DIR K DIR
    193         I $D(DIRUT) G UNLINKX
    194         M IBLST=Y
    195         ;
    196         W !
    197         S DIR(0)="YO"
    198         S DIR("A")="OK to proceed",DIR("B")="No"
    199         D ^DIR K DIR
    200         I Y'=1 G UNLINKX
    201         ;
    202         F IBSUB=0:1 Q:'$D(IBLST(IBSUB))  F IBPCE=1:1 S IBSEL=$P(IBLST(IBSUB),",",IBPCE) Q:'IBSEL  D
    203         . S DA=+$G(^TMP($J,"IBCNSL",3,IBSEL)) I 'DA Q
    204         . S DIE=36,DR="3.13////@;3.14////@" D ^DIE
    205         . Q
    206         ;
    207         D BLD   ; rebuild list of children
    208 UNLINKX ;
    209         S VALMBCK="R"
    210         Q
    211         ;
    212 PCNT(Z) ; count number of children for parent ins co Z
    213         NEW C,CNT
    214         S C=0,Z=+$G(Z)
    215         F CNT=0:1 S C=$O(^DIC(36,"APC",Z,C)) Q:'C
    216         Q CNT
    217         ;
    218 INSADD(Z)       ; function to return ins co address components
    219         NEW INSDATA,AD,NM,L1,CITY,ST,ZIP,CITYST,STCITY
    220         S INSDATA=""
    221         S AD=$G(^DIC(36,+$G(Z),.11))
    222         S NM=$P($G(^DIC(36,Z,0)),U,1)
    223         S L1=$P(AD,U,1),CITY=$P(AD,U,4),ST=$P(AD,U,5),ZIP=$P(AD,U,6)
    224         I ST S ST=$P($G(^DIC(5,ST,0)),U,2)
    225         S CITYST=$E(CITY,1,15)_" "_ST
    226         I CITY'="",ST'="" S CITYST=$E(CITY,1,15)_","_ST
    227         ;
    228         S $P(STCITY,"|",1)=ST
    229         I ST="" S $P(STCITY,"|",1)="~~"
    230         S $P(STCITY,"|",2)=CITY
    231         I CITY="" S $P(STCITY,"|",2)="~~~~"
    232         ;
    233         S INSDATA=NM_U_L1_U_CITY_U_ST_U_ZIP_U_CITYST_U_STCITY
    234         ;         1    2    3      4    5     6        7
    235 INSADDX ;
    236         Q INSDATA
    237         ;
    238 INSCO(Z)        ; return display data for ins co Z
    239         NEW X,Y
    240         S Y=$$INSADD(Z)
    241         S X=$$FO^IBCNEUT1($P(Y,U,1),27)
    242         S X=X_$$FO^IBCNEUT1($P(Y,U,2),26)
    243         S X=X_$$FO^IBCNEUT1($P(Y,U,6),18)
    244 INSCOX  ;
    245         Q X
    246         ;
    247 INSLIST(INS)    ; insurance company lister for ^DIC call
    248         NEW Z
    249         S Z=$$INSADD(INS)
    250         W ?27,$E($P(Z,U,2),1,20)   ; address line 1
    251         W ?47,"  ",$P(Z,U,6)       ; city, state
    252 INSLISTX        ;
    253         Q
    254         ;
     1IBCNSC02 ;ALB/ESG - Insurance Company parent/child management ;01-NOV-2005
     2 ;;2.0;INTEGRATED BILLING;**320**;21-MAR-1994
     3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
     4 ;
     5 Q
     6 ;
     7DISP ; entry point for display of parent/child companies
     8 NEW PCFLG,PARENT,PCDESC,TITLE,START,IBLINE,OFFSET,INSDATA,CNT,TXT
     9 S PCFLG=$P($G(^DIC(36,+IBCNS,3)),U,13),PARENT=""
     10 I PCFLG="C" S PARENT=$P($G(^DIC(36,+IBCNS,3)),U,14),PCDESC="Child"
     11 I PCFLG="P" S PCDESC="Parent"
     12 S TITLE=" Associated Insurance Companies "
     13 S (START,IBLINE)=54
     14 S OFFSET=(40-($L(TITLE)/2))\1+1
     15 D SET^IBCNSP(START,OFFSET,TITLE,IORVON,IORVOFF)
     16 ;
     17 ; no link - display this and get out
     18 I PCFLG="" D  G DISPX
     19 . S IBLINE=IBLINE+1
     20 . D SET^IBCNSP(IBLINE,3,"This insurance company is not defined as either a Parent or a Child.")
     21 . Q
     22 ;
     23 ; display for either parent or child
     24 S IBLINE=IBLINE+1
     25 D SET^IBCNSP(IBLINE,3,"This insurance company is defined as a "_PCDESC_" Insurance Company.")
     26 ;
     27 ; child display
     28 I PCFLG="C" D  G DISPX
     29 . S IBLINE=IBLINE+1
     30 . D SET^IBCNSP(IBLINE,3,"It is associated with the following Parent Insurance Company:")
     31 . S IBLINE=IBLINE+1
     32 . D SET^IBCNSP(IBLINE,2," ")    ; blank line
     33 . S INSDATA=""
     34 . I 'PARENT S INSDATA="*** Parent Insurance Company not defined ***"
     35 . I PARENT D
     36 .. N AD S AD=$$INSADD(PARENT)   ; get parent ins co data
     37 .. S INSDATA=$P(AD,U,1)_"  "_$P(AD,U,2)_"  "_$P(AD,U,6)
     38 .. Q
     39 . S IBLINE=IBLINE+1
     40 . D SET^IBCNSP(IBLINE,8,INSDATA)
     41 . Q
     42 ;
     43 ; parent display
     44 S CNT=$$PCNT(IBCNS)    ; count # of children
     45 S TXT="There are "_CNT_" Child Insurance Companies"
     46 I CNT=1 S TXT="There is 1 Child Insurance Company"
     47 S TXT=TXT_" associated with it."
     48 S IBLINE=IBLINE+1
     49 D SET^IBCNSP(IBLINE,3,TXT)
     50 S IBLINE=IBLINE+1
     51 D SET^IBCNSP(IBLINE,3,"Select the ""AC  Associate Companies"" action to enter/edit the children.")
     52 ;
     53DISPX ; end with 2 blank lines
     54 S IBLINE=IBLINE+1
     55 D SET^IBCNSP(IBLINE,2," ")    ; blank line
     56 S IBLINE=IBLINE+1
     57 D SET^IBCNSP(IBLINE,2," ")    ; blank line
     58 Q
     59 ;
     60PARENT(IBCNS) ; Insurance company parent/child management
     61 ; Calls ListMan screen for parent insurance companies
     62 NEW PCFLG
     63 I '$G(IBCNS) G PARENTX
     64 S PCFLG=$P($G(^DIC(36,IBCNS,3)),U,13)
     65 ;
     66 ; special check to remove 3.13 field if 3.14 field is nil
     67 I PCFLG="C",'$P($G(^DIC(36,IBCNS,3)),U,14) D
     68 . N DIE,DA,DR S DIE=36,DA=IBCNS,DR="3.13////@" D ^DIE
     69 . Q
     70 ;
     71 ; get out if not a parent insurance company
     72 I PCFLG'="P" G PARENTX
     73 ;
     74 ; call ListMan for parent/children management
     75 D EN^VALM("IBCNS ASSOCIATIONS LIST")
     76 KILL ^TMP($J,"IBCNSL")
     77PARENTX ;
     78 Q
     79 ;
     80HDR ; List header info
     81 S VALMHDR(1)="Parent Insurance Company:"
     82 S VALMHDR(2)="     "_$$INSCO(IBCNS)
     83 S VALMHDR(3)=""
     84HDRX ;
     85 Q
     86 ;
     87BLD ; Build list contents
     88 NEW C,INSDATA,INSNAME,STCITY,ENTRY,NM,ST,IEN,X
     89 KILL ^TMP($J,"IBCNSL")
     90 S C=0
     91 F  S C=$O(^DIC(36,"APC",IBCNS,C)) Q:'C  D
     92 . S INSDATA=$$INSADD(C)
     93 . S INSNAME=$P(INSDATA,U,1)
     94 . I INSNAME="" S INSNAME="~UNKNOWN"
     95 . S STCITY=$P(INSDATA,U,7)
     96 . I STCITY="" S STCITY="~UNKNOWN"
     97 . S ^TMP($J,"IBCNSL",1,INSNAME,STCITY,C)=""
     98 . Q
     99 ;
     100 I '$D(^TMP($J,"IBCNSL",1)) D  G BLDX
     101 . ; no children insurance companies found
     102 . S ^TMP($J,"IBCNSL",2,1,0)=""
     103 . S ^TMP($J,"IBCNSL",2,2,0)="     No Children Insurance Companies Found"
     104 . S VALMCNT=2
     105 . Q
     106 ;
     107 S VALMCNT=0,ENTRY=0
     108 S NM=""
     109 F  S NM=$O(^TMP($J,"IBCNSL",1,NM)) Q:NM=""  D
     110 . S ST=""
     111 . F  S ST=$O(^TMP($J,"IBCNSL",1,NM,ST)) Q:ST=""  D
     112 .. S IEN=0
     113 .. F  S IEN=$O(^TMP($J,"IBCNSL",1,NM,ST,IEN)) Q:'IEN  D
     114 ... S VALMCNT=VALMCNT+1,ENTRY=ENTRY+1
     115 ... S X=$$FO^IBCNEUT1($J(ENTRY,3),5)_$$INSCO(IEN)
     116 ... S ^TMP($J,"IBCNSL",2,VALMCNT,0)=X
     117 ... S ^TMP($J,"IBCNSL",2,"IDX",VALMCNT,ENTRY)=""
     118 ... S ^TMP($J,"IBCNSL",3,ENTRY)=IEN_U_VALMCNT
     119 ... Q
     120 .. Q
     121 . Q
     122BLDX ;
     123 Q
     124 ;
     125LINK ; action protocol IBCNSL LINK used to associate children insurance
     126 ; companies to the current parent ins co for the list
     127 NEW DIC,X,Y,DIE,DR,DA,NEWINS,IBSTOP,PAR,DIR,DIRUT,DTOUT,DUOUT,DIROUT
     128 D FULL^VALM1
     129 I '$$KCHK^XUSRB("IB EDI INSURANCE EDIT") D  G LINKX
     130 . W !!?5,"You must hold the IB EDI INSURANCE EDIT key to access this option."
     131 . D PAUSE^VALM1
     132 . Q
     133 ;
     134 ; lookup ins company
     135 W !
     136 S DIC=36,DIC(0)="AEMQ",DIC("A")="Select Insurance Company: "
     137 S DIC("W")="D INSLIST^IBCNSC02(Y)"
     138 ; screen - ins co Y is not a parent and also it is not already in the list of children
     139 S DIC("S")="I $P($G(^DIC(36,Y,3)),U,13)'=""P""&'$D(^DIC(36,""APC"",IBCNS,Y))"
     140 D ^DIC K DIC
     141 I +Y'>0 G LINKX
     142 S NEWINS=+Y
     143 ;
     144 ; check to see if this selected insurance company is already a child
     145 ; for some other parent
     146 S PAR=+$P($G(^DIC(36,NEWINS,3)),U,14),IBSTOP=0
     147 I PAR,PAR'=IBCNS D
     148 . W !
     149 . S DIR(0)="YO",DIR("B")="No"
     150 . S DIR("A",1)="Please Note:  The insurance company you selected is currently identified"
     151 . S DIR("A",2)="as a Child insurance company associated with the following Parent:"
     152 . S DIR("A",3)=""
     153 . S DIR("A",4)="     "_$$INSCO(PAR)
     154 . S DIR("A",5)=""
     155 . S DIR("A")="OK to proceed and make this switch"
     156 . D ^DIR K DIR
     157 . I Y'=1 S IBSTOP=1 Q
     158 . Q
     159 I IBSTOP G LINKX
     160 ;
     161 ; lock the potential new child ins company
     162 L +^DIC(36,NEWINS):0 I '$T D LOCKED^IBTRCD1 G LINKX
     163 ;
     164 ; update selected child
     165 S DIE=36,DA=NEWINS,DR="3.13////C;3.14////"_IBCNS D ^DIE
     166 ;
     167 ; Copy the IDs from the parent
     168 D COPY^IBCEPCID(NEWINS)
     169 ;
     170 ; unlock
     171 L -^DIC(36,NEWINS)
     172 ;
     173 D BLD   ; rebuild list of children
     174LINKX ;
     175 S VALMBCK="R"
     176 Q
     177 ;
     178UNLINK ; action protocol IBCNSL UNLINK used to disassociate selected children
     179 ; insurance companies from the list.
     180 NEW DIR,X,Y,DIRUT,DTOUT,DUOUT,DIROUT,IBLST,IBSUB,IBPCE,IBSEL,DA,DIE,DR
     181 D FULL^VALM1
     182 I '$$KCHK^XUSRB("IB EDI INSURANCE EDIT") D  G UNLINKX
     183 . W !!?5,"You must hold the IB EDI INSURANCE EDIT key to access this option."
     184 . D PAUSE^VALM1
     185 . Q
     186 ;
     187 I '$D(^TMP($J,"IBCNSL",3)) D  G UNLINKX
     188 . W !!?5,"There are no insurance companies to select." D PAUSE^VALM1
     189 . Q
     190 S DIR(0)="LO^1:"_+$O(^TMP($J,"IBCNSL",3,""),-1)
     191 S DIR("A")="Select Insurance Company(s)"
     192 W ! D ^DIR K DIR
     193 I $D(DIRUT) G UNLINKX
     194 M IBLST=Y
     195 ;
     196 W !
     197 S DIR(0)="YO"
     198 S DIR("A")="OK to proceed",DIR("B")="No"
     199 D ^DIR K DIR
     200 I Y'=1 G UNLINKX
     201 ;
     202 F IBSUB=0:1 Q:'$D(IBLST(IBSUB))  F IBPCE=1:1 S IBSEL=$P(IBLST(IBSUB),",",IBPCE) Q:'IBSEL  D
     203 . S DA=+$G(^TMP($J,"IBCNSL",3,IBSEL)) I 'DA Q
     204 . S DIE=36,DR="3.13////@;3.14////@" D ^DIE
     205 . Q
     206 ;
     207 D BLD   ; rebuild list of children
     208UNLINKX ;
     209 S VALMBCK="R"
     210 Q
     211 ;
     212PCNT(Z) ; count number of children for parent ins co Z
     213 NEW C,CNT
     214 S C=0,Z=+$G(Z)
     215 F CNT=0:1 S C=$O(^DIC(36,"APC",Z,C)) Q:'C
     216 Q CNT
     217 ;
     218INSADD(Z) ; function to return ins co address components
     219 NEW INSDATA,AD,NM,L1,CITY,ST,ZIP,CITYST,STCITY
     220 S INSDATA=""
     221 S AD=$G(^DIC(36,+$G(Z),.11))
     222 S NM=$P($G(^DIC(36,Z,0)),U,1)
     223 S L1=$P(AD,U,1),CITY=$P(AD,U,4),ST=$P(AD,U,5),ZIP=$P(AD,U,6)
     224 I ST S ST=$P($G(^DIC(5,ST,0)),U,2)
     225 S CITYST=$E(CITY,1,15)_" "_ST
     226 I CITY'="",ST'="" S CITYST=$E(CITY,1,15)_","_ST
     227 ;
     228 S $P(STCITY,"|",1)=ST
     229 I ST="" S $P(STCITY,"|",1)="~~"
     230 S $P(STCITY,"|",2)=CITY
     231 I CITY="" S $P(STCITY,"|",2)="~~~~"
     232 ;
     233 S INSDATA=NM_U_L1_U_CITY_U_ST_U_ZIP_U_CITYST_U_STCITY
     234 ;         1    2    3      4    5     6        7
     235INSADDX ;
     236 Q INSDATA
     237 ;
     238INSCO(Z) ; return display data for ins co Z
     239 NEW X,Y
     240 S Y=$$INSADD(Z)
     241 S X=$$FO^IBCNEUT1($P(Y,U,1),27)
     242 S X=X_$$FO^IBCNEUT1($P(Y,U,2),26)
     243 S X=X_$$FO^IBCNEUT1($P(Y,U,6),18)
     244INSCOX ;
     245 Q X
     246 ;
     247INSLIST(INS) ; insurance company lister for ^DIC call
     248 NEW Z
     249 S Z=$$INSADD(INS)
     250 W ?27,$E($P(Z,U,2),1,20)   ; address line 1
     251 W ?47,"  ",$P(Z,U,6)       ; city, state
     252INSLISTX ;
     253 Q
     254 ;

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSC1.m

    r613 r623  
    1 IBCNSC1 ;ALB/NLR - IBCNS INSURANCE COMPANY ;23-MAR-93
    2         ;;2.0;INTEGRATED BILLING;**62,137,232,291,320,348,349,371**;21-MAR-94;Build 57
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5 %       G EN^IBCNSC
    6         ;
    7 AI      ; -- (In)Activate Company
    8         D FULL^VALM1 W !!
    9         I '$D(^XUSEC("IB INSURANCE SUPERVISOR",DUZ)) D SORRY G EXIT
    10         D ^IBCNSC2
    11         G EXIT
    12 CC      ; -- Change Insurance Company
    13         D FULL^VALM1 W !!
    14         S IBCNS1=IBCNS K IBCNS D INSCO^IBCNSC
    15         I '$D(IBCNS) S IBCNS=IBCNS1
    16         K IBCNS1,VALMQUIT
    17         G EXIT
    18 EA      ; -- Billing,Claims,Appeals,Inquiry,Telephone,Main,Remarks,Synonyms
    19         D FULL^VALM1
    20         ;
    21         ; IB*2*320 - check key for associate company action
    22         I $G(IBY)=",13,",'$$KCHK^XUSRB("IB EDI INSURANCE EDIT") D  G EXIT
    23         . W !!?5,"You must hold the IB EDI INSURANCE EDIT key to access this option."
    24         . D PAUSE^VALM1
    25         . Q
    26         ;
    27         W !!
    28         D MAIN
    29         ;
    30         ; -- was company deleted
    31         I '$D(^DIC(36,IBCNS)) W !!,"<DELETED>",!! S VALMQUIT="" Q
    32         ;
    33 EXIT    ;
    34         D HDR^IBCNSC,BLD^IBCNSC
    35         S VALMBCK="R"
    36         Q
    37 MAIN    ; -- Call edit template
    38         N IBEDIKEY,Z
    39         L +^DIC(36,+IBCNS):5 I '$T D LOCKED^IBTRCD1 G MAINQ
    40         I $G(IBY)=",12," D FACID
    41         F Z=1,2,4,9,13,14 S IBEDIKEY(Z)=$P($G(^DIC(36,+IBCNS,3)),U,Z)   ; save EDI data fields
    42         F Z=1:1:8 S IBEDIKEY(Z,6)=$P($G(^DIC(36,+IBCNS,6)),U,Z)   ; save EDI data fields
    43         I $G(IBY)'=",12," N DIE,DA,DR S DIE="^DIC(36,",(DA,Y)=IBCNS,DR="[IBEDIT INS CO1]" D ^DIE K DIE S:$D(Y) IB("^")=1 D:$TR($P($G(^DIC(36,IBCNS,6)),U,1,8),U)]"" CUIDS(IBCNS)
    44         I $G(IBY)=",12," D EDITID^IBCEP(+IBCNS)
    45         I $F(",6,13,",$G(IBY)) D PARENT^IBCNSC02(+IBCNS)   ; parent/child management
    46         L -^DIC(36,+IBCNS)
    47 MAINQ   Q
    48         ;
    49 FACID   ; -- Edit facility ids
    50         D FACID^IBCEP2B(+IBCNS,"E")
    51         Q
    52         ;
    53 SORRY   ; -- can't inactivate, don't have key
    54         W !!,"You do not have access to Inactivate entries.  See your application coordinator.",! D PAUSE^VALM1
    55         Q
    56 PRESCR  ;
    57         N OFFSET,START,IBCNS18,IBADD
    58         S IBCNS18=$$ADDRESS^IBCNSC0(IBCNS,.18,11)
    59         S START=41,OFFSET=2
    60         D SET^IBCNSP(START,OFFSET+19," Prescription Claims Office Information ",IORVON,IORVOFF)
    61         D SET^IBCNSP(START+1,OFFSET," Company Name: "_$P($G(^DIC(36,+$P(IBCNS18,"^",7),0)),"^",1))
    62         D SET^IBCNSP(START+2,OFFSET,"       Street: "_$P(IBCNS18,"^",1))
    63         D SET^IBCNSP(START+3,OFFSET,"     Street 2: "_$P(IBCNS18,"^",2))
    64         ; D SET^IBCNSP(START+4,OFFSET,"Claim Off. ID: "_$P(IBCNS18,"^",11))
    65         N OFFSET S OFFSET=45
    66         D SET^IBCNSP(START+1,OFFSET,"     Street 3: "_$P(IBCNS18,"^",3)) S IBADD=1
    67         D SET^IBCNSP(START+1+IBADD,OFFSET,"   City/State: "_$E($P(IBCNS18,"^",4),1,15)_$S($P(IBCNS18,"^",4)="":"",1:", ")_$P($G(^DIC(5,+$P(IBCNS18,"^",5),0)),"^",2)_" "_$E($P(IBCNS18,"^",6),1,5))
    68         D SET^IBCNSP(START+2+IBADD,OFFSET,"        Phone: "_$P(IBCNS18,"^",8))
    69         D SET^IBCNSP(START+3+IBADD,OFFSET,"          Fax: "_$P(IBCNS18,"^",9))
    70         Q
    71         ;
    72 PROVID  N OFFSET,START,IBCNS4,IBCNS3,IBDISP,Z,LINE
    73         S START=$O(^TMP("IBCNSC",$J,""),-1)+1
    74         S (IB1ST("PROVID"),LINE)=START
    75         S OFFSET=2,IBCNS4=$G(^DIC(36,IBCNS,4)),IBCNS3=$G(^(3))
    76         ;       
    77         D SET^IBCNSP(LINE,OFFSET+25,"Provider IDs",IORVON,IORVOFF)
    78         N OFFSET
    79         S LINE=LINE+1,OFFSET=1
    80         D SET^IBCNSP(LINE,OFFSET,"Billing Provider Secondary ID")
    81         ;
    82         N Z,Z0,Z1,IBS,I,DIV,FT,CU,CUF,DIVISION,FORMTYPE,PIDT
    83         S Z=0 F  S Z=$O(^IBA(355.92,"B",+IBCNS,Z)) Q:'Z  D
    84         . S Z0=$G(^IBA(355.92,Z,0))
    85         . Q:'$P(Z0,U,6)!($P(Z0,U,7)="")  ; Quit if no provider id or id type
    86         . Q:'($P(Z0,U,8)="E")
    87         . S IBS(+$P(Z0,U,5),+$P(Z0,U,3),+$P(Z0,U,4))=$P(Z0,U,6)_U_$P(Z0,U,7)
    88         ;
    89         S DIV="" F  S DIV=$O(IBS(DIV)) Q:DIV=""  D
    90         . S DIVISION=$$DIV^IBCEP7(DIV)
    91         . S CU="",CUF=0 F  S CU=$O(IBS(DIV,CU)) Q:CU=""  D
    92         .. S FT="" F  S FT=$O(IBS(DIV,CU,FT)) Q:FT=""  D
    93         ... S FORMTYPE=$S(FT=1:"UB-04",FT=2:"1500",1:"UNKNOWN")
    94         ... S LINE=LINE+1
    95         ... I 'CUF,+CU S CUF=1 S TEXT=$P(DIVISION,"/")_" Care Units :",OFFSET=5 D SET^IBCNSP(LINE,OFFSET,TEXT) S LINE=LINE+1
    96         ... I CU=0 S TEXT=DIVISION_"/"_FORMTYPE_": "_$$GET1^DIQ(355.97,$P(IBS(DIV,CU,FT),U),.03,"E")_" "_$P(IBS(DIV,CU,FT),U,2),OFFSET=2
    97         ... I +CU S TEXT=$$EXPAND^IBTRE(355.92,.03,CU)_"/"_FORMTYPE_": "_$$GET1^DIQ(355.97,$P(IBS(DIV,CU,FT),U),.03,"E")_" "_$P(IBS(DIV,CU,FT),U,2),OFFSET=5
    98         ... D SET^IBCNSP(LINE,OFFSET,TEXT)
    99         ;
    100         S LINE=LINE+1 D SET^IBCNSP(LINE,2," ")
    101         ;
    102         K IBS
    103         S OFFSET=1,LINE=LINE+1
    104         D SET^IBCNSP(LINE,OFFSET,"Additional Billing Provider Secondary IDs")
    105         S Z=0 F  S Z=$O(^IBA(355.92,"B",+IBCNS,Z)) Q:'Z  D
    106         . S Z0=$G(^IBA(355.92,Z,0))
    107         . Q:'$P(Z0,U,6)!($P(Z0,U,7)="")  ; Quit if no provider id or id type
    108         . Q:'($P(Z0,U,8)="A")
    109         . ; IBS(DIVISION,FORMTYPE,IDTYPE)=ID
    110         . S IBS(+$P(Z0,U,5),+$P(Z0,U,4),+$P(Z0,U,6))=$P(Z0,U,7)
    111         ;
    112         S DIVISION=$$DIV^IBCEP7(0)
    113         S DIV="" F  S DIV=$O(IBS(DIV)) Q:DIV=""  D
    114         . S FT="" F  S FT=$O(IBS(DIV,FT)) Q:FT=""  D
    115         .. S FORMTYPE=$S(FT=1:"UB-04",FT=2:"1500",1:"UNKNOWN")
    116         .. S TEXT=DIVISION_"/"_FORMTYPE_": "
    117         .. S LINE=LINE+1,OFFSET=2
    118         .. D SET^IBCNSP(LINE,OFFSET,TEXT)
    119         .. S PIDT="" F  S PIDT=$O(IBS(DIV,FT,PIDT)) Q:PIDT=""  D
    120         ... S LINE=LINE+1
    121         ... S TEXT=$$GET1^DIQ(355.97,PIDT,.03,"E")_" "_IBS(DIV,FT,PIDT),OFFSET=5
    122         ... D SET^IBCNSP(LINE,OFFSET,TEXT)
    123         ;
    124         S LINE=LINE+1 D SET^IBCNSP(LINE,2," ")
    125         ;
    126         K IBS
    127         S OFFSET=1,LINE=LINE+1
    128         D SET^IBCNSP(LINE,OFFSET,"VA-Laboratory or Facility Secondary IDs")
    129         S Z=0 F  S Z=$O(^IBA(355.92,"B",+IBCNS,Z)) Q:'Z  D
    130         . S Z0=$G(^IBA(355.92,Z,0))
    131         . Q:'$P(Z0,U,6)!($P(Z0,U,7)="")  ; Quit if no provider id or id type
    132         . Q:'($P(Z0,U,8)="LF")
    133         . ; IBS(DIVISION,FORMTYPE,IDTYPE)=ID
    134         . S IBS(+$P(Z0,U,5),+$P(Z0,U,4),+$P(Z0,U,6))=$P(Z0,U,7)
    135         ;
    136         S DIVISION=$$DIV^IBCEP7(0)
    137         S DIV="" F  S DIV=$O(IBS(DIV)) Q:DIV=""  D
    138         . S FT="" F  S FT=$O(IBS(DIV,FT)) Q:FT=""  D
    139         .. S FORMTYPE=$S(FT=1:"UB-04",FT=2:"1500",1:"UNKNOWN")
    140         .. S TEXT=DIVISION_"/"_FORMTYPE_": "
    141         .. S LINE=LINE+1,OFFSET=2
    142         .. D SET^IBCNSP(LINE,OFFSET,TEXT)
    143         .. S PIDT="" F  S PIDT=$O(IBS(DIV,FT,PIDT)) Q:PIDT=""  D
    144         ... S LINE=LINE+1
    145         ... ;S TEXT=$$EXPAND^IBTRE(355.92,.06,PIDT)_" "_IBS(DIV,FT,PIDT),OFFSET=5
    146         ... S TEXT=$$GET1^DIQ(355.97,PIDT,.03,"E")_" "_IBS(DIV,FT,PIDT),OFFSET=5
    147         ... D SET^IBCNSP(LINE,OFFSET,TEXT)
    148         ;
    149         ;
    150         S LINE=LINE+1 D SET^IBCNSP(LINE,2," ")
    151         S LINE=LINE+1 D SET^IBCNSP(LINE,2," ")
    152         S OFFSET=2
    153         S LINE=LINE+1 D SET^IBCNSP(LINE,OFFSET+25,"ID Parameters",IORVON,IORVOFF)
    154         ;
    155         S IBCNS4=$G(^DIC(36,IBCNS,4)),IBCNS3=$G(^(3)),OFFSET=1
    156         S TEXT="Attending/Rendering Provider Secondary ID Qualifier (1500): "_$$EXPAND^IBTRE(36,4.01,+$P(IBCNS4,U))
    157         S LINE=LINE+1
    158         D SET^IBCNSP(LINE,OFFSET,TEXT)
    159         ;
    160         S TEXT="Attending/Rendering Provider Secondary ID Qualifier (UB-04): "_$$EXPAND^IBTRE(36,4.02,+$P(IBCNS4,U,2))
    161         S LINE=LINE+1
    162         D SET^IBCNSP(LINE,OFFSET,TEXT)
    163         ;
    164         S TEXT="Attending/Rendering Secondary ID Requirement: "_$$EXPAND^IBTRE(36,4.03,+$P(IBCNS4,U,3))
    165         S LINE=LINE+1
    166         D SET^IBCNSP(LINE,OFFSET,TEXT)
    167         ;
    168         S TEXT="Referring Provider Secondary ID Qualifier (1500): "_$$EXPAND^IBTRE(36,4.04,+$P(IBCNS4,U,4))
    169         S LINE=LINE+1
    170         D SET^IBCNSP(LINE,OFFSET,TEXT)
    171         ;
    172         S TEXT="Referring Provider Secondary ID Requirement: "_$$EXPAND^IBTRE(36,4.05,+$P(IBCNS4,U,5))
    173         S LINE=LINE+1
    174         D SET^IBCNSP(LINE,OFFSET,TEXT)
    175         ;
    176         S TEXT="Use Att/Rend ID as Billing Provider Sec. ID (1500): "_$$EXPAND^IBTRE(36,4.06,+$P(IBCNS4,U,6))
    177         S LINE=LINE+1
    178         D SET^IBCNSP(LINE,OFFSET,TEXT)
    179         ;
    180         S TEXT="Use Att/Rend ID as Billing Provider Sec. ID (UB-04): "_$$EXPAND^IBTRE(36,4.08,+$P(IBCNS4,U,8))
    181         S LINE=LINE+1
    182         D SET^IBCNSP(LINE,OFFSET,TEXT)
    183         ;
    184         S TEXT="Send VA Lab/Facility IDs or Facility Data for VAMC?: "_$$EXPAND^IBTRE(36,4.07,+$P(IBCNS4,U,7))
    185         S LINE=LINE+1
    186         D SET^IBCNSP(LINE,OFFSET,TEXT)
    187         ;
    188         S TEXT="Transmit no Billing Provider Sec. ID for the Electronic Plan Types: "
    189         S LINE=LINE+1
    190         D SET^IBCNSP(LINE,OFFSET,TEXT)
    191         ;
    192         N TAR,ERR,IBCT
    193         D LIST^DIC(36.013,","_IBCNS_",",".01",,10,,,,,,"TAR","ERR")
    194         F IBCT=1:1:+$G(TAR("DILIST",0)) D
    195         . S TEXT=TAR("DILIST",1,IBCT)
    196         . S LINE=LINE+1
    197         . D SET^IBCNSP(LINE,OFFSET,TEXT)
    198         ;
    199         S LINE=LINE+1 D SET^IBCNSP(LINE,2," ")
    200         S LINE=LINE+1 D SET^IBCNSP(LINE,2," ")
    201         Q
    202         ;       
    203 INSDEF(IBINS,IBPTYP)    ; Returns the default id # for an ins co, if possible
    204         N X
    205         S X=""
    206         I IBINS,IBPTYP S X=$P($G(^IBA(355.91,+$O(^IBA(355.91,"AC",IBINS,IBPTYP,"*N/A*","")),0)),U,7)
    207         Q X
    208         ;
    209 CUIDS(IBCNS)    ;
    210         N DIE,DA,DR,PIECE,DAT6,Y
    211         S DAT6=$P(^DIC(36,IBCNS,6),U,1,8) ; get the Payer IDs
    212         ;
    213         ; Make sure each qualifier has an ID and vice versa
    214         F PIECE=1,3,5,7 D
    215         . I $TR($P(DAT6,U,PIECE,PIECE+1),U)="" Q  ; both blank
    216         . I $P(DAT6,U,PIECE)]"",$P(DAT6,U,PIECE+1)]"" Q  ; both have data
    217         . S DIE="^DIC(36,",(DA,Y)=IBCNS,DR="6.0"_$S($P(DAT6,U,PIECE)]"":PIECE,1:PIECE+1)_"////@"
    218         . D ^DIE K DIE
    219         ;
    220         S DAT6=$P($G(^DIC(36,IBCNS,6)),U,1,8) ; get the Payer IDs again since they may have changed above.
    221         ;
    222         ; Make sure the first pair of ID/Qual are populated if the 2nd pair is.  If not, move em over.
    223         ; This is done for institutional then professional
    224         F PIECE=1,5 D
    225         . I $P(DAT6,U,PIECE)]"" Q  ; already has set one
    226         . I $P(DAT6,U,PIECE+2)="" Q  ; has no second set
    227         . S DIE="^DIC(36,",(DA,Y)=IBCNS
    228         . ; deleting the qualifier triggers deletion of the ID
    229         . S DR="6.0"_PIECE_"////"_$P(DAT6,U,PIECE+2)_";6.0"_(PIECE+1)_"////"_$P(DAT6,U,PIECE+3)_";6.0"_(PIECE+2)_"////@"
    230         . D ^DIE K DIE
    231         Q
     1IBCNSC1 ;ALB/NLR - IBCNS INSURANCE COMPANY ;23-MAR-93
     2 ;;2.0;INTEGRATED BILLING;**62,137,232,291,320,348,349**;21-MAR-94;Build 46
     3 ;;Per VHA Directive 2004-038, this routine should not be modified.
     4 ;
     5% G EN^IBCNSC
     6 ;
     7AI ; -- (In)Activate Company
     8 D FULL^VALM1 W !!
     9 I '$D(^XUSEC("IB INSURANCE SUPERVISOR",DUZ)) D SORRY G EXIT
     10 D ^IBCNSC2
     11 G EXIT
     12CC ; -- Change Insurance Company
     13 D FULL^VALM1 W !!
     14 S IBCNS1=IBCNS K IBCNS D INSCO^IBCNSC
     15 I '$D(IBCNS) S IBCNS=IBCNS1
     16 K IBCNS1,VALMQUIT
     17 G EXIT
     18EA ; -- Billing,Claims,Appeals,Inquiry,Telephone,Main,Remarks,Synonyms
     19 D FULL^VALM1
     20 ;
     21 ; IB*2*320 - check key for associate company action
     22 I $G(IBY)=",13,",'$$KCHK^XUSRB("IB EDI INSURANCE EDIT") D  G EXIT
     23 . W !!?5,"You must hold the IB EDI INSURANCE EDIT key to access this option."
     24 . D PAUSE^VALM1
     25 . Q
     26 ;
     27 W !!
     28 D MAIN
     29 ;
     30 ; -- was company deleted
     31 I '$D(^DIC(36,IBCNS)) W !!,"<DELETED>",!! S VALMQUIT="" Q
     32 ;
     33EXIT ;
     34 D HDR^IBCNSC,BLD^IBCNSC
     35 S VALMBCK="R"
     36 Q
     37MAIN ; -- Call edit template
     38 N IBEDIKEY,Z
     39 L +^DIC(36,+IBCNS):5 I '$T D LOCKED^IBTRCD1 G MAINQ
     40 I $G(IBY)=",12," D FACID
     41 F Z=1,2,4,9,13,14 S IBEDIKEY(Z)=$P($G(^DIC(36,+IBCNS,3)),U,Z)   ; save EDI data fields
     42 I $G(IBY)'=",12," N DIE,DA,DR S DIE="^DIC(36,",(DA,Y)=IBCNS,DR="[IBEDIT INS CO1]" D ^DIE K DIE I $D(Y) S IB("^")=1
     43 I $G(IBY)=",12," D EDITID^IBCEP(+IBCNS)
     44 I $F(",6,13,",$G(IBY)) D PARENT^IBCNSC02(+IBCNS)   ; parent/child management
     45 L -^DIC(36,+IBCNS)
     46MAINQ Q
     47 ;
     48FACID ; -- Edit facility ids
     49 D FACID^IBCEP2B(+IBCNS,"E")
     50 Q
     51 ;
     52SORRY ; -- can't inactivate, don't have key
     53 W !!,"You do not have access to Inactivate entries.  See your application coordinator.",! D PAUSE^VALM1
     54 Q
     55PRESCR ;
     56 N OFFSET,START,IBCNS18,IBADD
     57 S IBCNS18=$$ADDRESS^IBCNSC0(IBCNS,.18,11)
     58 S START=34,OFFSET=2
     59 D SET^IBCNSP(START,OFFSET+19," Prescription Claims Office Information ",IORVON,IORVOFF)
     60 D SET^IBCNSP(START+1,OFFSET," Company Name: "_$P($G(^DIC(36,+$P(IBCNS18,"^",7),0)),"^",1))
     61 D SET^IBCNSP(START+2,OFFSET,"       Street: "_$P(IBCNS18,"^",1))
     62 D SET^IBCNSP(START+3,OFFSET,"     Street 2: "_$P(IBCNS18,"^",2))
     63 ; D SET^IBCNSP(START+4,OFFSET,"Claim Off. ID: "_$P(IBCNS18,"^",11))
     64 N OFFSET S OFFSET=45
     65 D SET^IBCNSP(START+1,OFFSET,"     Street 3: "_$P(IBCNS18,"^",3)) S IBADD=1
     66 D SET^IBCNSP(START+1+IBADD,OFFSET,"   City/State: "_$E($P(IBCNS18,"^",4),1,15)_$S($P(IBCNS18,"^",4)="":"",1:", ")_$P($G(^DIC(5,+$P(IBCNS18,"^",5),0)),"^",2)_" "_$E($P(IBCNS18,"^",6),1,5))
     67 D SET^IBCNSP(START+2+IBADD,OFFSET,"        Phone: "_$P(IBCNS18,"^",8))
     68 D SET^IBCNSP(START+3+IBADD,OFFSET,"          Fax: "_$P(IBCNS18,"^",9))
     69 Q
     70 ;
     71PROVID N OFFSET,START,IBCNS4,IBCNS3,IBDISP,Z,LINE
     72 S START=$O(^TMP("IBCNSC",$J,""),-1)+1
     73 S (IB1ST("PROVID"),LINE)=START
     74 S OFFSET=2,IBCNS4=$G(^DIC(36,IBCNS,4)),IBCNS3=$G(^(3))
     75 ;       
     76 D SET^IBCNSP(LINE,OFFSET+25,"Provider IDs",IORVON,IORVOFF)
     77 N OFFSET
     78 S LINE=LINE+1,OFFSET=1
     79 D SET^IBCNSP(LINE,OFFSET,"Billing Provider Secondary ID")
     80 ;
     81 N Z,Z0,Z1,IBS,I,DIV,FT,CU,CUF,DIVISION,FORMTYPE,PIDT
     82 S Z=0 F  S Z=$O(^IBA(355.92,"B",+IBCNS,Z)) Q:'Z  D
     83 . S Z0=$G(^IBA(355.92,Z,0))
     84 . Q:'$P(Z0,U,6)!($P(Z0,U,7)="")  ; Quit if no provider id or id type
     85 . Q:'($P(Z0,U,8)="E")
     86 . S IBS(+$P(Z0,U,5),+$P(Z0,U,3),+$P(Z0,U,4))=$P(Z0,U,6)_U_$P(Z0,U,7)
     87 ;
     88 S DIV="" F  S DIV=$O(IBS(DIV)) Q:DIV=""  D
     89 . S DIVISION=$$DIV^IBCEP7(DIV)
     90 . S CU="",CUF=0 F  S CU=$O(IBS(DIV,CU)) Q:CU=""  D
     91 .. S FT="" F  S FT=$O(IBS(DIV,CU,FT)) Q:FT=""  D
     92 ... S FORMTYPE=$S(FT=1:"UB-04",FT=2:"1500",1:"UNKNOWN")
     93 ... S LINE=LINE+1
     94 ... I 'CUF,+CU S CUF=1 S TEXT=$P(DIVISION,"/")_" Care Units :",OFFSET=5 D SET^IBCNSP(LINE,OFFSET,TEXT) S LINE=LINE+1
     95 ... I CU=0 S TEXT=DIVISION_"/"_FORMTYPE_": "_$$GET1^DIQ(355.97,$P(IBS(DIV,CU,FT),U),.03,"E")_" "_$P(IBS(DIV,CU,FT),U,2),OFFSET=2
     96 ... I +CU S TEXT=$$EXPAND^IBTRE(355.92,.03,CU)_"/"_FORMTYPE_": "_$$GET1^DIQ(355.97,$P(IBS(DIV,CU,FT),U),.03,"E")_" "_$P(IBS(DIV,CU,FT),U,2),OFFSET=5
     97 ... D SET^IBCNSP(LINE,OFFSET,TEXT)
     98 ;
     99 S LINE=LINE+1 D SET^IBCNSP(LINE,2," ")
     100 ;
     101 K IBS
     102 S OFFSET=1,LINE=LINE+1
     103 D SET^IBCNSP(LINE,OFFSET,"Additional Billing Provider Secondary IDs")
     104 S Z=0 F  S Z=$O(^IBA(355.92,"B",+IBCNS,Z)) Q:'Z  D
     105 . S Z0=$G(^IBA(355.92,Z,0))
     106 . Q:'$P(Z0,U,6)!($P(Z0,U,7)="")  ; Quit if no provider id or id type
     107 . Q:'($P(Z0,U,8)="A")
     108 . ; IBS(DIVISION,FORMTYPE,IDTYPE)=ID
     109 . S IBS(+$P(Z0,U,5),+$P(Z0,U,4),+$P(Z0,U,6))=$P(Z0,U,7)
     110 ;
     111 S DIVISION=$$DIV^IBCEP7(0)
     112 S DIV="" F  S DIV=$O(IBS(DIV)) Q:DIV=""  D
     113 . S FT="" F  S FT=$O(IBS(DIV,FT)) Q:FT=""  D
     114 .. S FORMTYPE=$S(FT=1:"UB-04",FT=2:"1500",1:"UNKNOWN")
     115 .. S TEXT=DIVISION_"/"_FORMTYPE_": "
     116 .. S LINE=LINE+1,OFFSET=2
     117 .. D SET^IBCNSP(LINE,OFFSET,TEXT)
     118 .. S PIDT="" F  S PIDT=$O(IBS(DIV,FT,PIDT)) Q:PIDT=""  D
     119 ... S LINE=LINE+1
     120 ... S TEXT=$$GET1^DIQ(355.97,PIDT,.03,"E")_" "_IBS(DIV,FT,PIDT),OFFSET=5
     121 ... D SET^IBCNSP(LINE,OFFSET,TEXT)
     122 ;
     123 S LINE=LINE+1 D SET^IBCNSP(LINE,2," ")
     124 ;
     125 K IBS
     126 S OFFSET=1,LINE=LINE+1
     127 D SET^IBCNSP(LINE,OFFSET,"VA-Laboratory or Facility Secondary IDs")
     128 S Z=0 F  S Z=$O(^IBA(355.92,"B",+IBCNS,Z)) Q:'Z  D
     129 . S Z0=$G(^IBA(355.92,Z,0))
     130 . Q:'$P(Z0,U,6)!($P(Z0,U,7)="")  ; Quit if no provider id or id type
     131 . Q:'($P(Z0,U,8)="LF")
     132 . ; IBS(DIVISION,FORMTYPE,IDTYPE)=ID
     133 . S IBS(+$P(Z0,U,5),+$P(Z0,U,4),+$P(Z0,U,6))=$P(Z0,U,7)
     134 ;
     135 S DIVISION=$$DIV^IBCEP7(0)
     136 S DIV="" F  S DIV=$O(IBS(DIV)) Q:DIV=""  D
     137 . S FT="" F  S FT=$O(IBS(DIV,FT)) Q:FT=""  D
     138 .. S FORMTYPE=$S(FT=1:"UB-04",FT=2:"1500",1:"UNKNOWN")
     139 .. S TEXT=DIVISION_"/"_FORMTYPE_": "
     140 .. S LINE=LINE+1,OFFSET=2
     141 .. D SET^IBCNSP(LINE,OFFSET,TEXT)
     142 .. S PIDT="" F  S PIDT=$O(IBS(DIV,FT,PIDT)) Q:PIDT=""  D
     143 ... S LINE=LINE+1
     144 ... ;S TEXT=$$EXPAND^IBTRE(355.92,.06,PIDT)_" "_IBS(DIV,FT,PIDT),OFFSET=5
     145 ... S TEXT=$$GET1^DIQ(355.97,PIDT,.03,"E")_" "_IBS(DIV,FT,PIDT),OFFSET=5
     146 ... D SET^IBCNSP(LINE,OFFSET,TEXT)
     147 ;
     148 ;
     149 S LINE=LINE+1 D SET^IBCNSP(LINE,2," ")
     150 S LINE=LINE+1 D SET^IBCNSP(LINE,2," ")
     151 S OFFSET=2
     152 S LINE=LINE+1 D SET^IBCNSP(LINE,OFFSET+25,"ID Parameters",IORVON,IORVOFF)
     153 ;
     154 S IBCNS4=$G(^DIC(36,IBCNS,4)),IBCNS3=$G(^(3)),OFFSET=1
     155 S TEXT="Attending/Rendering Provider Secondary ID Qualifier (1500): "_$$EXPAND^IBTRE(36,4.01,+$P(IBCNS4,U))
     156 S LINE=LINE+1
     157 D SET^IBCNSP(LINE,OFFSET,TEXT)
     158 ;
     159 S TEXT="Attending/Rendering Provider Secondary ID Qualifier (UB-04): "_$$EXPAND^IBTRE(36,4.02,+$P(IBCNS4,U,2))
     160 S LINE=LINE+1
     161 D SET^IBCNSP(LINE,OFFSET,TEXT)
     162 ;
     163 S TEXT="Attending/Rendering Secondary ID Requirement: "_$$EXPAND^IBTRE(36,4.03,+$P(IBCNS4,U,3))
     164 S LINE=LINE+1
     165 D SET^IBCNSP(LINE,OFFSET,TEXT)
     166 ;
     167 S TEXT="Referring Provider Secondary ID Qualifier (1500): "_$$EXPAND^IBTRE(36,4.04,+$P(IBCNS4,U,4))
     168 S LINE=LINE+1
     169 D SET^IBCNSP(LINE,OFFSET,TEXT)
     170 ;
     171 S TEXT="Referring Provider Secondary ID Requirement: "_$$EXPAND^IBTRE(36,4.05,+$P(IBCNS4,U,5))
     172 S LINE=LINE+1
     173 D SET^IBCNSP(LINE,OFFSET,TEXT)
     174 ;
     175 S TEXT="Use Att/Rend ID as Billing Provider Sec. ID (1500): "_$$EXPAND^IBTRE(36,4.06,+$P(IBCNS4,U,6))
     176 S LINE=LINE+1
     177 D SET^IBCNSP(LINE,OFFSET,TEXT)
     178 ;
     179 S TEXT="Use Att/Rend ID as Billing Provider Sec. ID (UB-04): "_$$EXPAND^IBTRE(36,4.08,+$P(IBCNS4,U,8))
     180 S LINE=LINE+1
     181 D SET^IBCNSP(LINE,OFFSET,TEXT)
     182 ;
     183 S TEXT="Send VA Lab/Facility IDs or Facility Data for VAMC?: "_$$EXPAND^IBTRE(36,4.07,+$P(IBCNS4,U,7))
     184 S LINE=LINE+1
     185 D SET^IBCNSP(LINE,OFFSET,TEXT)
     186 ;
     187 S TEXT="Transmit no Billing Provider Sec. ID for the Electronic Plan Types: "
     188 S LINE=LINE+1
     189 D SET^IBCNSP(LINE,OFFSET,TEXT)
     190 ;
     191 N TAR,ERR,IBCT
     192 D LIST^DIC(36.013,","_IBCNS_",",".01",,10,,,,,,"TAR","ERR")
     193 F IBCT=1:1:+$G(TAR("DILIST",0)) D
     194 . S TEXT=TAR("DILIST",1,IBCT)
     195 . S LINE=LINE+1
     196 . D SET^IBCNSP(LINE,OFFSET,TEXT)
     197 ;
     198 S LINE=LINE+1 D SET^IBCNSP(LINE,2," ")
     199 S LINE=LINE+1 D SET^IBCNSP(LINE,2," ")
     200 Q
     201 ;       
     202INSDEF(IBINS,IBPTYP) ; Returns the default id # for an ins co, if possible
     203 N X
     204 S X=""
     205 I IBINS,IBPTYP S X=$P($G(^IBA(355.91,+$O(^IBA(355.91,"AC",IBINS,IBPTYP,"*N/A*","")),0)),U,7)
     206 Q X

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSEH.m

    r613 r623  
    1 IBCNSEH ;ALB/AAS - EXTENDED HELP FOR INSURANCE MANAGEMENT ;28-MAY-93
    2         ;;2.0;INTEGRATED BILLING;**6,28,371**;21-MAR-94;Build 57
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5 INS     ; -- Help for Insurance Type
    6         Q:'$G(IBCNSEH)
    7         W !!,"The way we store and think about patient insurance information has been"
    8         W !,"dramatically changed.  We are separating out information that is specific"
    9         W !,"to an insurance company, specific to the patient, specific to the group plan,"
    10         W !,"specific to the annual benefits available, and the annual benefits already"
    11         W !,"used."
    12         W !!,"To start, you must select the insurance company for the patient's policy.",!
    13         Q
    14 PAT     ; -- Help for entering patient specific information
    15         Q:'$G(IBCNSEH)
    16         W !!,"Now you may enter the patient specific policy information.",!
    17         Q
    18 POL     ; -- Help for policy specific information
    19         Q:'$G(IBCNSEH)
    20         W !!,"You can now edit information specific to the PLAN.  Remember, updating"
    21         W !,"PLAN information will affect all patients with this plan, if it is a"
    22         W !,"group plan, and not just the current patient.",!
    23         Q
    24         ;
    25 SEL     ; -- help for selecting a new HIP
    26         Q:'$G(IBCNSEH)
    27         W !!,"Each Insurance policy entry for a patient must be associated with an"
    28         W !,"Insurance Plan offered by the Insurance company you just selected."
    29         W !,"You will be given a choice of selecting previously entered Group Plans or"
    30         W !,"you may enter a new one.  If you enter a new Insurance Plan you"
    31         W !,"must enter whether or not this is a group or individual plan.",!
    32         Q
    33 AB      ;
    34         Q:'$G(IBCNSEH)
    35         Q
    36 BU      ;
    37         Q:'$G(IBCNSEH)
    38         Q
     1IBCNSEH ;ALB/AAS - EXTENDED HELP FOR INSURANCE MANAGEMENT - 28-MAY-93
     2 ;;Version 2.0 ; INTEGRATED BILLING ;**6,28**; 21-MAR-94
     3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
     4 ;
     5INS ; -- Help for Insurance Type
     6 Q:'$G(IBCNSEH)
     7 W !!,"The way we store and think about patient insurance information has been"
     8 W !,"dramatically changed.  We are separating out information that is specific"
     9 W !,"to an insurance company, specific to the patient, specific to the group plan,"
     10 W !,"specific to the annual benefits available, and the annual benefits already"
     11 W !,"used."
     12 W !!,"To start, you must select the insurance company for the patient's policy.",!
     13 Q
     14PAT ; -- Help for entering patient specific information
     15 Q:'$G(IBCNSEH)
     16 W !!,"Now you may enter the patient specific policy information."
     17 W !,"Most of these fields will be familiar to experienced users.  The field"
     18 W !,"'SUBSCRIBER ID' used to be called 'INSURANCE NUMBER' and "
     19 W !,"has been modified to allow entering just 'SS' to retrieve"
     20 W !,"the patients SSN.  This field is the identifier for the policy or patient"
     21 W !,"that the carrier uses.  See the new help.",!
     22 Q
     23POL ; -- Help for policy specific information
     24 Q:'$G(IBCNSEH)
     25 W !!,"You can now edit information specific to the PLAN.  Remember, updating"
     26 W !,"PLAN information will affect all patients with this plan, if it is a"
     27 W !,"group plan, and not just the current patient.",!
     28 Q
     29 ;
     30SEL ; -- help for selecting a new HIP
     31 Q:'$G(IBCNSEH)
     32 W !!,"Each Insurance policy entry for a patient must be associated with an"
     33 W !,"Insurance Plan offered by the Insurance company you just selected."
     34 W !,"You will be given a choice of selecting previously entered Group Plans or"
     35 W !,"you may enter a new one.  If you enter a new Insurance Plan you"
     36 W !,"must enter whether or not this is a group or individual plan.",!
     37 Q
     38AB ;
     39 Q:'$G(IBCNSEH)
     40 Q
     41BU ;
     42 Q:'$G(IBCNSEH)
     43 Q

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSM32.m

    r613 r623  
    1 IBCNSM32        ;ALB/AAS - INSURANCE MANAGEMENT - POLICY EDIT ;23-JAN-95
    2         ;;2.0;INTEGRATED BILLING;**28,40,52,85,103,133,361,371**;21-MAR-94;Build 57
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5 PATPOL(IBCDFN)  ; -- edit patient specific policy info
    6         I '$G(IBCDFN) G PATPOLQ
    7         D SAVEPT^IBCNSP3(DFN,IBCDFN)
    8         D POL^IBCNSU41(DFN)
    9         ;
    10         ; -- give warning if expired or inactive co.
    11         I $P(^DPT(DFN,.312,IBCDFN,0),"^",4),$P(^(0),"^",4)'>DT W !,"WARNING:  This appears to be an expired policy!",!
    12         I $P(^DIC(36,+$P(^DPT(DFN,.312,IBCDFN,0),"^"),0),"^",5) W !,*7,"WARNING:  This insurance company is INACTIVE!",!
    13         ;
    14         N IBAD,IBDIF,DA,DR,DIC,DIE,DGSENFLG S DGSENFLG=1
    15         L +^DPT(DFN,.312,+IBCDFN):5 I '$T D LOCKED^IBTRCD1 G PATPOLQ
    16         ;
    17         D EDIT^IBCNSP1(DFN,IBCDFN,.IBQUIT)    ; IB*371 edit 2.312 subfile data
    18         ;
    19         ; If the 2.312 subfile entry was deleted then unlock and get out
    20         I '$D(^DPT(DFN,.312,IBCDFN,0)) L -^DPT(DFN,.312,+IBCDFN) G PATPOLQ
    21         ;
    22         ; -- if the company was changed, change the policy plan
    23         I $G(IBREG),$G(IBCNS),+$G(^DPT(DFN,.312,IBCDFN,0))'=IBCNS D CHPL
    24         ;
    25         K IBFUTUR
    26         D COMPPT^IBCNSP3(DFN,IBCDFN)
    27         I IBDIF D UPDATPT^IBCNSP3(DFN,IBCDFN)
    28         L -^DPT(DFN,.312,+IBCDFN)
    29         ;
    30         D FUTURE^IBCNSM31 K Y,IBFUTUR
    31 PATPOLQ Q
    32         ;
    33 CHPL    ; Change policy plan if the policy company differs from plan company.
    34         ;  Required variable input:
    35         ;        DFN  --  pointer to the patient in file #2
    36         ;     IBCDFN  --  pointer to the policy in file #2.312
    37         ;      IBCNS  --  pointer to the plan company in file #36
    38         ;
    39         N IBBU,IBCNS1,IBCPOL1,IBNEWP1,IBPLAN,IBIP,IBT,X
    40         S X=$G(^DPT(DFN,.312,IBCDFN,0)),IBCNS1=+X
    41         S IBPLAN=$P(X,"^",18),IBIP='$P($G(^IBA(355.3,IBPLAN,0)),"^",2)
    42         W !!,"Since you have changed the Insurance Company to ",$E($P($G(^DIC(36,IBCNS1,0)),"^"),1,25),","
    43         W !,"you must now change the Insurance Plan to which this veteran"
    44         W !,"is subscribing to one which is offered by this company!",!
    45         ;
    46         ; - warn about benefits used
    47         D BU^IBCNSJ21 I $O(IBBU(0)) D
    48         .W !,"The current policy plan has Benefits Used associated with it!"
    49         .W !,"If you add or select another plan to associate with this policy,"
    50         .W !,"these Benefits Used will be deleted!",!
    51         ;
    52         ; - warn about Individual Plans
    53         I IBIP D
    54         .W !,"  ***  Please note:  Since the veteran's current plan is an Individual Plan,"
    55         .W !?21,"this plan will be deleted if you add or select a new"
    56         .W !?21,"plan to associate with this policy.",!
    57         ;
    58         ; - select or add a new plan
    59         S IBCPOL1=$$LK^IBCNSM31(IBCNS1)
    60         I 'IBCPOL1 D NEW^IBCNSJ3(IBCNS1,.IBCPOL1) S:IBCPOL1 IBNEWP1=1
    61         I 'IBCPOL1 D  G CHPLQ
    62         .W !!,"A new plan was not added or selected!"
    63         .W !,"Changing the policy company back to ",$E($P($G(^DIC(36,IBCNS,0)),"^"),1,25),"..."
    64         .S DIE="^DPT(DFN,.312,",DA(1)=DFN,DA=IBCDFN,DR=".01////"_IBCNS_";1.05///NOW;1.06////"_DUZ D ^DIE K DA,DIE,DR
    65         ;
    66         W !!,"Changing the policy plan..."
    67         S DIE="^DPT(DFN,.312,",DA(1)=DFN,DA=IBCDFN,DR=".18////"_IBCPOL1_";1.05///NOW;1.06////"_DUZ D ^DIE K DA,DIE,DR
    68         I IBIP!$G(IBNEWP) W !!,"Deleting the ",$S(IBIP:"current Individual",1:"previously-added")," plan for ",$E($P($G(^DIC(36,IBCNS,0)),"^"),1,25),"..." D DEL^IBCNSJ(IBPLAN)
    69         ;
    70         ; - delete any dangling benefits used
    71         I $O(IBBU(0)) D
    72         .N IBDAT
    73         .W !!,"Deleting current Benefits Used... "
    74         .S IBDAT="" F  S IBDA=$O(IBBU(IBDAT)) Q:IBDAT=""  D DBU^IBCNSJ(IBBU(IBDAT))
    75         ;
    76         ; - repoint all Insurance Reviews to new company
    77         I $$IR^IBCNSJ21(DFN,IBCDFN) D
    78         .W !!,"Repointing all Insurance Reviews to ",$E($P($G(^DIC(36,IBCNS1,0)),"^"),1,25),"... "
    79         .S IBT=0 F  S IBT=$O(^IBT(356.2,"D",DFN,IBT)) Q:'IBT  I $P($G(^IBT(356.2,IBT,1)),"^",5)=IBCDFN,$P($G(^(0)),"^",8)'=IBCNS1 S DA=IBT,DR=".08////"_IBCNS1,DIE="^IBT(356.2," D ^DIE K DA,DR,DIE W "."
    80         ;
    81         S IBCNS=IBCNS1,IBNEWP=$G(IBNEWP1)
    82 CHPLQ   Q
    83         ;
    84 PLAN(DFN,IBCDFN,IBCNS)  ; Fix policies when identified.
    85         ;
    86         ;  This function is invoked from Inactivate Plan or Change Policy Plan,
    87         ;  when it is recognized that the policy and plan companies are out
    88         ;  of synch.  If the user doesn't select a new plan to associate with
    89         ;  the policy, the policy company will be changed to the plan company.
    90         ;
    91         ;  The input parameters are defined above.
    92         ;
    93         N IBNEWP
    94         I '$G(DFN)!'$G(IBCDFN)!'$G(IBCNS) G PLANQ
    95         W !!,*7,"The policy company and plan company are not the same!!"
    96         W !,"This inconsistency probably occurred in the past when changing"
    97         W !,"the policy company through Screen 5 of Registration."
    98         W !!,"You must resolve this inconsistency.  If you do not choose a new plan"
    99         W !,"offered by the policy company, the policy company will be changed to"
    100         W !,"the plan company (",$P($G(^DIC(36,IBCNS,0)),"^"),") ...."
    101         D CHPL
    102 PLANQ   Q
    103 HLP     ; -- help text for subscriber id
    104         W !,?5,"Enter Medicare Claim Number (Subscriber ID) exactly as it"
    105         W !,?5,"appears on the Medicare Insurance Card including All Characters."
    106         W !,?5,"Valid HICN formats are:  1-3 alpha characters followed by 6 or 9 digits, "
    107         W !,?5,"or 9 digits followed by 1 alpha character optionally followed by another "
    108         W !,?5,"alpha character or 1 digit."
    109         Q
     1IBCNSM32 ;ALB/AAS - INSURANCE MANAGEMENT - POLICY EDIT ; 23-JAN-95
     2 ;;2.0;INTEGRATED BILLING;**28,40,52,85,103,133,361**;21-MAR-94;Build 9
     3 ;;Per VHA Directive 2004-038, this routine should not be modified.
     4 ;
     5PATPOL(IBCDFN) ; -- edit patient specific policy info
     6 I '$G(IBCDFN) G PATPOLQ
     7 D SAVEPT^IBCNSP3(DFN,IBCDFN)
     8 D POL^IBCNSU41(DFN)
     9 ;
     10 ; -- give warning if expired or inactive co.
     11 I $P(^DPT(DFN,.312,IBCDFN,0),"^",4),$P(^(0),"^",4)'>DT W !,"WARNING:  This appears to be an expired policy!",!
     12 I $P(^DIC(36,+$P(^DPT(DFN,.312,IBCDFN,0),"^"),0),"^",5) W !,*7,"WARNING:  This insurance company is INACTIVE!",!
     13 ;
     14 N IBAD,IBDIF,DA,DR,DIC,DIE,DGSENFLG S DGSENFLG=1
     15 S DIE="^DPT("_DFN_",.312,",DA(1)=DFN,DA=IBCDFN
     16 S DR="S IBAD="""";8;@333;3;D FUTURE^IBCNSM31;6;S IBAD=X;K X I '$$VET^IBCNSU1() S Y=""@10"";17///^S X=$P(^DPT(DFN,0),U);16///^S X=""01"""
     17 ;S DR="S IBAD="""";8;@333;3;D FUTURE^IBCNSM31;6;S IBAD=X;I IBAD'=""v"" S Y=""@10"";17"_$S($$VET^IBCNSU1():"///^S X="""_$P(^DPT(DFN,0),U,1)_"""",1:"//"_);16///^S X=""01"""
     18 S DR=DR_";S Y=""@20"";@10;17;16//^S X=$S(IBAD=""s"":""02"",1:"""");@20;1;3.01;3.12;1.09//;I $G(IBREG) S Y=""@99"";.2;4.01;4.02;@99"
     19 I $G(IBREG),$D(^XUSEC("IB INSURANCE SUPERVISOR",DUZ)) S DR=".01//;"_DR
     20 L +^DPT(DFN,.312,+IBCDFN):5 I '$T D LOCKED^IBTRCD1 G PATPOLQ
     21 D ^DIE I $D(Y)!($D(DTOUT)) S IBQUIT=1
     22 I '$D(DA) S IBQUIT=1 G PATPOLQ
     23 ;
     24 ; -- if the company was changed, change the policy plan
     25 I $G(IBREG),$G(IBCNS),+$G(^DPT(DFN,.312,IBCDFN,0))'=IBCNS D CHPL
     26 ;
     27 K IBFUTUR
     28 D COMPPT^IBCNSP3(DFN,IBCDFN)
     29 I IBDIF D UPDATPT^IBCNSP3(DFN,IBCDFN)
     30 L -^DPT(DFN,.312,+IBCDFN)
     31 ;
     32 D FUTURE^IBCNSM31 K Y,IBFUTUR
     33PATPOLQ Q
     34 ;
     35CHPL ; Change policy plan if the policy company differs from plan company.
     36 ;  Required variable input:
     37 ;        DFN  --  pointer to the patient in file #2
     38 ;     IBCDFN  --  pointer to the policy in file #2.312
     39 ;      IBCNS  --  pointer to the plan company in file #36
     40 ;
     41 N IBBU,IBCNS1,IBCPOL1,IBNEWP1,IBPLAN,IBIP,IBT,X
     42 S X=$G(^DPT(DFN,.312,IBCDFN,0)),IBCNS1=+X
     43 S IBPLAN=$P(X,"^",18),IBIP='$P($G(^IBA(355.3,IBPLAN,0)),"^",2)
     44 W !!,"Since you have changed the Insurance Company to ",$E($P($G(^DIC(36,IBCNS1,0)),"^"),1,25),","
     45 W !,"you must now change the Insurance Plan to which this veteran"
     46 W !,"is subscribing to one which is offered by this company!",!
     47 ;
     48 ; - warn about benefits used
     49 D BU^IBCNSJ21 I $O(IBBU(0)) D
     50 .W !,"The current policy plan has Benefits Used associated with it!"
     51 .W !,"If you add or select another plan to associate with this policy,"
     52 .W !,"these Benefits Used will be deleted!",!
     53 ;
     54 ; - warn about Individual Plans
     55 I IBIP D
     56 .W !,"  ***  Please note:  Since the veteran's current plan is an Individual Plan,"
     57 .W !?21,"this plan will be deleted if you add or select a new"
     58 .W !?21,"plan to associate with this policy.",!
     59 ;
     60 ; - select or add a new plan
     61 S IBCPOL1=$$LK^IBCNSM31(IBCNS1)
     62 I 'IBCPOL1 D NEW^IBCNSJ3(IBCNS1,.IBCPOL1) S:IBCPOL1 IBNEWP1=1
     63 I 'IBCPOL1 D  G CHPLQ
     64 .W !!,"A new plan was not added or selected!"
     65 .W !,"Changing the policy company back to ",$E($P($G(^DIC(36,IBCNS,0)),"^"),1,25),"..."
     66 .S DIE="^DPT(DFN,.312,",DA(1)=DFN,DA=IBCDFN,DR=".01////"_IBCNS_";1.05///NOW;1.06////"_DUZ D ^DIE K DA,DIE,DR
     67 ;
     68 W !!,"Changing the policy plan..."
     69 S DIE="^DPT(DFN,.312,",DA(1)=DFN,DA=IBCDFN,DR=".18////"_IBCPOL1_";1.05///NOW;1.06////"_DUZ D ^DIE K DA,DIE,DR
     70 I IBIP!$G(IBNEWP) W !!,"Deleting the ",$S(IBIP:"current Individual",1:"previously-added")," plan for ",$E($P($G(^DIC(36,IBCNS,0)),"^"),1,25),"..." D DEL^IBCNSJ(IBPLAN)
     71 ;
     72 ; - delete any dangling benefits used
     73 I $O(IBBU(0)) D
     74 .N IBDAT
     75 .W !!,"Deleting current Benefits Used... "
     76 .S IBDAT="" F  S IBDA=$O(IBBU(IBDAT)) Q:IBDAT=""  D DBU^IBCNSJ(IBBU(IBDAT))
     77 ;
     78 ; - repoint all Insurance Reviews to new company
     79 I $$IR^IBCNSJ21(DFN,IBCDFN) D
     80 .W !!,"Repointing all Insurance Reviews to ",$E($P($G(^DIC(36,IBCNS1,0)),"^"),1,25),"... "
     81 .S IBT=0 F  S IBT=$O(^IBT(356.2,"D",DFN,IBT)) Q:'IBT  I $P($G(^IBT(356.2,IBT,1)),"^",5)=IBCDFN,$P($G(^(0)),"^",8)'=IBCNS1 S DA=IBT,DR=".08////"_IBCNS1,DIE="^IBT(356.2," D ^DIE K DA,DR,DIE W "."
     82 ;
     83 S IBCNS=IBCNS1,IBNEWP=$G(IBNEWP1)
     84CHPLQ Q
     85 ;
     86PLAN(DFN,IBCDFN,IBCNS) ; Fix policies when identified.
     87 ;
     88 ;  This function is invoked from Inactivate Plan or Change Policy Plan,
     89 ;  when it is recognized that the policy and plan companies are out
     90 ;  of synch.  If the user doesn't select a new plan to associate with
     91 ;  the policy, the policy company will be changed to the plan company.
     92 ;
     93 ;  The input parameters are defined above.
     94 ;
     95 N IBNEWP
     96 I '$G(DFN)!'$G(IBCDFN)!'$G(IBCNS) G PLANQ
     97 W !!,*7,"The policy company and plan company are not the same!!"
     98 W !,"This inconsistency probably occurred in the past when changing"
     99 W !,"the policy company through Screen 5 of Registration."
     100 W !!,"You must resolve this inconsistency.  If you do not choose a new plan"
     101 W !,"offered by the policy company, the policy company will be changed to"
     102 W !,"the plan company (",$P($G(^DIC(36,IBCNS,0)),"^"),") ...."
     103 D CHPL
     104PLANQ Q
     105HLP ; -- help text for subscriber id
     106 W !,?5,"Enter Medicare Claim Number (Subscriber ID) exactly as it"
     107 W !,?5,"appears on the Medicare Insurance Card including All Characters."
     108 W !,?5,"Valid HICN formats are:  1-3 alpha characters followed by 6 or 9 digits, "
     109 W !,?5,"or 9 digits followed by 1 alpha character optionally followed by another "
     110 W !,?5,"alpha character or 1 digit."
     111 Q

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSP.m

    r613 r623  
    1 IBCNSP  ;ALB/AAS - INSURANCE MANAGEMENT - EXPANDED POLICY ;05-MAR-1993
    2         ;;2.0;INTEGRATED BILLING;**6,28,43,52,85,251,363,371**;21-MAR-94;Build 57
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4 %       ;
    5 EN      ; -- main entry point for IBCNS EXPANDED POLICY
    6         N IB1ST
    7         K VALMQUIT,IBPPOL
    8         S IBTOP="IBCNSP"
    9         D EN^VALM("IBCNS EXPANDED POLICY")
    10         Q
    11         ;
    12 HDR     ; -- header code
    13         N W,X,Y,Z
    14         S VALMHDR(1)="Expanded Policy Information for: "_$E($P(^DPT(DFN,0),U),1,20)_"  "_$P($$PT^IBEFUNC(DFN),U,2)
    15         S Z=$G(^DPT(DFN,.312,+$P(IBPPOL,U,4),0))
    16         S W=$P($G(^IBA(355.3,+$P(Z,U,18),0)),U,11)
    17         S Y=$E($P($G(^DIC(36,+Z,0)),U),1,20)_" Insurance Company"
    18         S X="** Plan Currently "_$S(W:"Ina",1:"A")_"ctive **"
    19         S VALMHDR(2)=$$SETSTR^VALM1(X,Y,48,29)
    20         Q
    21         ;
    22 INIT    ; -- init variables and list array
    23         K VALMQUIT
    24         S VALMCNT=0,VALMBG=1
    25         I '$D(IBPPOL) D PPOL Q:$D(VALMQUIT)
    26         K ^TMP("IBCNSVP",$J)
    27         D BLD,HDR
    28         Q
    29         ;
    30 BLD     ; -- list builder
    31         K ^TMP("IBCNSVP",$J),^TMP("IBCNSVPDX",$J)
    32         D KILL^VALM10()
    33         F I=1:1:20 D BLANK(.I)    ; start with 20 blank lines
    34         N IBCDFND,IBCDFND1,IBCDFND2,IBCDFND4,IBCDFND5
    35         S IBCDFND=$G(^DPT(DFN,.312,$P(IBPPOL,U,4),0)),IBCDFND1=$G(^(1)),IBCDFND2=$G(^(2)),IBCDFND4=$G(^(4)),IBCDFND5=$G(^(5))
    36         S IBCPOL=+$P(IBCDFND,U,18),IBCNS=+IBCDFND,IBCDFN=$P(IBPPOL,U,4)
    37         S IBCPOLD=$G(^IBA(355.3,+$P(IBCDFND,U,18),0)),IBCPOLD1=$G(^(1))
    38         S IBCPOLD2=$G(^IBA(355.3,+$G(IBCPOL),6)) ;; Daou/EEN adding BIN and PCN
    39         ;
    40         D POLICY^IBCNSP0                   ; plan information
    41         D INS^IBCNSP0                      ; insurance company
    42         D UR                               ; utilization review info
    43         D EFFECT                           ; effective dates & source of info
    44         D SUBSC^IBCNSP01                   ; subscriber info
    45         D EMP                              ; subscriber's employer info
    46         D SPON^IBCNSP0                     ; insured person's info
    47         D ID^IBCNSP01                      ; ins co ID numbers (IB*2*371)
    48         D PLIM                             ; plan coverage limitations
    49         D VER^IBCNSP01                     ; user/verifier/editor info
    50         D CONTACT^IBCNSP0                  ; last insurance contact
    51         D COMMENT                          ; comments - policy & plan
    52         D RIDER^IBCNSP01                   ; policy rider info
    53         ;
    54         S VALMCNT=+$O(^TMP("IBCNSVP",$J,""),-1)
    55         Q
    56         ;
    57 COMMENT ; -- Comment region
    58         N START,OFFSET,IBL,IBI
    59         S (START,IBL)=$O(^TMP("IBCNSVP",$J,""),-1)+1,OFFSET=2
    60         S IB1ST("COMMENT")=START
    61         D SET(START,OFFSET," Comment -- Patient Policy ",IORVON,IORVOFF)
    62         S IBL=IBL+1
    63         D SET(IBL,OFFSET,$S($P(IBCDFND1,U,8)="":"None",1:$P(IBCDFND1,U,8)))
    64         S IBL=IBL+1
    65         D SET(IBL,OFFSET," ")
    66         S IBL=IBL+1
    67         D SET(IBL,OFFSET," Comment -- Group Plan ",IORVON,IORVOFF)
    68         S IBI=0 F  S IBI=$O(^IBA(355.3,+IBCPOL,11,IBI)) Q:IBI<1  D
    69         . S IBL=IBL+1
    70         . D SET(IBL,OFFSET,"  "_$E($G(^IBA(355.3,+IBCPOL,11,IBI,0)),1,80))
    71         . Q
    72         S IBL=IBL+1 D SET(IBL,OFFSET," ")
    73         S IBL=IBL+1 D SET(IBL,OFFSET," ")
    74         Q
    75         ;
    76 EFFECT  ; -- Effective date region
    77         N START,OFFSET
    78         S START=16,OFFSET=45
    79         D SET(START,OFFSET-4," Effective Dates & Source ",IORVON,IORVOFF)
    80         D SET(START+1,OFFSET," Effective Date: "_$$DAT1^IBOUTL($P(IBCDFND,U,8)))
    81         D SET(START+2,OFFSET,"Expiration Date: "_$$DAT1^IBOUTL($P(IBCDFND,U,4)))
    82         D SET(START+3,OFFSET," Source of Info: "_$$EXPAND^IBTRE(2.312,1.09,$P($G(IBCDFND1),U,9)))
    83         D SET(START+4,OFFSET-4,"Policy Not Billable: "_$S($P($G(^DPT(DFN,.312,IBCDFN,3)),"^",4):"YES",1:"NO"))
    84         Q
    85         ;
    86 UR      ; -- UR of insurance region
    87         N START,OFFSET
    88         S START=16,OFFSET=2
    89         D SET(START,OFFSET," Utilization Review Info ",IORVON,IORVOFF)
    90         D SET(START+1,OFFSET,"         Require UR: "_$$EXPAND^IBTRE(355.3,.05,$P(IBCPOLD,U,5)))
    91         D SET(START+2,OFFSET,"   Require Amb Cert: "_$$EXPAND^IBTRE(355.3,.12,$P(IBCPOLD,U,12)))
    92         D SET(START+3,OFFSET,"   Require Pre-Cert: "_$$EXPAND^IBTRE(355.3,.06,$P(IBCPOLD,U,6)))
    93         D SET(START+4,OFFSET,"   Exclude Pre-Cond: "_$$EXPAND^IBTRE(355.3,.07,$P(IBCPOLD,U,7)))
    94         D SET(START+5,OFFSET,"Benefits Assignable: "_$$EXPAND^IBTRE(355.3,.08,$P(IBCPOLD,U,8)))
    95         Q
    96 EMP     ; -- Insurance Employer Region
    97         N OFFSET,START,IBADD
    98         S START=24,OFFSET=40
    99         D SET(START,OFFSET," Subscriber's Employer Information ",IORVON,IORVOFF)
    100         D SET(START+1,OFFSET,"Emp Sponsored Plan: "_$S(+$P(IBCDFND2,U,10):"Yes",1:"No"))
    101         D SET(START+2,OFFSET,"          Employer: "_$P(IBCDFND2,U,9))
    102         D SET(START+3,OFFSET," Employment Status: "_$$EXPAND^IBTRE(2.312,2.11,$P(IBCDFND2,U,11)))
    103         D SET(START+4,OFFSET,"   Retirement Date: "_$$DAT1^IBOUTL($P(IBCDFND2,U,12)))
    104         D SET(START+5,OFFSET,"Claims to Employer: "_$S(+IBCDFND2:"Yes, Send to Employer",1:"No, Send to Insurance Company"))
    105         ;
    106         D SET(START+6,OFFSET,"            Street: "_$P(IBCDFND2,U,2)) S IBADD=1
    107         I $P(IBCDFND2,U,3)'="" D SET(START+7,OFFSET,"          Street 2: "_$P(IBCDFND2,U,3)) S IBADD=2
    108         I $P(IBCDFND2,U,4)'="" D SET(START+8,OFFSET,"          Street 3: "_$P(IBCDFND2,U,4)) S IBADD=3
    109         D SET(START+6+IBADD,OFFSET,"        City/State: "_$E($P(IBCDFND2,U,5),1,15)_$S($P(IBCDFND2,U,5)="":"",1:", ")_$P($G(^DIC(5,+$P(IBCDFND2,U,6),0)),U,2)_" "_$E($P(IBCDFND2,U,7),1,5))
    110         D SET(START+7+IBADD,OFFSET,"             Phone: "_$P(IBCDFND2,U,8))
    111         ;
    112         ; couple of blank lines to end this section
    113         D SET(START+8+IBADD,2," ")
    114         D SET(START+9+IBADD,2," ")
    115         ;
    116 EMPQ    Q
    117         ;
    118 PLIM    ; plan coverage limitations/plan limitation category display
    119         N START,END S START=$O(^TMP("IBCNSVP",$J,""),-1)+1
    120         S IB1ST("PLIM")=START
    121         D LIMBLD^IBCNSC41(START,2)
    122         S END=$O(^TMP("IBCNSVP",$J,""),-1)  ; last line constructed
    123         D SET(END+1,2," ")    ; 2 blank lines to end this section
    124         D SET(END+2,2," ")
    125 PLIMX   ;
    126         Q
    127         ;
    128 HELP    ; -- help code
    129         S X="?" D DISP^XQORM1 W !!
    130         Q
    131         ;
    132 EXIT    ; -- exit code
    133         K IBPPOL,VALMQUIT,IBCNS,IBCPOL,IBCPOLD,IBCPOLD1,IBCPOLD2,IBCDFND,IBCDFND1,IBCDFND2
    134         D CLEAN^VALM10,CLEAR^VALM1
    135         Q
    136         ;
    137 EXPND   ; -- expand code
    138         Q
    139         ;
    140 PPOL    ; -- select patient, select policy
    141         I '$D(DFN) D  G:$D(VALMQUIT) PPOLQ
    142         .S DIC="^DPT(",DIC(0)="AEQMN" D ^DIC
    143         .S DFN=+Y
    144         I $G(DFN)<1 S VALMQUIT="" G PPOLQ
    145         ;
    146         I '$O(^DPT(DFN,.312,0)) W !!,"Patient doesn't have Insurance" K DFN G PPOL
    147         ;
    148         S DIC="^DPT("_DFN_",.312,",DIC(0)="AEQMN",DIC("A")="Select Patient Policy: "
    149         D ^DIC I +Y<1 S VALMQUIT=""
    150         G:$D(VALMQUIT) PPOLQ
    151         S IBPPOL="^2^"_DFN_U_+Y_U_$G(^DPT(DFN,.312,+Y,0))
    152 PPOLQ   K DIC Q
    153         ;
    154 BLANK(LINE)     ; -- Build blank line
    155         D SET^VALM10(.LINE,$J("",80))
    156         Q
    157         ;
    158 SET(LINE,COL,TEXT,ON,OFF)       ; -- set display info in array
    159         I '$D(@VALMAR@(LINE,0)) D BLANK(.LINE) S VALMCNT=$G(VALMCNT)+1
    160         D SET^VALM10(.LINE,$$SETSTR^VALM1(.TEXT,@VALMAR@(LINE,0),.COL,$L(TEXT)))
    161         D:$G(ON)]""!($G(OFF)]"") CNTRL^VALM10(.LINE,.COL,$L(TEXT),$G(ON),$G(OFF))
    162         W:'(LINE#5) "."
    163         Q
     1IBCNSP ;ALB/AAS - INSURANCE MANAGEMENT - EXPANDED POLICY ;05-MAR-1993
     2 ;;2.0;INTEGRATED BILLING;**6,28,43,52,85,251,363**;21-MAR-94;Build 35
     3 ;;Per VHA Directive 2004-038, this routine should not be modified.
     4% ;
     5EN ; -- main entry point for IBCNS EXPANDED POLICY
     6 K VALMQUIT,IBPPOL
     7 S IBTOP="IBCNSP"
     8 D EN^VALM("IBCNS EXPANDED POLICY")
     9 Q
     10 ;
     11HDR ; -- header code
     12 N W,X,Y,Z
     13 S VALMHDR(1)="Expanded Policy Information for: "_$E($P(^DPT(DFN,0),U),1,20)_"  "_$P($$PT^IBEFUNC(DFN),U,2)
     14 S Z=$G(^DPT(DFN,.312,+$P(IBPPOL,U,4),0))
     15 S W=$P($G(^IBA(355.3,+$P(Z,U,18),0)),U,11)
     16 S Y=$E($P($G(^DIC(36,+Z,0)),U),1,20)_" Insurance Company"
     17 S X="** Plan Currently "_$S(W:"Ina",1:"A")_"ctive **"
     18 S VALMHDR(2)=$$SETSTR^VALM1(X,Y,48,29)
     19 Q
     20 ;
     21INIT ; -- init variables and list array
     22 K VALMQUIT
     23 S VALMCNT=0,VALMBG=1
     24 I '$D(IBPPOL) D PPOL Q:$D(VALMQUIT)
     25 K ^TMP("IBCNSVP",$J)
     26 D BLD,HDR
     27 Q
     28 ;
     29BLD ; -- list builder
     30 K ^TMP("IBCNSVP",$J),^TMP("IBCNSVPDX",$J)
     31 D KILL^VALM10()
     32 F I=1:1:50 D BLANK(.I)
     33 S VALMCNT=50
     34 N IBCDFND,IBCDFND1,IBCDFND2,IBCDFND4
     35 S IBCDFND=$G(^DPT(DFN,.312,$P(IBPPOL,U,4),0)),IBCDFND1=$G(^(1)),IBCDFND2=$G(^(2)),IBCDFND4=$G(^(4))
     36 S IBCPOL=+$P(IBCDFND,U,18),IBCNS=+IBCDFND,IBCDFN=$P(IBPPOL,U,4)
     37 S IBCPOLD=$G(^IBA(355.3,+$P(IBCDFND,U,18),0)),IBCPOLD1=$G(^(1))
     38 S IBCPOLD2=$G(^IBA(355.3,+$G(IBCPOL),6)) ;; Daou/EEN adding BIN and PCN
     39 S IBLCNT=0
     40 D POLICY^IBCNSP0,INS^IBCNSP0,SPON^IBCNSP0,LIMBLD^IBCNSC41(36,2,.IBLCNT)
     41 D CONTACT^IBCNSP0,EFFECT,UR,EMP,VER^IBCNSP01,COMMENT,^IBCNSP01
     42 Q
     43 ;
     44COMMENT ; -- Comment region
     45 N START,OFFSET,IBL,IBI
     46 S START=49+$G(IBLCNT),OFFSET=2,IBL=0
     47 I '$D(@VALMAR@(START-1)) D SET(START-1,OFFSET,"  ")
     48 D SET(START,OFFSET," Comment -- Patient Policy ",IORVON,IORVOFF)
     49 D SET(START+1,OFFSET,$S($P(IBCDFND1,U,8)="":"None",1:$P(IBCDFND1,U,8)))
     50 I '$D(@VALMAR@(START+2)) D SET(START+2,OFFSET,"  ")
     51 D SET(START+3,OFFSET," Comment -- Group Plan ",IORVON,IORVOFF)
     52 S IBI=0 F  S IBI=$O(^IBA(355.3,+IBCPOL,11,IBI)) Q:IBI<1  D
     53 .S IBL=IBL+1
     54 .D SET(START+IBL+3,OFFSET,"  "_$E($G(^IBA(355.3,+IBCPOL,11,IBI,0)),1,80))
     55 S IBLCNT=$G(IBLCNT)+IBL+1 D SET(START+IBL+4,OFFSET,"  ")
     56 Q
     57 ;
     58EFFECT ; -- Effective date region
     59 N START,OFFSET
     60 S START=14,OFFSET=45
     61 D SET(START,OFFSET-4," Effective Dates & Source ",IORVON,IORVOFF)
     62 D SET(START+1,OFFSET," Effective Date: "_$$DAT1^IBOUTL($P(IBCDFND,U,8)))
     63 D SET(START+2,OFFSET,"Expiration Date: "_$$DAT1^IBOUTL($P(IBCDFND,U,4)))
     64 D SET(START+3,OFFSET," Source of Info: "_$$EXPAND^IBTRE(2.312,1.09,$P($G(IBCDFND1),U,9)))
     65 D SET(START+4,OFFSET-4,"Policy Not Billable: "_$S($P($G(^DPT(DFN,.312,IBCDFN,3)),"^",4):"YES",1:"NO"))
     66 Q
     67 ;
     68UR ; -- UR of insurance region
     69 N START,OFFSET
     70 S START=14,OFFSET=2
     71 D SET(START,OFFSET," Utilization Review Info ",IORVON,IORVOFF)
     72 D SET(START+1,OFFSET,"         Require UR: "_$$EXPAND^IBTRE(355.3,.05,$P(IBCPOLD,U,5)))
     73 D SET(START+2,OFFSET,"   Require Amb Cert: "_$$EXPAND^IBTRE(355.3,.12,$P(IBCPOLD,U,12)))
     74 D SET(START+3,OFFSET,"   Require Pre-Cert: "_$$EXPAND^IBTRE(355.3,.06,$P(IBCPOLD,U,6)))
     75 D SET(START+4,OFFSET,"   Exclude Pre-Cond: "_$$EXPAND^IBTRE(355.3,.07,$P(IBCPOLD,U,7)))
     76 D SET(START+5,OFFSET,"Benefits Assignable: "_$$EXPAND^IBTRE(355.3,.08,$P(IBCPOLD,U,8)))
     77 Q
     78EMP ; -- Insurance Employer Region
     79 N OFFSET,START,IBADD
     80 S START=19,OFFSET=40
     81 D SET(START,OFFSET," Subscriber's Employer Information ",IORVON,IORVOFF)
     82 D SET(START+1,OFFSET,"Emp Sponsored Plan: "_$S(+$P(IBCDFND2,U,10):"Yes",1:"No"))
     83 D SET(START+2,OFFSET,"          Employer: "_$P(IBCDFND2,U,9))
     84 D SET(START+3,OFFSET," Employment Status: "_$$EXPAND^IBTRE(2.312,2.11,$P(IBCDFND2,U,11)))
     85 D SET(START+4,OFFSET,"   Retirement Date: "_$$DAT1^IBOUTL($P(IBCDFND2,U,12)))
     86 D SET(START+5,OFFSET,"Claims to Employer: "_$S(+IBCDFND2:"Yes, Send to Employer",1:"No, Send to Insurance Company"))
     87 ;I +IBCDFND2 W !!,"If ROI applies, make sure current consent is signed.",!! D PAUSE^VALM1
     88 ;
     89 D SET(START+6,OFFSET,"            Street: "_$P(IBCDFND2,U,2)) S IBADD=1
     90 I $P(IBCDFND2,U,3)'="" D SET(START+7,OFFSET,"          Street 2: "_$P(IBCDFND2,U,3)) S IBADD=2
     91 I $P(IBCDFND2,U,4)'="" D SET(START+8,OFFSET,"          Street 3: "_$P(IBCDFND2,U,4)) S IBADD=3
     92 D SET(START+6+IBADD,OFFSET,"        City/State: "_$E($P(IBCDFND2,U,5),1,15)_$S($P(IBCDFND2,U,5)="":"",1:", ")_$P($G(^DIC(5,+$P(IBCDFND2,U,6),0)),U,2)_" "_$E($P(IBCDFND2,U,7),1,5))
     93 D SET(START+7+IBADD,OFFSET,"             Phone: "_$P(IBCDFND2,U,8))
     94 ;
     95EMPQ Q
     96 ;
     97HELP ; -- help code
     98 S X="?" D DISP^XQORM1 W !!
     99 Q
     100 ;
     101EXIT ; -- exit code
     102 K IBPPOL,VALMQUIT,IBCNS,IBCPOL,IBCPOLD,IBCPOLD1,IBCPOLD2,IBCDFND,IBCDFND1,IBCDFND2
     103 D CLEAN^VALM10,CLEAR^VALM1
     104 Q
     105 ;
     106EXPND ; -- expand code
     107 Q
     108 ;
     109PPOL ; -- select patient, select policy
     110 I '$D(DFN) D  G:$D(VALMQUIT) PPOLQ
     111 .S DIC="^DPT(",DIC(0)="AEQMN" D ^DIC
     112 .S DFN=+Y
     113 I $G(DFN)<1 S VALMQUIT="" G PPOLQ
     114 ;
     115 I '$O(^DPT(DFN,.312,0)) W !!,"Patient doesn't have Insurance" K DFN G PPOL
     116 ;
     117 S DIC="^DPT("_DFN_",.312,",DIC(0)="AEQMN",DIC("A")="Select Patient Policy: "
     118 D ^DIC I +Y<1 S VALMQUIT=""
     119 G:$D(VALMQUIT) PPOLQ
     120 S IBPPOL="^2^"_DFN_U_+Y_U_$G(^DPT(DFN,.312,+Y,0))
     121PPOLQ K DIC Q
     122 ;
     123BLANK(LINE) ; -- Build blank line
     124 D SET^VALM10(.LINE,$J("",80))
     125 Q
     126 ;
     127SET(LINE,COL,TEXT,ON,OFF) ; -- set display info in array
     128 I '$D(@VALMAR@(LINE,0)) D BLANK(.LINE) S VALMCNT=$G(VALMCNT)+1
     129 D SET^VALM10(.LINE,$$SETSTR^VALM1(.TEXT,@VALMAR@(LINE,0),.COL,$L(TEXT)))
     130 D:$G(ON)]""!($G(OFF)]"") CNTRL^VALM10(.LINE,.COL,$L(TEXT),$G(ON),$G(OFF))
     131 W:'(LINE#5) "."
     132 Q

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSP0.m

    r613 r623  
    1 IBCNSP0 ;ALB/AAS - INSURANCE MANAGEMENT - EXPANDED POLICY ;05-MAR-1993
    2         ;;2.0;INTEGRATED BILLING;**28,43,52,85,93,103,137,229,251,363,371**;21-MAR-94;Build 57
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5         ;
    6 CONTACT ; -- Insurance Contact Information
    7         N OFFSET,START
    8         ;
    9         ; The start of this section is designed to start on the same line
    10         ; as the User Information section (see VER^IBCNSP01).
    11         ;
    12         S START=$O(^TMP("IBCNSVP",$J,""),-1)-8
    13         S IB1ST("CONTACT")=START
    14         S OFFSET=42
    15         N IBTRC,IBTRCD,IBTCOD
    16         S IBTCOD=$O(^IBE(356.11,"ACODE",85,0))
    17         ;
    18         S IBTRC=0,IBTRCD=""
    19         F  S IBTRC=$O(^IBT(356.2,"D",DFN,IBTRC)) Q:'IBTRC  D
    20         .Q:$P($G(^IBT(356.2,+IBTRC,1)),"^",5)'=IBCDFN  ; must be same policy
    21         .Q:$P($G(^IBT(356.2,+IBTRC,0)),"^",4)'=IBTCOD  ; must be ins. ver. type
    22         .S IBTRCD=$G(^IBT(356.2,+IBTRC,0))
    23         ;
    24         D SET(START,OFFSET," Insurance Contact (last) ",IORVON,IORVOFF)
    25         D SET(START+1,OFFSET," Person Contacted: "_$$EXPAND^IBTRE(356.2,.06,$P(IBTRCD,"^",6)))
    26         D SET(START+2,OFFSET,"Method of Contact: "_$$EXPAND^IBTRE(356.2,.17,$P(IBTRCD,"^",17)))
    27         D SET(START+3,OFFSET,"  Contact's Phone: "_$$EXPAND^IBTRE(356.2,.07,$P(IBTRCD,"^",7)))
    28         D SET(START+4,OFFSET,"    Call Ref. No.: "_$$EXPAND^IBTRE(356.2,.09,$P(IBTRCD,"^",9)))
    29         D SET(START+5,OFFSET,"     Contact Date: "_$$EXPAND^IBTRE(356.2,.01,$P(IBTRCD,"^")))
    30         ; no blank lines here because the User Information section is on the
    31         ; left and it is bigger than this section
    32         Q
    33         ;
    34 POLICY  ; -- Policy Region
    35         ; -- if pointer to policy file exists get data from policy file
    36         N OFFSET,START,IBP,IBX,IBPLNID,IBPLNNM,IBPLNNA,IBPLNLA
    37         S (IBPLNID,IBPLNNM,IBPLNNA,IBPLNLA)=""
    38         S START=1,OFFSET=2
    39         D GPLAN(+IBCPOLD2)
    40         D SET(START,OFFSET," Plan Information ",IORVON,IORVOFF)
    41         D SET(START+1,OFFSET,"   Is Group Plan: "_$S($P(IBCPOLD,"^",2)=1:"YES",1:"NO"))
    42         D SET(START+2,OFFSET,"      Group Name: "_$P(IBCPOLD,"^",3))
    43         D SET(START+3,OFFSET,"    Group Number: "_$P(IBCPOLD,"^",4))
    44         D SET(START+4,OFFSET,"             BIN: "_$P(IBCPOLD2,"^",2)) ;;Daou/EEN
    45         D SET(START+5,OFFSET,"             PCN: "_$P(IBCPOLD2,"^",3)) ;;04/09/04
    46         D SET(START+6,OFFSET,"    Type of Plan: "_$E($P($G(^IBE(355.1,+$P(IBCPOLD,"^",9),0)),"^"),1,23))
    47         S IBX=7
    48         I $P(IBCPOLD,U,14)]"" D
    49         . D SET(START+IBX,OFFSET,"   Plan Category: "_$$EXPAND^IBTRE(355.3,.14,$P(IBCPOLD,"^",14))) S IBX=IBX+1
    50         I $P(IBCPOLD,U,15)]"" D
    51         . D SET(START+IBX,OFFSET," Electronic Type: "_$$EXPAND^IBTRE(355.3,.15,$P(IBCPOLD,"^",15))) S IBX=IBX+1
    52         D SET(START+IBX,OFFSET,"  Plan Filing TF: "_$P(IBCPOLD,"^",13)) S IBX=IBX+1
    53         ;
    54         D SET(START+IBX,OFFSET,"      ePharmacy Plan ID: "_IBPLNID) S IBX=IBX+1
    55         D SET(START+IBX,OFFSET,"    ePharmacy Plan Name: "_IBPLNNM) S IBX=IBX+1
    56         D SET(START+IBX,OFFSET,"  ePharmacy Natl Status: "_IBPLNNA) S IBX=IBX+1
    57         D SET(START+IBX,OFFSET," ePharmacy Local Status: "_IBPLNLA) S IBX=IBX+1
    58         ;
    59         ; -- in case pointer is missing
    60         I '$G(^IBA(355.3,+$P(IBCDFND,"^",18),0)) D
    61         .D SET(START+1,OFFSET,"Insurance Number: "_$P(IBCDFND,"^",2))
    62         .D SET(START+2,OFFSET,"      Group Name: "_$P(IBCDFND,"^",15))
    63         .D SET(START+3,OFFSET,"    Group Number: "_$P(IBCDFND,"^",3))
    64         .Q
    65         Q
    66         ;
    67 INS     ; -- Insurance Co. Region
    68         N OFFSET,START,IBADD,IBCDFNDA,IBCDFNDB
    69         S START=1,OFFSET=45
    70         D SET(START,OFFSET," Insurance Company ",IORVON,IORVOFF)
    71         D SET(START+1,OFFSET,"   Company: "_$P($G(^DIC(36,+IBCDFND,0)),"^"))
    72         S IBCDFNDA=$G(^DIC(36,+IBCDFND,.11)),IBCDFNDB=$G(^(.13))
    73         G:IBCDFNDA="" INSQ
    74         D SET(START+2,OFFSET,"    Street: "_$P(IBCDFNDA,"^")) S IBADD=1
    75         I $P(IBCDFNDA,"^",2)'="" D SET(START+3,OFFSET,"  Street 2: "_$P(IBCDFNDA,"^",2)) S IBADD=2
    76         I $P(IBCDFNDA,"^",3)'="" D SET(START+4,OFFSET,"  Street 3: "_$P(IBCDFNDA,"^",3)) S IBADD=3
    77         D SET(START+2+IBADD,OFFSET,"City/State: "_$E($P(IBCDFNDA,"^",4),1,15)_$S($P(IBCDFNDA,"^",4)="":"",1:", ")_$P($G(^DIC(5,+$P(IBCDFNDA,"^",5),0)),"^",2)_" "_$E($P(IBCDFNDA,"^",6),1,5))
    78         D SET(START+3+IBADD,OFFSET,"Billing Ph: "_$P(IBCDFNDB,"^",2))
    79         D SET(START+4+IBADD,OFFSET,"Precert Ph: "_$$PHONE^IBCNSC01(IBCDFNDB))
    80         ;
    81 INSQ    Q
    82         ;
    83 SPON    ; -- Sponsor (Insured Person) Region
    84         N IBC3,IBZIP,START,OFFSET,IBA,DA,DR,DIC,DIQ
    85         S IBC3=$G(^DPT(DFN,.312,IBCDFN,3))
    86         S DA=+$P(IBC3,"^",2),DR=.01,DIQ(0)="E",DIC="^DIC(23,",DIQ="IBA" D EN^DIQ1
    87         S START=$O(^TMP("IBCNSVP",$J,""),-1)+1,OFFSET=4
    88         D SET(START,OFFSET," Insured Person's Information (use Subscriber Update Action) ",IORVON,IORVOFF)
    89         D SET(START+1,OFFSET,"    Insured's DOB: "_$$DAT3^IBOUTL($P(IBC3,"^")))
    90         D SET(START+2,OFFSET,"    Insured's Sex: "_$$EXTERNAL^DILFD(2.312,3.12,,$P(IBC3,U,12)))
    91         D SET(START+3,OFFSET," Insured's Branch: "_$G(IBA(23,DA,.01,"E")))
    92         D SET(START+4,OFFSET,"   Insured's Rank: "_$P(IBC3,"^",3))
    93         ;
    94         S OFFSET=43
    95         S Y=$P(IBC3,"^",10) D ZIPOUT^VAFADDR S IBZIP=Y
    96         D SET(START+1,OFFSET," Str 1: "_$P(IBC3,"^",6))
    97         D SET(START+2,OFFSET," Str 2: "_$P(IBC3,"^",7))
    98         D SET(START+3,OFFSET,"  City: "_$P(IBC3,"^",8))
    99         D SET(START+4,OFFSET,"St/Zip: "_$P($G(^DIC(5,+$P(IBC3,"^",9),0)),"^",2)_"  "_IBZIP)
    100         D SET(START+5,OFFSET," Phone: "_$P(IBC3,"^",11))
    101         ;
    102         ; blank lines at end of section
    103         D SET(START+6,2," ")
    104         D SET(START+7,2," ")
    105         Q
    106         ;
    107 BLANK(LINE)     ; -- Build blank line
    108         D SET^VALM10(.LINE,$J("",80))
    109         Q
    110         ;
    111 SET(LINE,COL,TEXT,ON,OFF)       ; -- set display info in array
    112         D:'$D(@VALMAR@(LINE,0)) BLANK(.LINE)
    113         D SET^VALM10(.LINE,$$SETSTR^VALM1(.TEXT,@VALMAR@(LINE,0),.COL,$L(TEXT)))
    114         D:$G(ON)]""!($G(OFF)]"") CNTRL^VALM10(.LINE,.COL,$L(TEXT),$G(ON),$G(OFF))
    115         W:'(LINE#5) "."
    116         Q
    117         ;
    118 GPLAN(IBPLDA)   ; get data from PLAN file (#366.03) related to the
    119         ; GROUP INSURANCE PLAN file (#355.3) and the INSURANCE COMPANY file (#36)
    120         ; that is associated with the PATIENT
    121         ; input - IBPLDA - ien of the PLAN file (#366.03)
    122         N IBPLN0,IBAIEN,IBAPIEN,IBAP0
    123         S IBPLN0=$G(^IBCNR(366.03,IBPLDA,0)) ;; Q:'$P(IBPLN0,"^",3) ;quit if payer not defined
    124         S IBPLNID=$P(IBPLN0,"^"),IBPLNNM=$P(IBPLN0,"^",2)
    125         S IBAIEN=$O(^IBCNR(366.13,"B","E-PHARM","")) Q:'IBAIEN
    126         S IBAPIEN=$O(^IBCNR(366.03,IBPLDA,3,"B",IBAIEN,"")) Q:'IBAPIEN
    127         S IBAP0=$G(^IBCNR(366.03,IBPLDA,3,IBAPIEN,0))
    128         S IBPLNNA=$S($P(IBAP0,"^",2)=0:"NOT ACTIVE",1:"ACTIVE")
    129         S IBPLNLA=$S($P(IBAP0,"^",3)=0:"NOT ACTIVE",1:"ACTIVE")
    130         Q
    131         ;
    132         ;IBCNSP0
     1IBCNSP0 ;ALB/AAS - INSURANCE MANAGEMENT - EXPANDED POLICY  ;05-MAR-1993
     2 ;;2.0;INTEGRATED BILLING;**28,43,52,85,93,103,137,229,251,363**;21-MAR-94;Build 35
     3 ;;Per VHA Directive 2004-038, this routine should not be modified.
     4 ;
     5 ;
     6CONTACT ; -- Insurance Contact Information
     7 N OFFSET,START
     8 S START=41+$G(IBLCNT),OFFSET=42
     9 N IBTRC,IBTRCD,IBTCOD
     10 S IBTCOD=$O(^IBE(356.11,"ACODE",85,0))
     11 ;
     12 S IBTRC=0,IBTRCD=""
     13 F  S IBTRC=$O(^IBT(356.2,"D",DFN,IBTRC)) Q:'IBTRC  D
     14 .Q:$P($G(^IBT(356.2,+IBTRC,1)),"^",5)'=IBCDFN  ; must be same policy
     15 .Q:$P($G(^IBT(356.2,+IBTRC,0)),"^",4)'=IBTCOD  ; must be ins. ver. type
     16 .S IBTRCD=$G(^IBT(356.2,+IBTRC,0))
     17 ;
     18 I '$D(@VALMAR@(START-1)) D SET(START-1,OFFSET,"  ")
     19 D SET(START,OFFSET," Insurance Contact (last) ",IORVON,IORVOFF)
     20 D SET(START+1,OFFSET," Person Contacted: "_$$EXPAND^IBTRE(356.2,.06,$P(IBTRCD,"^",6)))
     21 D SET(START+2,OFFSET,"Method of Contact: "_$$EXPAND^IBTRE(356.2,.17,$P(IBTRCD,"^",17)))
     22 D SET(START+3,OFFSET,"  Contact's Phone: "_$$EXPAND^IBTRE(356.2,.07,$P(IBTRCD,"^",7)))
     23 D SET(START+4,OFFSET,"    Call Ref. No.: "_$$EXPAND^IBTRE(356.2,.09,$P(IBTRCD,"^",9)))
     24 D SET(START+5,OFFSET,"     Contact Date: "_$$EXPAND^IBTRE(356.2,.01,$P(IBTRCD,"^")))
     25 Q
     26 ;
     27POLICY ; -- Policy Region
     28 ; -- if pointer to policy file exists get data from policy file
     29 N OFFSET,START,IBP,IBX,IBPLNID,IBPLNNM,IBPLNNA,IBPLNLA
     30 S (IBPLNID,IBPLNNM,IBPLNNA,IBPLNLA)=""
     31 S START=1,OFFSET=2
     32 D GPLAN(+IBCPOLD2)
     33 D SET(START,OFFSET," Plan Information ",IORVON,IORVOFF)
     34 D SET(START+1,OFFSET,"   Is Group Plan: "_$S($P(IBCPOLD,"^",2)=1:"YES",1:"NO"))
     35 D SET(START+2,OFFSET,"      Group Name: "_$P(IBCPOLD,"^",3))
     36 D SET(START+3,OFFSET,"    Group Number: "_$P(IBCPOLD,"^",4))
     37 D SET(START+4,OFFSET,"             BIN: "_$P(IBCPOLD2,"^",2)) ;;Daou/EEN
     38 D SET(START+5,OFFSET,"             PCN: "_$P(IBCPOLD2,"^",3)) ;;04/09/04
     39 D SET(START+6,OFFSET,"    Type of Plan: "_$E($P($G(^IBE(355.1,+$P(IBCPOLD,"^",9),0)),"^"),1,23))
     40 S IBX=7
     41 I $P(IBCPOLD,U,14)]"" D
     42 . D SET(START+IBX,OFFSET,"   Plan Category: "_$$EXPAND^IBTRE(355.3,.14,$P(IBCPOLD,"^",14))) S IBX=IBX+1
     43 I $P(IBCPOLD,U,15)]"" D
     44 . D SET(START+IBX,OFFSET," Electronic Type: "_$$EXPAND^IBTRE(355.3,.15,$P(IBCPOLD,"^",15))) S IBX=IBX+1
     45 D SET(START+IBX,OFFSET,"  Plan Filing TF: "_$P(IBCPOLD,"^",13)) S IBX=IBX+1
     46 ; -- in case pointer is missing
     47 D SET(START+IBX,OFFSET,"      ePharmacy Plan ID: "_IBPLNID) S IBX=IBX+1
     48 D SET(START+IBX,OFFSET,"    ePharmacy Plan Name: "_IBPLNNM) S IBX=IBX+1
     49 D SET(START+IBX,OFFSET,"  ePharmacy Natl Status: "_IBPLNNA) S IBX=IBX+1
     50 D SET(START+IBX,OFFSET," ePharmacy Local Status: "_IBPLNLA) S IBX=IBX+1
     51 I '$G(^IBA(355.3,+$P(IBCDFND,"^",18),0)) D
     52 .D SET(START+1,OFFSET,"Insurance Number: "_$P(IBCDFND,"^",2))
     53 .D SET(START+2,OFFSET,"      Group Name: "_$P(IBCDFND,"^",15))
     54 .D SET(START+3,OFFSET,"    Group Number: "_$P(IBCDFND,"^",3))
     55 .Q
     56 Q
     57 ;
     58INS ; -- Insurance Co. Region
     59 N OFFSET,START,IBADD,IBCDFNDA,IBCDFNDB
     60 S START=1,OFFSET=45
     61 D SET(START,OFFSET," Insurance Company ",IORVON,IORVOFF)
     62 D SET(START+1,OFFSET,"   Company: "_$P($G(^DIC(36,+IBCDFND,0)),"^"))
     63 S IBCDFNDA=$G(^DIC(36,+IBCDFND,.11)),IBCDFNDB=$G(^(.13))
     64 G:IBCDFNDA="" INSQ
     65 D SET(START+2,OFFSET,"    Street: "_$P(IBCDFNDA,"^")) S IBADD=1
     66 I $P(IBCDFNDA,"^",2)'="" D SET(START+3,OFFSET,"  Street 2: "_$P(IBCDFNDA,"^",2)) S IBADD=2
     67 I $P(IBCDFNDA,"^",3)'="" D SET(START+4,OFFSET,"  Street 3: "_$P(IBCDFNDA,"^",3)) S IBADD=3
     68 D SET(START+2+IBADD,OFFSET,"City/State: "_$E($P(IBCDFNDA,"^",4),1,15)_$S($P(IBCDFNDA,"^",4)="":"",1:", ")_$P($G(^DIC(5,+$P(IBCDFNDA,"^",5),0)),"^",2)_" "_$E($P(IBCDFNDA,"^",6),1,5))
     69 D SET(START+3+IBADD,OFFSET,"Billing Ph: "_$P(IBCDFNDB,"^",2))
     70 D SET(START+4+IBADD,OFFSET,"Precert Ph: "_$$PHONE^IBCNSC01(IBCDFNDB))
     71 ;
     72INSQ Q
     73 ;
     74SPON ; -- Sponsor (Insured Person) Region
     75 N IBC3,IBSSN,IBZIP,START,OFFSET,IBA,DA,DR,DIC,DIQ
     76 S IBC3=$G(^DPT(DFN,.312,IBCDFN,3)),IBSSN=$P(IBC3,"^",5)
     77 S DA=+$P(IBC3,"^",2),DR=.01,DIQ(0)="E",DIC="^DIC(23,",DIQ="IBA" D EN^DIQ1
     78 S START=30,OFFSET=4
     79 D SET(START,OFFSET," Insured Person's Information (use Subscriber Update action) ",IORVON,IORVOFF)
     80 D SET(START+1,OFFSET,"    Insured's DOB: "_$$DAT3^IBOUTL($P(IBC3,"^")))
     81 D SET(START+2,OFFSET," Insured's Branch: "_$G(IBA(23,DA,.01,"E")))
     82 D SET(START+3,OFFSET,"   Insured's Rank: "_$P(IBC3,"^",3))
     83 D SET(START+4,OFFSET,"    Insured's SSN: "_$S(IBSSN]"":$E(IBSSN,1,3)_"-"_$E(IBSSN,4,5)_"-"_$E(IBSSN,6,9),1:""))
     84 ;
     85 S OFFSET=43
     86 S Y=$P(IBC3,"^",10) D ZIPOUT^VAFADDR S IBZIP=Y
     87 D SET(START+1,OFFSET," Str 1: "_$P(IBC3,"^",6))
     88 D SET(START+2,OFFSET," Str 2: "_$P(IBC3,"^",7))
     89 D SET(START+3,OFFSET,"  City: "_$P(IBC3,"^",8))
     90 D SET(START+4,OFFSET,"St/Zip: "_$P($G(^DIC(5,+$P(IBC3,"^",9),0)),"^",2)_"  "_IBZIP)
     91 D SET(START+5,OFFSET," Phone: "_$P(IBC3,"^",11))
     92 Q
     93 ;
     94BLANK(LINE) ; -- Build blank line
     95 D SET^VALM10(.LINE,$J("",80))
     96 Q
     97 ;
     98SET(LINE,COL,TEXT,ON,OFF) ; -- set display info in array
     99 D:'$D(@VALMAR@(LINE,0)) BLANK(.LINE)
     100 D SET^VALM10(.LINE,$$SETSTR^VALM1(.TEXT,@VALMAR@(LINE,0),.COL,$L(TEXT)))
     101 D:$G(ON)]""!($G(OFF)]"") CNTRL^VALM10(.LINE,.COL,$L(TEXT),$G(ON),$G(OFF))
     102 W:'(LINE#5) "."
     103 Q
     104GPLAN(IBPLDA) ; get data from PLAN file (#366.03) related to the
     105 ; GROUP INSURANCE PLAN file (#355.3) and the INSURANCE COMPANY file (#36)
     106 ; that is associated with the PATIENT
     107 ; input - IBPLDA - ien of the PLAN file (#366.03)
     108 N IBPLN0,IBAIEN,IBAPIEN,IBAP0
     109 S IBPLN0=$G(^IBCNR(366.03,IBPLDA,0)) ;; Q:'$P(IBPLN0,"^",3) ;quit if payer not defined
     110 S IBPLNID=$P(IBPLN0,"^"),IBPLNNM=$P(IBPLN0,"^",2)
     111 S IBAIEN=$O(^IBCNR(366.13,"B","E-PHARM","")) Q:'IBAIEN
     112 S IBAPIEN=$O(^IBCNR(366.03,IBPLDA,3,"B",IBAIEN,"")) Q:'IBAPIEN
     113 S IBAP0=$G(^IBCNR(366.03,IBPLDA,3,IBAPIEN,0))
     114 S IBPLNNA=$S($P(IBAP0,"^",2)=0:"NOT ACTIVE",1:"ACTIVE")
     115 S IBPLNLA=$S($P(IBAP0,"^",3)=0:"NOT ACTIVE",1:"ACTIVE")
     116 Q
     117 ;
     118 ;IBCNSP0

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSP01.m

    r613 r623  
    1 IBCNSP01        ;ALB/AAS - INSURANCE MANAGEMENT - EXPANDED POLICY  ;05-MAR-1993
    2         ;;2.0;INTEGRATED BILLING;**43,52,85,251,371,377**;21-MAR-94;Build 23
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5         ;
    6 %       D SUBSC,RIDER
    7         Q
    8         ;
    9 SUBSC   ; -- subscriber region
    10         N OFFSET,START
    11         S START=24,OFFSET=2
    12         D SET^IBCNSP(START,OFFSET," Subscriber Information ",IORVON,IORVOFF)
    13         S Y=$P(IBCDFND,"^",6),C=$P(^DD(2.312,6,0),"^",2) D Y^DIQ
    14         D SET^IBCNSP(START+1,OFFSET," Whose Insurance: "_Y)
    15         D SET^IBCNSP(START+2,OFFSET," Subscriber Name: "_$P(IBCDFND,"^",17))
    16         S Y=$P(IBCDFND4,"^",3),C=$P(^DD(2.312,4.03,0),"^",2) D Y^DIQ
    17         D SET^IBCNSP(START+3,OFFSET,"    Relationship: "_Y)
    18         D SET^IBCNSP(START+4,OFFSET,"      Primary ID: "_$P(IBCDFND,"^",2))
    19         S Y=$P(IBCDFND,"^",20),C=$P(^DD(2.312,.2,0),"^",2) D Y^DIQ
    20         D SET^IBCNSP(START+5,OFFSET,"Coord.  Benefits: "_Y)
    21         D SET^IBCNSP(START+6,OFFSET,"Primary Provider: "_$P(IBCDFND4,"^",1))
    22         D SET^IBCNSP(START+7,OFFSET," Prim Prov Phone: "_$P(IBCDFND4,"^",2))
    23         Q
    24         ;
    25 VER     ; -- Entered/Verfied Region
    26         N OFFSET,START
    27         S START=$O(^TMP("IBCNSVP",$J,""),-1)+1,OFFSET=2
    28         S IB1ST("VERIFY")=START
    29         D SET^IBCNSP(START,OFFSET," User Information ",IORVON,IORVOFF)
    30         D SET^IBCNSP(START+1,OFFSET,"      Entered By: "_$E($P($G(^VA(200,+$P(IBCDFND1,"^",2),0)),"^",1),1,20))
    31         D SET^IBCNSP(START+2,OFFSET,"      Entered On: "_$$DAT1^IBOUTL(+IBCDFND1))
    32         D SET^IBCNSP(START+3,OFFSET,"Last Verified By: "_$E($P($G(^VA(200,+$P(IBCDFND1,"^",4),0)),"^",1),1,20))
    33         D SET^IBCNSP(START+4,OFFSET,"Last Verified On: "_$$DAT1^IBOUTL(+$P(IBCDFND1,"^",3)))
    34         D SET^IBCNSP(START+5,OFFSET," Last Updated By: "_$E($P($G(^VA(200,+$P(IBCDFND1,"^",6),0)),"^",1),1,20))
    35         D SET^IBCNSP(START+6,OFFSET," Last Updated On: "_$$DAT1^IBOUTL(+$P(IBCDFND1,"^",5)))
    36         D SET^IBCNSP(START+7,2," ")   ; 2 blank lines to end section
    37         D SET^IBCNSP(START+8,2," ")
    38 VERQ    Q
    39         ;
    40 ID      ; Subscriber and patient primary and secondary ID's and qualifiers
    41         NEW START,OFFSET,IBL,G,PCE,QUAL,QUAL1
    42         S G=IBCDFND5
    43         S (START,IBL)=$O(^TMP("IBCNSVP",$J,""),-1)+1,OFFSET=2
    44         S IB1ST("ID")=START
    45         D SET^IBCNSP(START,OFFSET," Insurance Company ID Numbers (use Subscriber Update Action) ",IORVON,IORVOFF)
    46         S IBL=IBL+1
    47         D SET^IBCNSP(IBL,OFFSET,"  Subscriber Primary ID: "_$P(IBCDFND,U,2))
    48         ;
    49         F PCE=3,5,7 D            ; subscriber secondary IDs
    50         . I $P(G,U,PCE)="" Q     ; no secondary ID#
    51         . S QUAL=$P(G,U,PCE-1)   ; internal qualifier code
    52         . S QUAL1=$S(QUAL="23":"Client#",QUAL="IG":"Ins. Policy#",QUAL="SY":"SSN",1:"Unknown")
    53         . S IBL=IBL+1
    54         . D SET^IBCNSP(IBL,OFFSET,"Subscriber Secondary ID: "_$P(G,U,PCE))
    55         . D SET^IBCNSP(IBL,52,"ID Qual: "_QUAL_" ("_QUAL1_")")
    56         . Q
    57         ;
    58         ; patient=subscriber so skip over patient ID# display
    59         I +$P(IBCDFND,U,16)=1 G ID1
    60         ;
    61         S IBL=IBL+1 D SET^IBCNSP(IBL,2," ")   ; blank line
    62         S IBL=IBL+1
    63         D SET^IBCNSP(IBL,OFFSET,"     Patient Primary ID: "_$P(G,U,1))
    64         ;
    65         F PCE=9,11,13 D          ; patient secondary IDs
    66         . I $P(G,U,PCE)="" Q     ; no secondary ID#
    67         . S QUAL=$P(G,U,PCE-1)   ; internal qualifier code
    68         . S QUAL1=$S(QUAL="23":"Client#",QUAL="IG":"Ins. Policy#",QUAL="SY":"SSN",1:"Unknown")
    69         . S IBL=IBL+1
    70         . D SET^IBCNSP(IBL,OFFSET,"   Patient Secondary ID: "_$P(G,U,PCE))
    71         . D SET^IBCNSP(IBL,52,"ID Qual: "_QUAL_" ("_QUAL1_")")
    72         . Q
    73         ;
    74 ID1     ; end of section - 2 blank lines
    75         S IBL=IBL+1 D SET^IBCNSP(IBL,2," ")
    76         S IBL=IBL+1 D SET^IBCNSP(IBL,2," ")
    77 IDQ     ;
    78         Q
    79         ;
    80 RIDER   ; -- Personal policy riders
    81         N OFFSET,START,IBI,IBL,IBPR,IBPRD
    82         S START=$O(^TMP("IBCNSVP",$J,""),-1)+1,OFFSET=2,IBL=0
    83         D SET^IBCNSP(START,OFFSET," Personal Riders ",IORVON,IORVOFF)
    84         S IBI="" F  S IBI=$O(^IBA(355.7,"APP",DFN,IBCDFN,IBI)) Q:'IBI  S IBPR=$O(^(IBI,0)),IBPRD=+$G(^IBA(355.7,IBPR,0)),IBL=IBL+1 D
    85         . D SET^IBCNSP(START+IBL,OFFSET,"   Rider #"_IBL_": "_$$EXPAND^IBTRE(355.7,.01,IBPRD))
    86         . Q
    87         S IBL=IBL+1 D SET^IBCNSP(START+IBL,OFFSET," ")
    88         S IBL=IBL+1 D SET^IBCNSP(START+IBL,OFFSET," ")
    89         Q
    90         ;
    91 AI      ; -- Add ins. verification entry
    92         ;    called from ai^ibcnsp1
    93         ;
    94         ; -- see if current inpatient
    95         D INP^VADPT I +VAIN(1) D
    96         .S IBTRN=$O(^IBT(356,"AD",+VAIN(1),0))
    97         ;
    98         S IBXIFN=$O(^IBE(356.11,"ACODE",85,0))
    99         ;
    100         ; -- if not tracking id allow selecting
    101         I '$G(IBTRN) D  G:IBQUIT AIQ
    102         .W !,"You can now enter a contact and relate it to a Claims Tracking Admission entry."
    103         .S DIC("A")="Select RELATED ADMISSION DATE: "
    104         .S DIC="^IBT(356,",DIC(0)="AEQ",D="ADFN"_DFN,DIC("S")="I $P(^(0),U,5)"
    105         .D IX^DIC K DA,DR,DIC,DIE I $D(DUOUT)!($D(DTOUT)) S IBQUIT=1 Q
    106         .I +Y>1 S IBTRN=+Y
    107         ;
    108         I '$G(IBTRN) W !!,"Warning: This contact is not associated with any care in Claims Tracking.",!,"You may only edit or view this contact using this action.",!
    109         ;
    110         ; -- select date
    111         S IBOK=0,IBI=0 F  S IBI=$O(^IBT(356.2,"D",DFN,IBI)) Q:'IBI  I $P($G(^IBT(356.2,+IBI,0)),"^",4)=IBXIFN,$P($G(^(1)),"^",5)=IBCDFN S IBOK=1
    112         I IBOK D  G:IBQUIT AIQ
    113         .S DIC="^IBT(356.2,",DIC("A")="Select Contact Date: "
    114         .S X="??",DIC(0)="EQ",DIC("S")="I $P($G(^(1)),U,5)=IBCDFN,$P(^(0),U,4)=IBXIFN" ;,DLAYGO=356.2
    115         .S D="ADFN"_DFN
    116         .D IX^DIC K DIC,DR,DA,DIE,D I $D(DUOUT)!($D(DTOUT)) S IBQUIT=1
    117         ;
    118         S DIC="^IBT(356.2,",DIC("A")="Select Contact Date: ",DIC("B")="TODAY"
    119         S DIC("DR")=".02////"_$G(IBTRN)_";.04////"_IBXIFN_";.05////"_DFN_";.19////1;1.01///NOW;1.02////"_DUZ_";1.05////"_IBCDFN
    120         S DIC(0)="AEQL",DIC("S")="I $P(^(0),U,5)=DFN,$P($G(^(1)),U,5)=IBCDFN,$P(^(0),U,4)=IBXIFN",DLAYGO=356.2
    121         D ^DIC K DIC
    122         I $D(DTOUT)!($D(DUOUT))!(+Y<1) G AIQ
    123         S IBTRC=+Y
    124         I $G(IBTRC),$G(IBTRN),'$P(^IBT(356.2,+IBTRC,0),"^",2) S DA=IBTRC,DIE="^IBT(356.2,",DR=".02////"_$G(IBTRN) D ^DIE
    125         ;
    126         ; -- edit ins ver type
    127         D EDIT^IBTRCD1("[IBT INS VERIFICATION]",1)
    128 AIQ     Q
     1IBCNSP01 ;ALB/AAS - INSURANCE MANAGEMENT - EXPANDED POLICY  ; 05-MAR-1993
     2 ;;2.0;INTEGRATED BILLING;**43,52,85,251**;21-MAR-94
     3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
     4 ;
     5 ;
     6% D SUBSC,RIDER
     7 Q
     8 ;
     9SUBSC ; -- subscriber region
     10 N OFFSET,START
     11 S START=19,OFFSET=2
     12 D SET^IBCNSP(START,OFFSET," Subscriber Information ",IORVON,IORVOFF)
     13 S Y=$P(IBCDFND,"^",6),C=$P(^DD(2.312,6,0),"^",2) D Y^DIQ
     14 D SET^IBCNSP(START+1,OFFSET," Whose Insurance: "_Y)
     15 D SET^IBCNSP(START+2,OFFSET," Subscriber Name: "_$P(IBCDFND,"^",17))
     16 S Y=$P(IBCDFND,"^",16),C=$P(^DD(2.312,16,0),"^",2) D Y^DIQ
     17 D SET^IBCNSP(START+3,OFFSET,"    Relationship: "_Y)
     18 D SET^IBCNSP(START+4,OFFSET,"Insurance Number: "_$P(IBCDFND,"^",2))
     19 S Y=$P(IBCDFND,"^",20),C=$P(^DD(2.312,.2,0),"^",2) D Y^DIQ
     20 D SET^IBCNSP(START+5,OFFSET,"Coord.  Benefits: "_Y)
     21 D SET^IBCNSP(START+6,OFFSET,"Primary Provider: "_$P(IBCDFND4,"^",1))
     22 D SET^IBCNSP(START+7,OFFSET," Prim Prov Phone: "_$P(IBCDFND4,"^",2))
     23 Q
     24 ;
     25VER ; -- Entered/Verfied Region
     26 N OFFSET,START
     27 S START=41+$G(IBLCNT),OFFSET=2
     28 I '$D(@VALMAR@(START-1)) D SET^IBCNSP(START-1,OFFSET,"  ")
     29 D SET^IBCNSP(START,OFFSET," User Information ",IORVON,IORVOFF)
     30 I IBCDFND1="" D SET^IBCNSP(START+1,OFFSET,"No User Information") G VERQ
     31 D SET^IBCNSP(START+1,OFFSET,"      Entered By: "_$E($P($G(^VA(200,+$P(IBCDFND1,"^",2),0)),"^",1),1,20))
     32 D SET^IBCNSP(START+2,OFFSET,"      Entered On: "_$$DAT1^IBOUTL(+IBCDFND1))
     33 D SET^IBCNSP(START+3,OFFSET,"Last Verified By: "_$E($P($G(^VA(200,+$P(IBCDFND1,"^",4),0)),"^",1),1,20))
     34 D SET^IBCNSP(START+4,OFFSET,"Last Verified On: "_$$DAT1^IBOUTL(+$P(IBCDFND1,"^",3)))
     35 D SET^IBCNSP(START+5,OFFSET," Last Updated By: "_$E($P($G(^VA(200,+$P(IBCDFND1,"^",6),0)),"^",1),1,20))
     36 D SET^IBCNSP(START+6,OFFSET," Last Updated On: "_$$DAT1^IBOUTL(+$P(IBCDFND1,"^",5)))
     37VERQ Q
     38 ;
     39RIDER ; -- Personal policy riders
     40 N OFFSET,START,IBI,IBL,IBPR,IBPRD
     41 S START=53+$G(IBLCNT),OFFSET=2,IBL=0
     42 I '$D(@VALMAR@(START-1)) D SET^IBCNSP(START-1,OFFSET,"  ")
     43 D SET^IBCNSP(START,OFFSET," Personal Riders ",IORVON,IORVOFF)
     44 S IBI="" F  S IBI=$O(^IBA(355.7,"APP",DFN,IBCDFN,IBI)) Q:'IBI  S IBPR=$O(^(IBI,0)),IBPRD=+$G(^IBA(355.7,IBPR,0)),IBL=IBL+1 D
     45 .D SET^IBCNSP(START+IBL,OFFSET,"   Rider #"_IBL_": "_$$EXPAND^IBTRE(355.7,.01,IBPRD))
     46 S IBLCNT=$G(IBLCNT)+IBL
     47 Q
     48 ;
     49AI ; -- Add ins. verification entry
     50 ;    called from ai^ibcnsp1
     51 ;N X,Y,I,J,DA,DR,DIC,DIE,DR,DD,DO,VA,VAIN,VAERR,IBQUIT,IBXIFN,IBTRN,DUOUT,IBX,IBQUIT,DTOUT
     52 ;Q:'$G(DFN)
     53 ;Q:'$G(IBCDFN)  S IBQUIT=0
     54 ;
     55 ; -- see if current inpatient
     56 D INP^VADPT I +VAIN(1) D
     57 .S IBTRN=$O(^IBT(356,"AD",+VAIN(1),0))
     58 ;
     59 S IBXIFN=$O(^IBE(356.11,"ACODE",85,0))
     60 ;
     61 ; -- if not tracking id allow selecting
     62 I '$G(IBTRN) D  G:IBQUIT AIQ
     63 .W !,"You can now enter a contact and relate it to a Claims Tracking Admission entry."
     64 .S DIC("A")="Select RELATED ADMISSION DATE: "
     65 .S DIC="^IBT(356,",DIC(0)="AEQ",D="ADFN"_DFN,DIC("S")="I $P(^(0),U,5)"
     66 .D IX^DIC K DA,DR,DIC,DIE I $D(DUOUT)!($D(DTOUT)) S IBQUIT=1 Q
     67 .I +Y>1 S IBTRN=+Y
     68 ;
     69 I '$G(IBTRN) W !!,"Warning: This contact is not associated with any care in Claims Tracking.",!,"You may only edit or view this contact using this action.",!
     70 ;
     71 ; -- select date
     72 S IBOK=0,IBI=0 F  S IBI=$O(^IBT(356.2,"D",DFN,IBI)) Q:'IBI  I $P($G(^IBT(356.2,+IBI,0)),"^",4)=IBXIFN,$P($G(^(1)),"^",5)=IBCDFN S IBOK=1
     73 I IBOK D  G:IBQUIT AIQ
     74 .S DIC="^IBT(356.2,",DIC("A")="Select Contact Date: "
     75 .S X="??",DIC(0)="EQ",DIC("S")="I $P($G(^(1)),U,5)=IBCDFN,$P(^(0),U,4)=IBXIFN" ;,DLAYGO=356.2
     76 .S D="ADFN"_DFN
     77 .D IX^DIC K DIC,DR,DA,DIE,D I $D(DUOUT)!($D(DTOUT)) S IBQUIT=1
     78 ;
     79 S DIC="^IBT(356.2,",DIC("A")="Select Contact Date: ",DIC("B")="TODAY"
     80 S DIC("DR")=".02////"_$G(IBTRN)_";.04////"_IBXIFN_";.05////"_DFN_";.19////1;1.01///NOW;1.02////"_DUZ_";1.05////"_IBCDFN
     81 S DIC(0)="AEQL",DIC("S")="I $P(^(0),U,5)=DFN,$P($G(^(1)),U,5)=IBCDFN,$P(^(0),U,4)=IBXIFN",DLAYGO=356.2
     82 D ^DIC K DIC
     83 I $D(DTOUT)!($D(DUOUT))!(+Y<1) G AIQ
     84 S IBTRC=+Y
     85 I $G(IBTRC),$G(IBTRN),'$P(^IBT(356.2,+IBTRC,0),"^",2) S DA=IBTRC,DIE="^IBT(356.2,",DR=".02////"_$G(IBTRN) D ^DIE
     86 ;
     87 ; -- edit ins ver type
     88 D EDIT^IBTRCD1("[IBT INS VERIFICATION]",1)
     89AIQ Q

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSP1.m

    r613 r623  
    1 IBCNSP1 ;ALB/AAS - INSURANCE MANAGEMENT - policy actions ;22-OCT-92
    2         ;;2.0;INTEGRATED BILLING;**6,28,40,43,52,85,103,361,371,377**;21-MAR-94;Build 23
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;;ICR#5002 for read of ^DIE input template data
    5         ;
    6 %       G EN^IBCNSP
    7         ;
    8 EA      ; -- Edit all
    9         N IBCDFN,IBTRC,IBTRN
    10         D FULL^VALM1 W !!
    11         S IBCDFN=$P($G(IBPPOL),"^",4) I 'IBCDFN W !!,"Can't identify the policy!" G EAQ
    12         S IBCNSEH=1 D PAT^IBCNSEH
    13         ;
    14         D BEFORE^IBCNSEVT
    15         D PATPOL^IBCNSM32(IBCDFN)
    16         D AFTER^IBCNSEVT,^IBCNSEVT
    17         ;
    18         ; -- edit policy data
    19         D POL^IBCNSEH
    20         D EDPOL^IBCNSM3(IBCDFN)
    21         ;
    22         W !! D AI
    23         ;
    24 EAQ     D:$G(IBTRC) AIP^IBCNSP02(IBTRC)
    25         D BLD^IBCNSP
    26         S VALMBCK="R"
    27         Q
    28         ;
    29 AB      ; -- Annual Benefits
    30         S X=+$P($G(IBPPOL),"^",4),IBCNS=+$G(^DPT(DFN,.312,X,0)),IBCPOL=+$P($G(^(0)),"^",18)
    31         I 'IBCPOL W !!,"Can't identify the plan!" S VALMBCK="" G ABQ
    32         D FULL^VALM1 W !!
    33         D EN^VALM("IBCNS ANNUAL BENEFITS")
    34         S VALMBCK="R"
    35 ABQ     Q
    36         ;
    37 BU      ; -- Benefits Used
    38         S IBCDFN=+$P($G(IBPPOL),"^",4),IBCNS=+$G(^DPT(DFN,.312,IBCDFN,0)),IBCPOL=+$P($G(^(0)),"^",18)
    39         I 'IBCPOL W !!,"Can't identify the plan!" S VALMBCK="" G BUQ
    40         D FULL^VALM1 W !!
    41         D EN^VALM("IBCNS BENEFITS USED BY DATE")
    42         S VALMBCK="R"
    43 BUQ     Q
    44         ;
    45 IT      ; -- edit insurance type info from patient policy and plan edit
    46         D FULL^VALM1 W !!
    47         N IBCDFN
    48         S IBCDFN=+$P($G(IBPPOL),"^",4),IBCPOL=+$P($G(^DPT(DFN,.312,IBCDFN,0)),"^",18)
    49         I 'IBCPOL W !!,"Can't identify the plan!" S VALMBCK="" G ITQ
    50         D ITEDIT(IBCPOL,IBCDFN)
    51 ITQ     S VALMBCK="R" Q
    52         ;
    53 IT1     ; -- edit insurance type info from patient policy
    54         D ITEDIT(IBCPOL)
    55         S VALMBCK="R"
    56         Q
    57         ;
    58 ITEDIT(IBCPOL,IBCDFN)   ;Edit insurance type info once you have plan (IBCPOL)
    59         ; IBCDFN = the ifn of the policy multiple for pt in ^DPT, node .312
    60         ;          only defined for editing via patient policy
    61         G:'$G(IBCPOL) ITEDITQ
    62         D SAVE^IBCNSP3(IBCPOL)
    63         L +^IBA(355.3,+IBCPOL):5 I '$T D LOCKED^IBTRCD1 G ITEDITQ
    64         I $G(IBCDFN) S IBCNSEH=+$G(^IBE(350.9,1,4)) D POL^IBCNSEH
    65         I $P($G(^IBA(355.3,IBCPOL,0)),"^",11) W !?2,*7,"Please note that this plan is inactive!",!
    66         S DA=IBCPOL,DIE="^IBA(355.3,",DR=".05;.12;.06;.07;.08"
    67         D ^DIE K DIC,DIE,DA,DR
    68         D COMP^IBCNSP3(IBCPOL)
    69         I IBDIF D UPDATE^IBCNSP3(IBCPOL) D:$G(IBCDFN) UPDATPT^IBCNSP3(DFN,IBCDFN),BLD^IBCNSP D:'$G(IBCDFN) INIT^IBCNSC4
    70         L -^IBA(355.3,+IBCPOL)
    71 ITEDITQ Q
    72         ;
    73 ED      ; -- Edit effective dates
    74         D FULL^VALM1 W !!
    75         N IBDIF,DA,DR,DIE,DIC
    76         D BEFORE^IBCNSEVT
    77         D SAVEPT^IBCNSP3(DFN,IBCDFN)
    78         L +^DPT(DFN,.312,+$P($G(IBPPOL),"^",4)):5 I '$T D LOCKED^IBTRCD1 G EDQ
    79         D VARS^IBCNSP3
    80         S DR="8;3;1.09//;3.04"
    81         D ^DIE K DIC,DIE,DA,DR
    82         D COMPPT^IBCNSP3(DFN,IBCDFN) I IBDIF D UPDATPT^IBCNSP3(DFN,IBCDFN),UPDCLM(DFN,IBCDFN),AFTER^IBCNSEVT,^IBCNSEVT,BLD^IBCNSP
    83         L -^DPT(DFN,.312,+$P($G(IBPPOL),"^",4))
    84 EDQ     S VALMBCK="R" Q
    85         ;
    86 VC      ; -- Verify Coverage
    87         D FULL^VALM1 W !!
    88         D VFY^IBCNSM2
    89         D BLD^IBCNSP
    90         S VALMBCK="R" Q
    91         ;
    92 SU      ; -- Subscriber Update
    93         D FULL^VALM1 W !!
    94         ;Patch 40
    95         N IBDIF,DA,DR,DIC,DIE,DGSENFLG
    96         S DGSENFLG=1
    97         D SAVEPT^IBCNSP3(DFN,IBCDFN)
    98         D VARS^IBCNSP3
    99         L +^DPT(DFN,.312,+$P($G(IBPPOL),"^",4)):5 I '$T D LOCKED^IBTRCD1 G SUQ
    100         ;
    101         D EDIT(DFN,IBCDFN)   ; IB*371 - edit pat ins 2.312 subfile fields
    102         ;
    103         D COMPPT^IBCNSP3(DFN,IBCDFN)
    104         I IBDIF D UPDATPT^IBCNSP3(DFN,IBCDFN),BLD^IBCNSP
    105         L -^DPT(DFN,.312,+$P($G(IBPPOL),"^",4))
    106 SUQ     S VALMBCK="R" Q
    107         ;
    108 IC      ; -- Insurance Contact Information
    109         D FULL^VALM1 W !!
    110         N IBDIF,DA,DR,DIC,DIE,IBTRC,DIR,DUOUT,DTOUT,DIRUT,IBTRN
    111         D AI
    112         D:$G(IBTRC) AIP^IBCNSP02(IBTRC),BLD^IBCNSP
    113         S VALMBCK="R" Q
    114         Q
    115 AI      ; -- Add ins. verification entry
    116         N X,Y,I,J,DA,DR,DIC,DIE,DR,DD,DO,VA,VAIN,VAERR,IBQUIT,IBXIFN,IBTRN,DUOUT,IBX,IBQUIT,DTOUT
    117         Q:'$G(DFN)
    118         Q:'$G(IBCDFN)  S IBQUIT=0
    119         D AI^IBCNSP02
    120         Q
    121         ;
    122 PIDEF(IBREL,FLD,IBDFN,SPDEF)    ; Function to return patient file defaults
    123         ; Called from input template IBCN PATIENT INSURANCE
    124         ; IBREL = value from 2.312,4.03 field (PT. RELATIONSHIP - HIPAA)
    125         ;   FLD = field# in file 2.312
    126         ; IBDFN = patient ien to file 2
    127         ; SPDEF = spouse default flag =1 if this field should be defaulted
    128         ;         when the spouse is the policy holder
    129         ;
    130         ; The purpose is to provide a default value for the field when the
    131         ; patient and the ins. subscriber are the same.
    132         ;
    133         NEW VAL
    134         S VAL=""
    135         I +$G(IBREL)'=1,+$G(IBREL)'=18 G PIDEFX     ; patient not the insured or spouse, get out
    136         I +$G(IBREL)=1,'$G(SPDEF) G PIDEFX          ; not a field for spouse default
    137         I '$G(FLD) G PIDEFX                         ; no field# passed in
    138         I '$G(IBDFN) G PIDEFX                       ; no patient passed in
    139         ;
    140         ; Build the patient demographics area
    141         I '$D(^UTILITY("VADM",$J)) D
    142         . N VAHOW,DFN,VADM
    143         . S VAHOW=2,DFN=IBDFN D DEM^VADPT
    144         . Q
    145         ;
    146         ; Build the patient address area
    147         I '$D(^UTILITY("VAPA",$J)) D
    148         . N VAHOW,DFN,VAPA
    149         . S VAHOW=2,DFN=IBDFN,VAPA("P")="" D ADD^VADPT
    150         . Q
    151         ;
    152         I FLD=17 S VAL=$P($G(^UTILITY("VADM",$J,1)),U,1) G PIDEFX                          ; Name
    153         I FLD=3.01 S VAL=$$FMTE^XLFDT($P($G(^UTILITY("VADM",$J,3)),U,1),"5Z") G PIDEFX     ; Date of Birth
    154         I FLD=3.02 S VAL=$$EXTERNAL^DILFD(2,.325,,$P($G(^DPT(IBDFN,.32)),U,5)) G PIDEFX    ; Branch
    155         I FLD=3.05 S VAL=$P($G(^UTILITY("VADM",$J,2)),U,2) G PIDEFX                        ; SSN
    156         I FLD=3.06 S VAL=$P($G(^UTILITY("VAPA",$J,1)),U,1) G PIDEFX                        ; Street Address 1
    157         I FLD=3.07 S VAL=$P($G(^UTILITY("VAPA",$J,2)),U,1) G PIDEFX                        ; Street Address 2
    158         I FLD=3.08 S VAL=$P($G(^UTILITY("VAPA",$J,4)),U,1) G PIDEFX                        ; City
    159         I FLD=3.09 S VAL=$P($G(^UTILITY("VAPA",$J,5)),U,2) G PIDEFX                        ; State
    160         I FLD=3.1 S VAL=$P($G(^UTILITY("VAPA",$J,11)),U,2) G PIDEFX                        ; Zipcode
    161         I FLD=3.11 S VAL=$P($G(^UTILITY("VAPA",$J,8)),U,1) G PIDEFX                        ; Phone#
    162         I FLD=3.12 S VAL=$P($G(^UTILITY("VADM",$J,5)),U,2) G PIDEFX                        ; Sex
    163 PIDEFX  ;
    164         Q VAL
    165         ;
    166 ASK(QUES,DEFLT) ; Function to ask Yes/No Question
    167         ; Returns 1 (yes), 0 (no, up-arrow, or timeout)
    168         NEW X,Y,DIR,DTOUT,DUOUT,DIRUT,DIROUT
    169         S DIR(0)="Y",DIR("A")=$G(QUES)
    170         S DIR("B")=$S($G(DEFLT):"Yes",1:"No")
    171         W ! D ^DIR W:Y !
    172         I $D(DIRUT) S Y=0
    173 ASKX    ;
    174         Q Y
    175         ;
    176 EDIT(IBDFN,IBCDFN,IBQUIT)       ; Main call to edit data in 2.312 pat ins subfile
    177         ;  IBDFN - patient DFN
    178         ; IBCDFN - ien for patient insurance policy in subfile 2.312
    179         ; IBQUIT - Output variable.  Pass by reference.  Will be set to 1 if
    180         ;          the user entered an up-arrow, timed-out, or deleted the
    181         ;          2.312 subfile entry by entering "@" at the .01 field
    182         ;
    183         NEW DA,DR,DIE,IBZ,IBY,X,Y,DTOUT
    184         NEW IDS,SUB,PAT,PCE,SUB1,PAT1
    185         S DA(1)=+$G(IBDFN)    ; patient IEN
    186         S DA=+$G(IBCDFN)      ; patient insurance IEN
    187         I 'DA!'DA(1) G EDITX
    188         S DIE="^DPT("_IBDFN_",.312,"
    189         ;
    190         ; Find the input template IEN for the [IBCN PATIENT INSURANCE] template
    191         S IBY=+$$FIND1^DIC(.402,,"X","IBCN PATIENT INSURANCE")
    192         I 'IBY G EDITX
    193         ;
    194         ; Build the DR array/string - ICR# 5002
    195         M DR(1)=^DIE(IBY,"DR",2)
    196         S DR=$G(DR(1,2.312))
    197         I DR="" G EDITX
    198         ;
    199         S $P(^DIE(IBY,0),U,7)=DT   ; see TEM+2^DIE  ICR# 5002
    200         ;
    201         D ^DIE     ; edit subfile data
    202         ;
    203         ; If the user entered an up-arrow, or timed-out, or deleted the entry,
    204         ; then set the output variable IBQUIT
    205         I $D(Y)!$D(DTOUT)!'$D(DA) S IBQUIT=1
    206         ;
    207         F IBZ="VADM","VAPA" K ^UTILITY(IBZ,$J)    ; cleanup scratch global
    208         ;
    209         D UPDCLM(IBDFN,IBCDFN)      ; update editable claims
    210         ;
    211         ; Cleanup any problems in the secondary ID area
    212         S IDS=$G(^DPT(IBDFN,.312,IBCDFN,5))           ; whole 5 node
    213         S (SUB,PAT)=""
    214         F PCE=3:1:8 S $P(SUB,U,PCE)=$P(IDS,U,PCE-1)   ; subscriber sec ID/qual
    215         F PCE=3:1:8 S $P(PAT,U,PCE)=$P(IDS,U,PCE+5)   ; patient sec ID/qual
    216         ; SUB and PAT are 8-piece strings with pieces 1 and 2 being nil
    217         S SUB1=$$SCRUB^IBCEF21(SUB)                   ; scrub 8-piece string
    218         S PAT1=$$SCRUB^IBCEF21(PAT)                   ; scrub 8-piece string
    219         I SUB'=SUB1 S $P(^DPT(IBDFN,.312,IBCDFN,5),U,2,7)=$P(SUB1,U,3,8)
    220         I PAT'=PAT1 S $P(^DPT(IBDFN,.312,IBCDFN,5),U,8,13)=$P(PAT1,U,3,8)
    221         ;
    222 EDITX   ;
    223         Q
    224         ;
    225 UPDCLM(IBDFN,IBCDFN)    ; Update the Insurance nodes of claims that are still editable
    226         NEW IBIFN
    227         S IBIFN=0 F  S IBIFN=$O(^DGCR(399,"C",IBDFN,IBIFN)) Q:'IBIFN  D UPDCLM^IBCNSP2(IBIFN,IBDFN,IBCDFN)
    228         ;
    229 UPDCLMX ;
    230         Q
    231         ;
    232 PRELCNV(CODE,FLG)       ; conversion between X12, NCPDP and VistA pt. relationship codes
    233         ; CODE - code for pt. relationship to convert
    234         ; FLG - 0 for X12 -> VistA conversion, 1 for VistA -> X12 conversion, 2 - for VistA -> NCPDP conversion
    235         ; returns converted code for pt. relationship, or null if no match found
    236         N I,RES,VSTR,X12STR
    237         S VSTR="01^02^03^08^11^15^32^33^34^35^36"
    238         S X12STR="18^01^19^20^39^41^32^33^29^53^G8"
    239         S RES=""
    240         I FLG=0 F I=1:1:11 S:$P(X12STR,U,I)=CODE RES=$P(VSTR,U,I) Q:RES'=""
    241         I FLG=1 F I=1:1:11 S:$P(VSTR,U,I)=CODE RES=$P(X12STR,U,I) Q:RES'=""
    242         I FLG=2,+CODE>0 S RES=$S(+CODE>3:"04",1:CODE)
    243         Q RES
     1IBCNSP1 ;ALB/AAS - INSURANCE MANAGEMENT - policy actions ; 22-OCT-92
     2 ;;2.0;INTEGRATED BILLING;**6,28,40,43,52,85,103,361**;21-MAR-94;Build 9
     3 ;;Per VHA Directive 2004-038, this routine should not be modified.
     4 ;
     5% G EN^IBCNSP
     6 ;
     7EA ; -- Edit all
     8 N IBCDFN,IBTRC,IBTRN
     9 D FULL^VALM1 W !!
     10 S IBCDFN=$P($G(IBPPOL),"^",4) I 'IBCDFN W !!,"Can't identify the policy!" G EAQ
     11 S IBCNSEH=1 D PAT^IBCNSEH
     12 ;
     13 D BEFORE^IBCNSEVT
     14 D PATPOL^IBCNSM32(IBCDFN)
     15 D AFTER^IBCNSEVT,^IBCNSEVT
     16 ;
     17 ; -- edit policy data
     18 D POL^IBCNSEH
     19 D EDPOL^IBCNSM3(IBCDFN)
     20 ;
     21 W !! D AI
     22 ;
     23EAQ D:$G(IBTRC) AIP^IBCNSP02(IBTRC)
     24 D BLD^IBCNSP
     25 S VALMBCK="R"
     26 Q
     27 ;
     28AB ; -- Annual Benefits
     29 S X=+$P($G(IBPPOL),"^",4),IBCNS=+$G(^DPT(DFN,.312,X,0)),IBCPOL=+$P($G(^(0)),"^",18)
     30 I 'IBCPOL W !!,"Can't identify the plan!" S VALMBCK="" G ABQ
     31 D FULL^VALM1 W !!
     32 D EN^VALM("IBCNS ANNUAL BENEFITS")
     33 S VALMBCK="R"
     34ABQ Q
     35 ;
     36BU ; -- Benefits Used
     37 S IBCDFN=+$P($G(IBPPOL),"^",4),IBCNS=+$G(^DPT(DFN,.312,IBCDFN,0)),IBCPOL=+$P($G(^(0)),"^",18)
     38 I 'IBCPOL W !!,"Can't identify the plan!" S VALMBCK="" G BUQ
     39 D FULL^VALM1 W !!
     40 D EN^VALM("IBCNS BENEFITS USED BY DATE")
     41 S VALMBCK="R"
     42BUQ Q
     43 ;
     44IT ; -- edit insurance type info from patient policy and plan edit
     45 D FULL^VALM1 W !!
     46 N IBCDFN
     47 S IBCDFN=+$P($G(IBPPOL),"^",4),IBCPOL=+$P($G(^DPT(DFN,.312,IBCDFN,0)),"^",18)
     48 I 'IBCPOL W !!,"Can't identify the plan!" S VALMBCK="" G ITQ
     49 D ITEDIT(IBCPOL,IBCDFN)
     50ITQ S VALMBCK="R" Q
     51 ;
     52IT1 ; -- edit insurance type info from patient policy
     53 D ITEDIT(IBCPOL)
     54 S VALMBCK="R"
     55 Q
     56 ;
     57ITEDIT(IBCPOL,IBCDFN) ;Edit insurance type info once you have plan (IBCPOL)
     58 ; IBCDFN = the ifn of the policy multiple for pt in ^DPT, node .312
     59 ;          only defined for editing via patient policy
     60 G:'$G(IBCPOL) ITEDITQ
     61 D SAVE^IBCNSP3(IBCPOL)
     62 L +^IBA(355.3,+IBCPOL):5 I '$T D LOCKED^IBTRCD1 G ITEDITQ
     63 I $G(IBCDFN) S IBCNSEH=+$G(^IBE(350.9,1,4)) D POL^IBCNSEH
     64 I $P($G(^IBA(355.3,IBCPOL,0)),"^",11) W !?2,*7,"Please note that this plan is inactive!",!
     65 S DA=IBCPOL,DIE="^IBA(355.3,",DR=".05;.12;.06;.07;.08"
     66 D ^DIE K DIC,DIE,DA,DR
     67 D COMP^IBCNSP3(IBCPOL)
     68 I IBDIF D UPDATE^IBCNSP3(IBCPOL) D:$G(IBCDFN) UPDATPT^IBCNSP3(DFN,IBCDFN),BLD^IBCNSP D:'$G(IBCDFN) INIT^IBCNSC4
     69 L -^IBA(355.3,+IBCPOL)
     70ITEDITQ Q
     71 ;
     72ED ; -- Edit effective dates
     73 D FULL^VALM1 W !!
     74 N IBDIF,DA,DR,DIE,DIC
     75 D BEFORE^IBCNSEVT
     76 D SAVEPT^IBCNSP3(DFN,IBCDFN)
     77 L +^DPT(DFN,.312,+$P($G(IBPPOL),"^",4)):5 I '$T D LOCKED^IBTRCD1 G EDQ
     78 D VARS^IBCNSP3
     79 S DR="8;3;1.09//;3.04"
     80 D ^DIE K DIC,DIE,DA,DR
     81 D COMPPT^IBCNSP3(DFN,IBCDFN) I IBDIF D UPDATPT^IBCNSP3(DFN,IBCDFN),AFTER^IBCNSEVT,^IBCNSEVT,BLD^IBCNSP
     82 L -^DPT(DFN,.312,+$P($G(IBPPOL),"^",4))
     83EDQ S VALMBCK="R" Q
     84 ;
     85VC ; -- Verify Coverage
     86 D FULL^VALM1 W !!
     87 D VFY^IBCNSM2
     88 D BLD^IBCNSP
     89 S VALMBCK="R" Q
     90 ;
     91SU ; -- Subscriber Update
     92 D FULL^VALM1 W !!
     93 ;Patch 40
     94 N IBDIF,DA,DR,DIC,DIE,DGSENFLG
     95 S DGSENFLG=1
     96 D SAVEPT^IBCNSP3(DFN,IBCDFN)
     97 D VARS^IBCNSP3
     98 L +^DPT(DFN,.312,+$P($G(IBPPOL),"^",4)):5 I '$T D LOCKED^IBTRCD1 G SUQ
     99 S DR="6;S IBAD=X;K X I '$$VET^IBCNSU1() S Y=""@10"";17///^S X=$P(^DPT(DFN,0),U);16///^S X=""01"""
     100 S DR=DR_";S Y=""@20"";@10;17;16//^S X=$S(IBAD=""s"":""02"",1:"""");@20;1;.2;4.01;4.02;3.01;3.12;3.02;3.03;3.05:3.11"
     101 D ^DIE K DIC,DIE,DA,DR
     102 D COMPPT^IBCNSP3(DFN,IBCDFN)
     103 I IBDIF D UPDATPT^IBCNSP3(DFN,IBCDFN),BLD^IBCNSP
     104 L -^DPT(DFN,.312,+$P($G(IBPPOL),"^",4))
     105SUQ S VALMBCK="R" Q
     106 ;
     107IC ; -- Insurance Contact Information
     108 D FULL^VALM1 W !!
     109 N IBDIF,DA,DR,DIC,DIE,IBTRC,DIR,DUOUT,DTOUT,DIRUT,IBTRN
     110 D AI
     111 D:$G(IBTRC) AIP^IBCNSP02(IBTRC),BLD^IBCNSP
     112 S VALMBCK="R" Q
     113 Q
     114AI ; -- Add ins. verification entry
     115 N X,Y,I,J,DA,DR,DIC,DIE,DR,DD,DO,VA,VAIN,VAERR,IBQUIT,IBXIFN,IBTRN,DUOUT,IBX,IBQUIT,DTOUT
     116 Q:'$G(DFN)
     117 Q:'$G(IBCDFN)  S IBQUIT=0
     118 D AI^IBCNSP02
     119 Q

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSP2.m

    r613 r623  
    1 IBCNSP2 ;ALB/AAS - PATIENT INSURANCE INTERFACE FOR REGISTRATION ;21-JUNE-93
    2         ;;2.0;INTEGRATED BILLING;**6,28,75,82,155,371**;21-MAR-94;Build 57
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5 %       ;
    6 REG     ; --Edit Patient insurance from registration, fee and mccr, allow new entries
    7         ;   only edit policy if new policy
    8         ;   call event driver if adding a new policy
    9         ;
    10         ; -- Input  DFN  = patient
    11         ;
    12         I $G(DGPRFLG) D PREG^IBCNBME(DFN) Q
    13         D REG^IBCNBME(DFN)
    14         Q
    15         ;
    16         N DIC,DIE,DE,DQ,DIR,DA,DR,DIC,DIV,X,Y,I,J,L,D,DIH,DIY,IBSEL,IBDD,IBD,IBNEW,IBNEWP,IBDT,IBQUIT,IBCNS,IBCDFN,IBCNSEH,IBCNP,IBCPOL,IBOK,VALMQUIT,IBCNT,IBEVT1,IBEVTA,VAERR,IBCOVP
    17         S IBCNP=1
    18         I '$D(DFN) D  G:$D(VALMQUIT) REGQ
    19         .S DIC="^DPT(",DIC(0)="AEQMN" D ^DIC
    20         .S DFN=+Y
    21         I $G(DFN)<1 S IBQUIT=1,VALMQUIT="" G REGQ
    22         ;
    23         I '$$ASKCOVD(DFN,.IBCOV,.IBCOVP) S IBQUIT=1 G REGQ
    24         ;
    25 R1      S (IBNEW,IBNEWP,IBQUIT)=0
    26         S DIC="^DPT("_DFN_",.312,",DIC(0)="AEQLM",DIC("A")="Select INSURANCE COMPANY: "
    27         S DIC("W")="N IBD S IBD=$G(^DPT(DFN,.312,+Y,0)) W ""  Group: ""_$$GRP^IBCNS($P(IBD,U,18))_""  Whose: ""_$$EXPAND^IBTRE(2.312,6,$P(IBD,U,6))"
    28         I IBCNP=1 S X=$P($G(^DIC(36,+$G(^DPT(DFN,.312,+$P($G(^DPT(DFN,.312,0)),"^",3),0)),0)),"^") I X'="" S DIC("B")=X
    29         S DA(1)=DFN
    30         I $G(^DPT(DFN,.312,0))="" S ^DPT(DFN,.312,0)="^2.312PAI^^"
    31         D ^DIC K DIC I +Y<1 S IBQUIT=1,VALMQUIT="" G REGQ
    32         S IBCDFN=+Y,IBCNS=$P(Y,"^",2)
    33         I $P(Y,"^",3) S IBNEW=1 I $$DUPCO^IBCNSOK1(DFN,IBCNS,IBCDFN,1)
    34         D BEFORE^IBCNSEVT
    35         S IBCNSEH=$P($G(^IBE(350.9,1,4)),"^",1)
    36         S IBCNP=IBCNP+1
    37         I 'IBNEW,$P($G(^DPT(DFN,.312,+IBCDFN,0)),"^",18)="" D  G REGQ
    38         .I '$P($G(^IBE(350.9,1,3)),"^",18) W !,"Insurance conversion not complete, NO EDITING ALLOWED",!! S IBQUIT=1 H 3 Q
    39         .I $P($G(^IBE(350.9,1,3)),"^",18) W !,"INVALID ENTRY, DELETE AND RE-ENTER, NO EDITING ALLOWED",!! S IBQUIT=1 H 3 Q
    40         ;
    41         I $G(IBFEE),'$G(IBNEW) G REGQ ; fee users can add but not edit existing  info
    42         I $G(IBNEW) D  G:$G(IBQUIT) REGQ
    43         .D SEL^IBCNSEH
    44         .S IBCPOL=$$LK^IBCNSM31(IBCNS)
    45         .I IBCPOL<1 D NEW^IBCNSJ3(IBCNS,.IBCPOL) S:IBCPOL<1 IBQUIT=1 Q:IBQUIT  S IBNEWP=1
    46         .;  dgprflg is a 1 if called from pre-registration, set default 4
    47         .;  for pre-reg, otherwise set the default to 1 for interview
    48         .S DR=".18////"_IBCPOL_";1.09////"_$S($G(DGPRFLG):4,1:1)_";1.05///NOW;1.06////"_DUZ
    49         .S DA=IBCDFN,DA(1)=DFN,DIE="^DPT("_DFN_",.312," D ^DIE
    50         .K DIE,DA,DR,DIC
    51         ;
    52         ; -- edit patient ins. data
    53         S IBREG=1 G:$G(IBQUIT) REGQ
    54         D PAT^IBCNSEH,PATPOL^IBCNSM32(IBCDFN),UPDCLM(+$G(IBIFN),DFN,IBCDFN)
    55         ;
    56         ; -- edit policy specific data if new or have key
    57         I $G(IBNEWP)!($D(^XUSEC("IB INSURANCE SUPERVISOR",DUZ))) D:'$G(IBQUIT) POL^IBCNSEH,EDPOL^IBCNSM3(IBCDFN)
    58         K IBREG S IBQUIT=0
    59         ;
    60 REGQ    ; -- exit logic and checks
    61         ; -- if no policy pointer delete
    62         I $G(IBNEW),$G(IBCDFN),$P($G(^DPT(DFN,.312,+IBCDFN,0)),"^",18)="" D
    63         .D DP1^IBCNSM1 W !,"<DELETED>  GROUP INSURANCE PLAN REQUIRED BUT NOT ENTERED" K IBNEW
    64         ;
    65         ; -- call event driver
    66         I $G(IBCDFN),$P($G(^DPT(DFN,.312,+$G(IBCDFN),0)),"^",18) D
    67         .K IBNEW
    68         .D AFTER^IBCNSEVT,^IBCNSEVT
    69         ;
    70         K IBCNS,IBCDFN,IBNEW,IBNEWP
    71         I '$G(IBQUIT) W ! G R1
    72         D COVERED^IBCNSM31(DFN,$G(IBCOVP))
    73         K IBQUIT
    74         Q
    75         ;
    76 FEE     ; -- fee entry point to add patient insurance.
    77         D FEE^IBCNBME(DFN)
    78         Q
    79         ;
    80 MCCR    ; -- called from screen 3 of the edit bill option in mccr
    81         N DLAYGO,DIC,DIE,DE,DQ,DIR,DA,DR,DIC,DIV,X,Y,I,J,L,D,DIH,DIY,IBSEL,IBDD,IBD,IBNEW,IBNEWP,IBDT,IBQUIT,IBCNS,IBCDFN,IBCNSEH,IBCNP,IBCPOL,IBOK,VALMQUIT,IBMCR
    82         ;
    83         S IBCNP=1,IBMCR=$$WNRBILL^IBEFUNC(IBIFN)
    84         S DIE="^DGCR(399,",DA=IBIFN,DR="[IB SCREEN3]" D ^DIE K DIC,DIE,DA,DR
    85         ;
    86         I $G(IBADI)=1 D R1 S IBCNRTN=1 K IBADI G MCCR
    87         I 'IBMCR,$$WNRBILL^IBEFUNC(IBIFN) S DGRVRCAL=1
    88         K IBCNRTN
    89         Q
    90         ;
    91 UPDCLM(IBIFN,DFN,IBCDFN)        ; Update the claim's insurance nodes when edits are made
    92         ;   to the patient insurance file.
    93         ;  This procedure is called when a claim is being edited from IB billing
    94         ;  screen#3 and also when the patient insurance is being edited directly.
    95         ;
    96         I '$G(IBIFN)!'$G(DFN)!'$G(IBCDFN) Q         ; missing something
    97         I $P($G(^DGCR(399,IBIFN,0)),U,2)'=DFN Q     ; mismatch of claim and DFN
    98         I $P($G(^DGCR(399,IBIFN,0)),U,13)'=1 Q      ; claim not editable
    99         I '$D(^DPT(DFN,.312,IBCDFN,0)) Q            ; missing pat ins data
    100         NEW X,Z,NODE
    101         S X=IBCDFN
    102         F Z=1:1:3 I $P($G(^DGCR(399,IBIFN,"M")),U,11+Z)=IBCDFN D  Q
    103         . S NODE="I"_Z
    104         . D IX^IBCNS2(IBIFN,NODE)
    105         . Q
    106         Q
    107         ;
    108 DISP    ; -- Display Patient insurance policy information for registrations
    109         Q:'$D(DFN)
    110         D DISP^IBCNS
    111 DISPQ   Q
    112         ;
    113 ASKCOVD(DFN,IBCOV,IBCOVP)       ; ask user if patient covered by insurance (2,.3192), returns true if answered yes
    114         ;
    115         N IBX,IBINSD,DIC,DIE,DA,DR,X,Y,DTOUT
    116         ;
    117         S IBCOV=$P($G(^DPT(DFN,.31)),"^",11),IBINSD=$$INSURED^IBCNS1(DFN),IBX=1 W !
    118         ;
    119         ; -- if covered by ins but none currently active so indicate
    120         I IBCOV="Y",'IBINSD W !!,"Covered By Health Insurance indicates 'YES' but none currently Active.",!,"Please Review!",!!
    121         ;
    122         ; -- ask if covered by insurance
    123         S DIE="^DPT(",DR=".3192",DA=DFN D ^DIE K DIC,DIE,DA,DR I $D(Y)!($D(DTOUT)) S IBX=0
    124         ;
    125         S IBCOVP=$P($G(^DPT(DFN,.31)),"^",11) I +IBX,IBCOVP'="Y",'IBINSD S IBX=0
    126         ;
    127         Q IBX
     1IBCNSP2 ;ALB/AAS - PATIENT INSURANCE INTERFACE FOR REGISTRATION ;21-JUNE-93
     2 ;;2.0;INTEGRATED BILLING;**6,28,75,82,155**;21-MAR-94
     3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
     4 ;
     5% ;
     6REG ; --Edit Patient insurance from registration, fee and mccr, allow new entries
     7 ;   only edit policy if new policy
     8 ;   call event driver if adding a new policy
     9 ;
     10 ; -- Input  DFN  = patient
     11 ;
     12 I $G(DGPRFLG) D PREG^IBCNBME(DFN) Q
     13 D REG^IBCNBME(DFN)
     14 Q
     15 ;
     16 N DIC,DIE,DE,DQ,DIR,DA,DR,DIC,DIV,X,Y,I,J,L,D,DIH,DIY,IBSEL,IBDD,IBD,IBNEW,IBNEWP,IBDT,IBQUIT,IBCNS,IBCDFN,IBCNSEH,IBCNP,IBCPOL,IBOK,VALMQUIT,IBCNT,IBEVT1,IBEVTA,VAERR,IBCOVP
     17 S IBCNP=1
     18 I '$D(DFN) D  G:$D(VALMQUIT) REGQ
     19 .S DIC="^DPT(",DIC(0)="AEQMN" D ^DIC
     20 .S DFN=+Y
     21 I $G(DFN)<1 S IBQUIT=1,VALMQUIT="" G REGQ
     22 ;
     23 I '$$ASKCOVD(DFN,.IBCOV,.IBCOVP) S IBQUIT=1 G REGQ
     24 ; -- of covered by ins but none currently active so indicate
     25 ;S IBCOV=$P($G(^DPT(DFN,.31)),"^",11)
     26 ;I IBCOV="Y",'$$INSURED^IBCNS1(DFN) W !!,"Covered By Health Insurance indicates 'YES' but none currently Active.",!,"Please Review!",!!
     27 ;
     28 ;; -- ask if covered by insuracnce
     29 ;S DIE="^DPT(",DR=".3192",DA=DFN D ^DIE K DIC,DIE,DA,DR
     30 ;S IBCOVP=$P($G(^DPT(DFN,.31)),"^",11)
     31 ;I $D(Y)!($D(DTOUT)) S IBQUIT=1 G REGQ
     32 ;I $P($G(^DPT(DFN,.31)),"^",11)'="Y",'$$INSURED^IBCNS1(DFN) S IBQUIT=1 G REGQ
     33 ;
     34R1 S (IBNEW,IBNEWP,IBQUIT)=0
     35 S DIC="^DPT("_DFN_",.312,",DIC(0)="AEQLM",DIC("A")="Select INSURANCE COMPANY: "
     36 S DIC("W")="N IBD S IBD=$G(^DPT(DFN,.312,+Y,0)) W ""  Group: ""_$$GRP^IBCNS($P(IBD,U,18))_""  Whose: ""_$$EXPAND^IBTRE(2.312,6,$P(IBD,U,6))"
     37 I IBCNP=1 S X=$P($G(^DIC(36,+$G(^DPT(DFN,.312,+$P($G(^DPT(DFN,.312,0)),"^",3),0)),0)),"^") I X'="" S DIC("B")=X
     38 S DA(1)=DFN
     39 I $G(^DPT(DFN,.312,0))="" S ^DPT(DFN,.312,0)="^2.312PAI^^"
     40 D ^DIC K DIC I +Y<1 S IBQUIT=1,VALMQUIT="" G REGQ
     41 S IBCDFN=+Y,IBCNS=$P(Y,"^",2)
     42 I $P(Y,"^",3) S IBNEW=1 I $$DUPCO^IBCNSOK1(DFN,IBCNS,IBCDFN,1)
     43 D BEFORE^IBCNSEVT
     44 S IBCNSEH=$P($G(^IBE(350.9,1,4)),"^",1)
     45 S IBCNP=IBCNP+1
     46 I 'IBNEW,$P($G(^DPT(DFN,.312,+IBCDFN,0)),"^",18)="" D  G REGQ
     47 .I '$P($G(^IBE(350.9,1,3)),"^",18) W !,"Insurance conversion not complete, NO EDITING ALLOWED",!! S IBQUIT=1 H 3 Q
     48 .I $P($G(^IBE(350.9,1,3)),"^",18) W !,"INVALID ENTRY, DELETE AND RE-ENTER, NO EDITING ALLOWED",!! S IBQUIT=1 H 3 Q
     49 ;
     50 I $G(IBFEE),'$G(IBNEW) G REGQ ; fee users can add but not edit existing  info
     51 I $G(IBNEW) D  G:$G(IBQUIT) REGQ
     52 .D SEL^IBCNSEH
     53 .S IBCPOL=$$LK^IBCNSM31(IBCNS)
     54 .I IBCPOL<1 D NEW^IBCNSJ3(IBCNS,.IBCPOL) S:IBCPOL<1 IBQUIT=1 Q:IBQUIT  S IBNEWP=1
     55 .;  dgprflg is a 1 if called from pre-registration, set default 4
     56 .;  for pre-reg, otherwise set the default to 1 for interview
     57 .S DR=".18////"_IBCPOL_";1.09////"_$S($G(DGPRFLG):4,1:1)_";1.05///NOW;1.06////"_DUZ
     58 .S DA=IBCDFN,DA(1)=DFN,DIE="^DPT("_DFN_",.312," D ^DIE
     59 .K DIE,DA,DR,DIC
     60 ;
     61 ; -- edit patient ins. data
     62 S IBREG=1 G:$G(IBQUIT) REGQ
     63 D PAT^IBCNSEH,PATPOL^IBCNSM32(IBCDFN)
     64 ;
     65 ; -- edit policy specific data if new or have key
     66 I $G(IBNEWP)!($D(^XUSEC("IB INSURANCE SUPERVISOR",DUZ))) D:'$G(IBQUIT) POL^IBCNSEH,EDPOL^IBCNSM3(IBCDFN)
     67 K IBREG S IBQUIT=0
     68 ;
     69REGQ ; -- exit logic and checks
     70 ; -- if no policy pointer delete
     71 I $G(IBNEW),$G(IBCDFN),$P($G(^DPT(DFN,.312,+IBCDFN,0)),"^",18)="" D
     72 .D DP1^IBCNSM1 W !,"<DELETED>  GROUP INSURANCE PLAN REQUIRED BUT NOT ENTERED" K IBNEW
     73 ;
     74 ; -- call event driver
     75 I $G(IBCDFN),$P($G(^DPT(DFN,.312,+$G(IBCDFN),0)),"^",18) D
     76 .K IBNEW
     77 .D AFTER^IBCNSEVT,^IBCNSEVT
     78 ;
     79 K IBCNS,IBCDFN,IBNEW,IBNEWP
     80 I '$G(IBQUIT) W ! G R1
     81 D COVERED^IBCNSM31(DFN,$G(IBCOVP))
     82 K IBQUIT
     83 Q
     84 ;
     85FEE ; -- fee entry point to add patient insurance.
     86 ;N IBFEE S IBFEE=1 D REG
     87 D FEE^IBCNBME(DFN)
     88 Q
     89 ;
     90MCCR ; -- called from screen 3 of the edit bill option in mccr
     91 N DLAYGO,DIC,DIE,DE,DQ,DIR,DA,DR,DIC,DIV,X,Y,I,J,L,D,DIH,DIY,IBSEL,IBDD,IBD,IBNEW,IBNEWP,IBDT,IBQUIT,IBCNS,IBCDFN,IBCNSEH,IBCNP,IBCPOL,IBOK,VALMQUIT,IBMCR
     92 ;
     93 S IBCNP=1,IBMCR=$$WNRBILL^IBEFUNC(IBIFN)
     94 S DIE="^DGCR(399,",DA=IBIFN,DR="[IB SCREEN3]" D ^DIE K DIC,DIE,DA,DR
     95 ;
     96 I $G(IBADI)=1 D R1 S IBCNRTN=1 K IBADI G MCCR
     97 I 'IBMCR,$$WNRBILL^IBEFUNC(IBIFN) S DGRVRCAL=1
     98 K IBCNRTN
     99 Q
     100 ;
     101DISP ; -- Display Patient insurance policy information for registrations
     102 Q:'$D(DFN)
     103 D DISP^IBCNS
     104DISPQ Q
     105 ;
     106ASKCOVD(DFN,IBCOV,IBCOVP) ; ask user if patient covered by insurance (2,.3192), returns true if answered yes
     107 ;
     108 N IBX,IBINSD,DIC,DIE,DA,DR,X,Y,DTOUT
     109 ;
     110 S IBCOV=$P($G(^DPT(DFN,.31)),"^",11),IBINSD=$$INSURED^IBCNS1(DFN),IBX=1 W !
     111 ;
     112 ; -- if covered by ins but none currently active so indicate
     113 I IBCOV="Y",'IBINSD W !!,"Covered By Health Insurance indicates 'YES' but none currently Active.",!,"Please Review!",!!
     114 ;
     115 ; -- ask if covered by insurance
     116 S DIE="^DPT(",DR=".3192",DA=DFN D ^DIE K DIC,DIE,DA,DR I $D(Y)!($D(DTOUT)) S IBX=0
     117 ;
     118 S IBCOVP=$P($G(^DPT(DFN,.31)),"^",11) I +IBX,IBCOVP'="Y",'IBINSD S IBX=0
     119 ;
     120 Q IBX

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSP3.m

    r613 r623  
    1 IBCNSP3 ;ALB/AAS - INSURANCE MANAGEMENT EDIT ;06-JUL-93
    2         ;;2.0;INTEGRATED BILLING;**28,52,85,251,371**;21-MAR-94;Build 57
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5 %       G ^IBCNSM4
    6         ;
    7 SAVEPT(DFN,DA)  ; -- Save the global before editing
    8         K ^TMP($J,"IBCNSPT")
    9         S ^TMP($J,"IBCNSPT",2.312,DFN,+DA,0)=$G(^DPT(DFN,.312,+DA,0))
    10         S ^TMP($J,"IBCNSPT",2.312,DFN,+DA,1)=$G(^DPT(DFN,.312,+DA,1))
    11         S ^TMP($J,"IBCNSPT",2.312,DFN,+DA,2)=$G(^DPT(DFN,.312,+DA,2))
    12         S ^TMP($J,"IBCNSPT",2.312,DFN,+DA,3)=$G(^DPT(DFN,.312,+DA,3))
    13         S ^TMP($J,"IBCNSPT",2.312,DFN,+DA,4)=$G(^DPT(DFN,.312,+DA,4))
    14         S ^TMP($J,"IBCNSPT",2.312,DFN,+DA,5)=$G(^DPT(DFN,.312,+DA,5))
    15         Q
    16         ;
    17 COMPPT(DFN,DA)  ; -- Compare before editing with globals
    18         S IBDIF=0
    19         I $G(^DPT(DFN,.312,+DA,0))'=$G(^TMP($J,"IBCNSPT",2.312,DFN,+DA,0)) S IBDIF=1 G COMPPTQ
    20         I $G(^DPT(DFN,.312,+DA,1))'=$G(^TMP($J,"IBCNSPT",2.312,DFN,+DA,1)) S IBDIF=1 G COMPPTQ
    21         I $G(^DPT(DFN,.312,+DA,2))'=$G(^TMP($J,"IBCNSPT",2.312,DFN,+DA,2)) S IBDIF=1 G COMPPTQ
    22         I $G(^DPT(DFN,.312,+DA,3))'=$G(^TMP($J,"IBCNSPT",2.312,DFN,+DA,3)) S IBDIF=1 G COMPPTQ
    23         I $G(^DPT(DFN,.312,+DA,4))'=$G(^TMP($J,"IBCNSPT",2.312,DFN,+DA,4)) S IBDIF=1 G COMPPTQ
    24         I $G(^DPT(DFN,.312,+DA,5))'=$G(^TMP($J,"IBCNSPT",2.312,DFN,+DA,5)) S IBDIF=1 G COMPPTQ
    25         ;
    26 COMPPTQ I IBDIF D:'$D(IBCOVP) COVERED^IBCNSM31(DFN,$P($G(^DPT(DFN,.31)),"^",11))
    27         Q
    28         ;
    29 UPDATPT(DFN,DA) ; -- enter date and user if editing has taken place
    30         N DR,DIE,DIC
    31         S DIE="^DPT("_DFN_",.312,",DA(1)=DFN
    32         S DR="1.05///NOW;1.06////"_DUZ
    33         D ^DIE
    34         Q
    35         ;
    36 EM      ; -- Employer for claims update
    37         D FULL^VALM1 W !!
    38         N IBDIF,DA,DR,DIC,DIE
    39         D SAVEPT(DFN,IBCDFN)
    40         D VARS
    41         L +^DPT(DFN,.312,+$P($G(IBPPOL),"^",4)):5 I '$T D LOCKED^IBTRCD1 G EMQ
    42         ;
    43         ;S DR="2.01;S:'$P($G(^DPT(DFN,.312,+$G(DA),2)),U) Y=""@999"";W !!,""*** If ROI applies, make sure current consent is signed! ***"",!;2.015;2.02;2.03;2.04;2.05;2.06;2.07;2.08;2.09;@999"
    44         ;
    45         S DR="2.1" D ^DIE K DIE,DR
    46         ;
    47         I +$P($G(^DPT(DFN,.312,+$G(DA),2)),U,10),$P($G(^DPT(DFN,.312,+$G(DA),2)),U,9)="" D EMPSET(DFN,$G(DA)) ; curr emp
    48         ;
    49         I +$P($G(^DPT(DFN,.312,+$G(DA),2)),U,10) D VARS S DR="2.015;2.11;2.12;2.01;W:+X !!,""*** If ROI applies, make sure current consent is signed! ***"",!!;2.02;2.03;2.04;2.05;2.06;2.07;2.08;@999" D ^DIE K DIE,DR
    50         ;
    51         ;I '$P($G(^DPT(DFN,.312,+$G(DA),2)),U) D VARS S DR="2.015///@;2.02///@;2.03///@;2.04///@;2.05///@;2.06///@;2.07///@;2.08///@" D ^DIE
    52         ;
    53         I '$P($G(^DPT(DFN,.312,+$G(DA),2)),U,10) D VARS S DR="2.01///@;2.015///@;2.02///@;2.03///@;2.04///@;2.05///@;2.06///@;2.07///@;2.08///@;2.11///@;2.12///@" D ^DIE
    54         ;
    55         D COMPPT(DFN,IBCDFN)
    56         I IBDIF D UPDATPT(DFN,IBCDFN),BLD^IBCNSP
    57         L -^DPT(DFN,.312,+$P($G(IBPPOL),"^",4))
    58 EMQ     S VALMBCK="R" Q
    59         ;
    60 AC      ; -- Add Comment
    61         D FULL^VALM1 W !!
    62         N IBDIF,DA,DR,DIE,DIC,X,Y
    63         D SAVEPT(DFN,IBCDFN)
    64         W !!,"You may now enter a brief comment about this patient's policy"
    65         D VARS
    66         L +^DPT(DFN,.312,+$P($G(IBPPOL),"^",4)):5 I '$T D LOCKED^IBTRCD1 G ACQ
    67         S DR="1.08" D ^DIE
    68         D COMPPT(DFN,IBCDFN) I IBDIF D UPDATPT(DFN,IBCDFN)
    69         L -^DPT(DFN,.312,+$P($G(IBPPOL),"^",4))
    70         W !!,"You may now enter comments about this Group Plan that pertains to all Patients"
    71         L +^IBA(355.3,+IBCPOL):5 I '$T D LOCKED^IBTRCD1 G ACQ
    72         S DIE="^IBA(355.3,",DA=IBCPOL,DR="11" D ^DIE
    73         D BLD^IBCNSP
    74         L -^IBA(355.3,+IBCPOL)
    75 ACQ     S VALMBCK="R" Q
    76         ;
    77 BLS(X,Y)        ; -- blank a section of lines
    78         N I
    79         F I=X:1:Y D BLANK^IBCNSP(.I)
    80         Q
    81         ;
    82 VARS    ; -- set vars for call to die for .312 node
    83         S DA(1)=DFN,DA=$P(IBPPOL,"^",4)
    84         S DIE="^DPT("_DA(1)_",.312,"
    85         Q
    86         ;
    87 SAVE(IBCPOL)    ; -- Save the global before editing
    88         K ^TMP($J,"IBCNSP")
    89         S ^TMP($J,"IBCNSP",355.3,+IBCPOL,0)=$G(^IBA(355.3,+IBCPOL,0))
    90         S ^TMP($J,"IBCNSP",355.3,+IBCPOL,1)=$G(^IBA(355.3,+IBCPOL,1))
    91         ;;Daou/EEN - adding BIN and PCN
    92         S ^TMP($J,"IBCNSP",355.3,+IBCPOL,6)=$G(^IBA(355.3,+IBCPOL,6))
    93         Q
    94         ;
    95 COMP(IBCPOL)    ; -- Compare before editing with globals
    96         S IBDIF=0
    97         I $G(^IBA(355.3,+IBCPOL,0))'=$G(^TMP($J,"IBCNSP",355.3,+IBCPOL,0)) S IBDIF=1 Q
    98         I $G(^IBA(355.3,+IBCPOL,1))'=$G(^TMP($J,"IBCNSP",355.3,+IBCPOL,1)) S IBDIF=1 Q
    99         ;;Daou/EEN - adding BIN and PCN
    100         I $G(^IBA(355.3,+IBCPOL,6))'=$G(^TMP($J,"IBCNSP",355.3,+IBCPOL,6)) S IBDIF=1 Q
    101         Q
    102         ;
    103 UPDATE(IBCPOL)  ; -- Update last edited by
    104         N DA,DIC,DIE,DR
    105         S DIE="^IBA(355.3,",DA=IBCPOL,DR="1.05///NOW;1.06////"_DUZ
    106         D ^DIE
    107         Q
    108         ;
    109 RIDERS  ; -- add/edit personal riders
    110         ;
    111         D FULL^VALM1
    112         N IBDIF,DA,DR,DIE,DIC,X,Y,IBCDFN,IBPRD,IBPRY
    113         S IBCDFN=$P(IBPPOL,"^",4)
    114         W ! D DISPR W !
    115         ;
    116 R1      S DIC="^IBA(355.7,",DIC(0)="AEQML",DLAYGO=355.7
    117         S DIC("DR")=".02////"_DFN_";.03////"_IBCDFN
    118         S DIC("S")="I $P(^(0),U,2)=DFN,$P(^(0),U,3)=IBCDFN"
    119         I $D(IBPRD) S DIC("B")=IBPRD
    120         D ^DIC K DIC,IBPRD
    121         I +Y<1 G RIDERQ
    122         S IBPRY=+Y
    123         L +^IBA(355.7,IBPRY):5 I '$T D LOCKED^IBTRCD1 G RIDERQ
    124         S DIE="^IBA(355.7,",DA=+Y,DR=".01",DIDEL=355.7
    125         D ^DIE K DA,DR,DIE,DIC,DIDEL
    126         L -^IBA(355.7,IBPRY)
    127         W ! G R1
    128 RIDERQ  S VALMBCK="R"
    129         Q
    130         ;
    131 RD      ; -- Add riders/ for multiple policies
    132         D FULL^VALM1
    133         N I,J,IBXX,VALMY
    134         D EN^VALM2($G(XQORNOD(0)))
    135         I $D(VALMY) S IBXX=0 F  S IBXX=$O(VALMY(IBXX)) Q:'IBXX  D
    136         .S IBPPOL=$G(^TMP("IBNSMDX",$J,$O(^TMP("IBNSM",$J,"IDX",IBXX,0))))
    137         .Q:IBPPOL=""
    138         .D RIDERS
    139         .Q
    140         D BLD^IBCNSM
    141         S VALMBCK="R"
    142         Q
    143         ;
    144 DISPR   ; -- Display riders
    145         N IBPR,I,J
    146         S I=0
    147         I '$G(IBCDFN)!('$G(DFN)) G DISPRQ
    148         W !,"Current Personal Riders: "
    149         F  S I=$O(^IBA(355.7,"APP",DFN,IBCDFN,I)) Q:'I  S J=$O(^(I,0)),IBPR=$G(^IBA(355.7,+J,0)) D
    150         .S IBPRD=$$EXPAND^IBTRE(355.7,.01,+IBPR)
    151         .W !?5,IBPRD
    152         I '$D(IBPRD) W !?5,"None Indicated"
    153 DISPRQ  Q
    154         ;
    155 EMPSET(DFN,IBCPOL)      ; insert patient or spouses current employer as ESGHP address if that employer sponsors this plan
    156         N IBWHOS,VAOA,DIR,IBE,IBEMPST,DR,X,Y
    157         I +$G(DFN) S IBWHOS=$P($G(^DPT(DFN,.312,+$G(IBCPOL),0)),U,6) S VAOA("A")=$S(IBWHOS="v":5,IBWHOS="s":6,1:"")
    158         I $G(VAOA("A"))'="" D OAD^VADPT I $G(VAOA(9))'="" D
    159         . ;
    160         . S DIR("A")="Current Employer "_VAOA(9)_" Sponsors this Plan",DIR("B")="No",DIR(0)="Y" W ! D ^DIR W ! Q:'Y  W "...."
    161         . D VARS S IBE=$S(IBWHOS="v":.311,1:.25),IBEMPST=$P($G(^DPT(DFN,IBE)),U,15)
    162         . ;
    163         . S DR="2.015///"_VAOA(9)_";2.02///"_VAOA(1)_";2.03///"_VAOA(2)_";2.04///"_VAOA(3)_";2.05///"_VAOA(4) D ^DIE
    164         . S DR="2.06////"_$P(VAOA(5),U,1)_";2.07////"_$P(VAOA(11),U,1)_";2.08///"_$E(VAOA(8),1,15)_";2.11////"_IBEMPST D ^DIE
    165         Q
     1IBCNSP3 ;ALB/AAS - INSURANCE MANAGEMENT EDIT ; 06-JUL-93
     2 ;;2.0;INTEGRATED BILLING;**28,52,85,251**;21-MAR-94
     3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
     4 ;
     5% G ^IBCNSM4
     6 ;
     7SAVEPT(DFN,DA) ; -- Save the global before editing
     8 K ^TMP($J,"IBCNSPT")
     9 S ^TMP($J,"IBCNSPT",2.312,DFN,+DA,0)=$G(^DPT(DFN,.312,+DA,0))
     10 S ^TMP($J,"IBCNSPT",2.312,DFN,+DA,1)=$G(^DPT(DFN,.312,+DA,1))
     11 S ^TMP($J,"IBCNSPT",2.312,DFN,+DA,2)=$G(^DPT(DFN,.312,+DA,2))
     12 S ^TMP($J,"IBCNSPT",2.312,DFN,+DA,3)=$G(^DPT(DFN,.312,+DA,3))
     13 S ^TMP($J,"IBCNSPT",2.312,DFN,+DA,4)=$G(^DPT(DFN,.312,+DA,4))
     14 Q
     15 ;
     16COMPPT(DFN,DA) ; -- Compare before editing with globals
     17 S IBDIF=0
     18 I $G(^DPT(DFN,.312,+DA,0))'=$G(^TMP($J,"IBCNSPT",2.312,DFN,+DA,0)) S IBDIF=1 G COMPPTQ
     19 I $G(^DPT(DFN,.312,+DA,1))'=$G(^TMP($J,"IBCNSPT",2.312,DFN,+DA,1)) S IBDIF=1 G COMPPTQ
     20 I $G(^DPT(DFN,.312,+DA,2))'=$G(^TMP($J,"IBCNSPT",2.312,DFN,+DA,2)) S IBDIF=1 G COMPPTQ
     21 I $G(^DPT(DFN,.312,+DA,3))'=$G(^TMP($J,"IBCNSPT",2.312,DFN,+DA,3)) S IBDIF=1 G COMPPTQ
     22 I $G(^DPT(DFN,.312,+DA,4))'=$G(^TMP($J,"IBCNSPT",2.312,DFN,+DA,4)) S IBDIF=1 G COMPPTQ
     23 ;
     24COMPPTQ I IBDIF D:'$D(IBCOVP) COVERED^IBCNSM31(DFN,$P($G(^DPT(DFN,.31)),"^",11))
     25 Q
     26 ;
     27UPDATPT(DFN,DA) ; -- enter date and user if editing has taken place
     28 N DR,DIE,DIC
     29 S DIE="^DPT("_DFN_",.312,",DA(1)=DFN
     30 S DR="1.05///NOW;1.06////"_DUZ
     31 D ^DIE
     32 Q
     33 ;
     34EM ; -- Employer for claims update
     35 D FULL^VALM1 W !!
     36 N IBDIF,DA,DR,DIC,DIE
     37 D SAVEPT(DFN,IBCDFN)
     38 D VARS
     39 L +^DPT(DFN,.312,+$P($G(IBPPOL),"^",4)):5 I '$T D LOCKED^IBTRCD1 G EMQ
     40 ;
     41 ;S DR="2.01;S:'$P($G(^DPT(DFN,.312,+$G(DA),2)),U) Y=""@999"";W !!,""*** If ROI applies, make sure current consent is signed! ***"",!;2.015;2.02;2.03;2.04;2.05;2.06;2.07;2.08;2.09;@999"
     42 ;
     43 S DR="2.1" D ^DIE K DIE,DR
     44 ;
     45 I +$P($G(^DPT(DFN,.312,+$G(DA),2)),U,10),$P($G(^DPT(DFN,.312,+$G(DA),2)),U,9)="" D EMPSET(DFN,$G(DA)) ; curr emp
     46 ;
     47 I +$P($G(^DPT(DFN,.312,+$G(DA),2)),U,10) D VARS S DR="2.015;2.11;2.12;2.01;W:+X !!,""*** If ROI applies, make sure current consent is signed! ***"",!!;2.02;2.03;2.04;2.05;2.06;2.07;2.08;@999" D ^DIE K DIE,DR
     48 ;
     49 ;I '$P($G(^DPT(DFN,.312,+$G(DA),2)),U) D VARS S DR="2.015///@;2.02///@;2.03///@;2.04///@;2.05///@;2.06///@;2.07///@;2.08///@" D ^DIE
     50 ;
     51 I '$P($G(^DPT(DFN,.312,+$G(DA),2)),U,10) D VARS S DR="2.01///@;2.015///@;2.02///@;2.03///@;2.04///@;2.05///@;2.06///@;2.07///@;2.08///@;2.11///@;2.12///@" D ^DIE
     52 ;
     53 D COMPPT(DFN,IBCDFN)
     54 I IBDIF D UPDATPT(DFN,IBCDFN),BLD^IBCNSP
     55 L -^DPT(DFN,.312,+$P($G(IBPPOL),"^",4))
     56EMQ S VALMBCK="R" Q
     57 ;
     58AC ; -- Add Comment
     59 D FULL^VALM1 W !!
     60 N IBDIF,DA,DR,DIE,DIC,X,Y
     61 D SAVEPT(DFN,IBCDFN)
     62 W !!,"You may now enter a brief comment about this patient's policy"
     63 D VARS
     64 L +^DPT(DFN,.312,+$P($G(IBPPOL),"^",4)):5 I '$T D LOCKED^IBTRCD1 G ACQ
     65 S DR="1.08" D ^DIE
     66 D COMPPT(DFN,IBCDFN) I IBDIF D UPDATPT(DFN,IBCDFN)
     67 L -^DPT(DFN,.312,+$P($G(IBPPOL),"^",4))
     68 W !!,"You may now enter comments about this Group Plan that pertains to all Patients"
     69 L +^IBA(355.3,+IBCPOL):5 I '$T D LOCKED^IBTRCD1 G ACQ
     70 S DIE="^IBA(355.3,",DA=IBCPOL,DR="11" D ^DIE
     71 D BLD^IBCNSP
     72 L -^IBA(355.3,+IBCPOL)
     73ACQ S VALMBCK="R" Q
     74 ;
     75BLS(X,Y) ; -- blank a section of lines
     76 N I
     77 F I=X:1:Y D BLANK^IBCNSP(.I)
     78 Q
     79 ;
     80VARS ; -- set vars for call to die for .312 node
     81 S DA(1)=DFN,DA=$P(IBPPOL,"^",4)
     82 S DIE="^DPT("_DA(1)_",.312,"
     83 Q
     84 ;
     85SAVE(IBCPOL) ; -- Save the global before editing
     86 K ^TMP($J,"IBCNSP")
     87 S ^TMP($J,"IBCNSP",355.3,+IBCPOL,0)=$G(^IBA(355.3,+IBCPOL,0))
     88 S ^TMP($J,"IBCNSP",355.3,+IBCPOL,1)=$G(^IBA(355.3,+IBCPOL,1))
     89 ;;Daou/EEN - adding BIN and PCN
     90 S ^TMP($J,"IBCNSP",355.3,+IBCPOL,6)=$G(^IBA(355.3,+IBCPOL,6))
     91 Q
     92 ;
     93COMP(IBCPOL) ; -- Compare before editing with globals
     94 S IBDIF=0
     95 I $G(^IBA(355.3,+IBCPOL,0))'=$G(^TMP($J,"IBCNSP",355.3,+IBCPOL,0)) S IBDIF=1 Q
     96 I $G(^IBA(355.3,+IBCPOL,1))'=$G(^TMP($J,"IBCNSP",355.3,+IBCPOL,1)) S IBDIF=1 Q
     97 ;;Daou/EEN - adding BIN and PCN
     98 I $G(^IBA(355.3,+IBCPOL,6))'=$G(^TMP($J,"IBCNSP",355.3,+IBCPOL,6)) S IBDIF=1 Q
     99 Q
     100 ;
     101UPDATE(IBCPOL) ; -- Update last edited by
     102 N DA,DIC,DIE,DR
     103 S DIE="^IBA(355.3,",DA=IBCPOL,DR="1.05///NOW;1.06////"_DUZ
     104 D ^DIE
     105 Q
     106 ;
     107RIDERS ; -- add/edit personal riders
     108 ;
     109 D FULL^VALM1
     110 N IBDIF,DA,DR,DIE,DIC,X,Y,IBCDFN,IBPRD,IBPRY
     111 S IBCDFN=$P(IBPPOL,"^",4)
     112 W ! D DISPR W !
     113 ;
     114R1 S DIC="^IBA(355.7,",DIC(0)="AEQML",DLAYGO=355.7
     115 S DIC("DR")=".02////"_DFN_";.03////"_IBCDFN
     116 S DIC("S")="I $P(^(0),U,2)=DFN,$P(^(0),U,3)=IBCDFN"
     117 I $D(IBPRD) S DIC("B")=IBPRD
     118 D ^DIC K DIC,IBPRD
     119 I +Y<1 G RIDERQ
     120 S IBPRY=+Y
     121 L +^IBA(355.7,IBPRY):5 I '$T D LOCKED^IBTRCD1 G RIDERQ
     122 S DIE="^IBA(355.7,",DA=+Y,DR=".01",DIDEL=355.7
     123 D ^DIE K DA,DR,DIE,DIC,DIDEL
     124 L -^IBA(355.7,IBPRY)
     125 W ! G R1
     126RIDERQ S VALMBCK="R"
     127 Q
     128 ;
     129RD ; -- Add riders/ for multiple policies
     130 D FULL^VALM1
     131 N I,J,IBXX,VALMY
     132 D EN^VALM2($G(XQORNOD(0)))
     133 I $D(VALMY) S IBXX=0 F  S IBXX=$O(VALMY(IBXX)) Q:'IBXX  D
     134 .S IBPPOL=$G(^TMP("IBNSMDX",$J,$O(^TMP("IBNSM",$J,"IDX",IBXX,0))))
     135 .Q:IBPPOL=""
     136 .D RIDERS
     137 .Q
     138 D BLD^IBCNSM
     139 S VALMBCK="R"
     140 Q
     141 ;
     142DISPR ; -- Display riders
     143 N IBPR,I,J
     144 S I=0
     145 I '$G(IBCDFN)!('$G(DFN)) G DISPRQ
     146 W !,"Current Personal Riders: "
     147 F  S I=$O(^IBA(355.7,"APP",DFN,IBCDFN,I)) Q:'I  S J=$O(^(I,0)),IBPR=$G(^IBA(355.7,+J,0)) D
     148 .S IBPRD=$$EXPAND^IBTRE(355.7,.01,+IBPR)
     149 .W !?5,IBPRD
     150 I '$D(IBPRD) W !?5,"None Indicated"
     151DISPRQ Q
     152 ;
     153EMPSET(DFN,IBCPOL) ; insert patient or spouses current employer as ESGHP address if that employer sponsors this plan
     154 N IBWHOS,VAOA,DIR,IBE,IBEMPST,DR,X,Y
     155 I +$G(DFN) S IBWHOS=$P($G(^DPT(DFN,.312,+$G(IBCPOL),0)),U,6) S VAOA("A")=$S(IBWHOS="v":5,IBWHOS="s":6,1:"")
     156 I $G(VAOA("A"))'="" D OAD^VADPT I $G(VAOA(9))'="" D
     157 . ;
     158 . S DIR("A")="Current Employer "_VAOA(9)_" Sponsors this Plan",DIR("B")="No",DIR(0)="Y" W ! D ^DIR W ! Q:'Y  W "...."
     159 . D VARS S IBE=$S(IBWHOS="v":.311,1:.25),IBEMPST=$P($G(^DPT(DFN,IBE)),U,15)
     160 . ;
     161 . S DR="2.015///"_VAOA(9)_";2.02///"_VAOA(1)_";2.03///"_VAOA(2)_";2.04///"_VAOA(3)_";2.05///"_VAOA(4) D ^DIE
     162 . S DR="2.06////"_$P(VAOA(5),U,1)_";2.07////"_$P(VAOA(11),U,1)_";2.08///"_$E(VAOA(8),1,15)_";2.11////"_IBEMPST D ^DIE
     163 Q

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSU.m

    r613 r623  
    1 IBCNSU  ;ALB/AAS - INSURANCE UTILITY ROUTINE ;19-MAY-93
    2         ;;2.0;INTEGRATED BILLING;**28,103,371**; 21-MAR-94;Build 57
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5 AB(IBCPOL,IBYR,IBASK)   ; -- Return entry in Annual Benefits file
    6         ;  Input:  IBCPOL  = pointer to health insurance policy file
    7         ;          IBYR    = fileman internal date, Default = dt
    8         ;          IBASK   = 1 if want to ask okay to add new entry
    9         ;
    10         ; Output:  IBCAB   = pointer to Annual Benefits file if added, else null
    11         ;
    12         N DIR,IBCAB
    13         S IBCAB=""
    14         I $G(IBCPOL)="" G ABQ
    15         I $G(IBYR)="" S IBYR=DT
    16         ;S IBYR=$E(IBYR,1,3)_"0000"
    17         ;
    18         ; -- try to find entry for policy for year
    19         S IBCAB=$O(^IBA(355.4,"APY",IBCPOL,-IBYR,0))
    20         ;
    21         ; -- if no match add new entry
    22         I 'IBCAB D
    23         .I $G(IBASK) S DIR(0)="Y",DIR("A")="Are you adding a new Annual Benefits YEAR",DIR("B")="YES" D ^DIR I $D(DIRUT)!(Y<1) S VALMQUIT="" Q
    24         .S IBCAB=$$ADDB(IBCPOL,IBYR)
    25         .Q
    26 ABQ     Q IBCAB
    27         ;
    28 ADDB(IBCPOL,IBYR)       ; -- add entries to Annual Benefits file
    29         ;  Input:  IBCPOL  = pointer to health insurance policy file
    30         ;          IBYR    = fileman internal date, Default = dt
    31         ;
    32         ; Output:  IBCAB   = pointer to Annual Benefits file if added, else null
    33         ;
    34         N %DT,IBN1,IBCAB,DIC,DIE,DR,DA,DLAYGO,DO,DD
    35         S IBCAB=""
    36         I $G(IBCPOL)="" G ADDBQ
    37         I $G(IBYR)="" S IBYR=DT
    38         K DD,DO,DIC,DR S DIC="^IBA(355.4,",DIC(0)="L",DLAYGO=355.4
    39         ;
    40         ;S X=$E(IBYR,1,3)_"0000"
    41         S X=IBYR D FILE^DICN I +Y<0 G ADDBQ
    42         S (IBCAB,DA)=+Y,DIE="^IBA(355.4,",DR=".02////"_IBCPOL
    43         D ^DIE K DIC,DIE,DA,DR
    44 ADDBQ   Q IBCAB
    45         ;
    46 CHIP(IBCDFND)   ; -- convert node with no hip pointer to one with hip pointer
    47         ;   Input:  IBCDFND  = zeroth node of insurance type multiple
    48         ;                    = ^dpt(dfn,.312,ibcdfn,0)
    49         ;
    50         ;  Output:  IBCPOL   = pointer to policy file
    51         ;
    52         N IBCNS,IBGRP,IBGRNA,IBGRNU
    53         S IBCNS=+IBCDFND,IBGRNA=$P(IBCDFND,"^",15),IBGRNU=$P(IBCDFND,"^",3),IBGRP=0
    54         I IBGRNA'=""!(IBGRNU'="") S IBGRP=1
    55         S IBCPOL=$$HIP(IBCNS,IBGRP,IBGRNA,IBGRNU)
    56 CHIPQ   Q IBCPOL
    57         ;
    58 HIP(IBCNS,IBGRP,IBGRNA,IBGRNU)  ; -- find internal entry number in policy file
    59         ;  Input:  IBCNS  = pointer to ins co file
    60         ;          IBGRP  = 1 if group policy, 0 if not
    61         ;          IBGRNA = group name
    62         ;          IBGRNU = group number
    63         ;
    64         ; Output:  IBCPOL = pointer to policy file
    65         ;
    66         N %DT
    67         S IBCPOL=""
    68         I $G(^DIC(36,+$G(IBCNS),0))="" G HIPQ
    69         S IBGRP=+$G(IBGRP) ; if undefine, is not a group policy
    70         I 'IBGRP S IBCPOL=$$ADDH(IBCNS,IBGRP) G HIPQ
    71         ;
    72         S:$G(IBGRNU)="" IBGRNU="IB ZZZZZ"
    73         I IBGRNU'="IB ZZZZZ" S IBCPOL=$O(^IBA(355.3,"AGNU",IBCNS,IBGRNU,0))
    74         I IBCPOL,$P($G(^IBA(355.3,+IBCPOL,0)),"^",3)=IBGRNA G HIPQ ; match both
    75         ;
    76         S:$G(IBGRNA)="" IBGRNA="IB ZZZZZ"
    77         S IBCPOL=$O(^IBA(355.3,"AGNA",IBCNS,IBGRNA,0))
    78         I IBCPOL,$P($G(^IBA(355.3,+IBCPOL,0)),"^",4)=IBGRNU G HIPQ ; match both
    79         ;
    80         I 'IBCPOL S IBCPOL=$$ADDH(IBCNS,IBGRP) D
    81         .I IBGRNA="",IBGRNU="" Q
    82         .S:IBGRNA="IB ZZZZZ" IBGRNA="" S:IBGRNU="IB ZZZZZ" IBGRNU=""
    83         .S DA=IBCPOL,DIE="^IBA(355.3,",DR=".03////"_$$STRIP(IBGRNA,";")_";.04////"_$$STRIP(IBGRNU,";")
    84         .D ^DIE K DA,DR,DIC,DIE
    85 HIPQ    Q IBCPOL
    86         ;
    87 ADDH(IBCNS,IBGRP,IBGNA,IBGNU)   ; -- add entries to health insurance policy file (355.3)
    88         ;     Input:  IBCNS  = pointer to ins co file
    89         ;             IBGRP  = 1 if group policy, 0 if no
    90         ;
    91         ;    Output:  IBCPOL = pointer to policy file, if added else null
    92         ;
    93         N %DT,IBN1,IBCAB,DIC,DIE,DR,DA,DLAYGO,DO,DD
    94         S IBCPOL=""
    95         I $G(IBCNS)="" G ADDHQ
    96         K DD,DO,DIC,DR S DIC="^IBA(355.3,",DIC(0)="L",DLAYGO=355.3
    97         ;
    98         S X=IBCNS D FILE^DICN I +Y<0 G ADDHQ
    99         S (DA,IBCPOL)=+Y,DIE="^IBA(355.3,",DR=".02////"_+$G(IBGRP)
    100         I IBGRP=0,$G(DFN) S DR=DR_";.1////"_DFN
    101         I $D(IBGNU) S DR=DR_";.04///^S X=IBGNU"
    102         I $D(IBGNA) S DR=DR_";.03///^S X=IBGNA"
    103         D ^DIE K DA,DR,DIE,DIC
    104         I $G(IBCNTP)'="" S IBCNTP=IBCNTP+1
    105 ADDHQ   Q IBCPOL
    106         ;
    107 ODELP(DFN,INS)  ; -- can an insurance policy be deleted
    108         ; -- called by ^dd(2.312,0,"del",.01) and by ibcnsm
    109         ; -- input  dfn: ien of patient in file 2.
    110         ;           ins: ien of ins. co in file 36
    111         ;
    112         ; -- output      1 if no deletion allowed
    113         ;                 0 if deletion allowed
    114         N I,X,Y S X=0
    115         ;
    116         ; -- do not delete if any uncancelled bills
    117         S J=0 F  S J=$O(^DGCR(399,"AE",DFN,INS,J)) Q:'J  I $P(^DGCR(399,J,"S"),"^",17)="" S X=1 Q
    118 ODELPQ  Q X
    119         ;
    120 STRIP(X,X1)     ; -- strip characters from string
    121         ;    input:  x  = string
    122         ;            x1 = character to strip (default is ";"
    123         N I,X2
    124         S X2="" S:$G(X1)="" X1=";"
    125         S X1=$E(X1)
    126         F I=1:1 S X2=X2_$P(X,X1,I) Q:($P(X,X1,I+1,999)'[X1)
    127         Q X2
    128         ;
    129         ;
    130 DELP(DFN,INS,IBC)       ; -- can an insurance policy be deleted
    131         ; -- called by ^dd(2.312,0,"del",.01) and by ibcnsm
    132         ; -- input  dfn: ien of patient in file 2.
    133         ;           ins: ien of ins. co in file 36
    134         ;           ibc: ien of policy in file 2.312 to do a match
    135         ;
    136         ; -- output      1 if no deletion allowed
    137         ;                0 if deletion allowed
    138         ;
    139         N ARR,J,ONEPOL,X
    140         ;
    141         ; - check input
    142         I '$G(DFN)!'$G(INS) S X=1 G DELPQ
    143         ;
    144         ; - see if vet has more than one policy with carrier; set flag
    145         ; - also, if no policy is passed, assume the patient has one policy
    146         I $G(IBC) D
    147         .S J=0  F  S J=$O(^DPT("AB",IBC,DFN,J)) Q:'J  S ARR(J)=$G(^DPT(DFN,.312,J,0))
    148         .S (J,ONEPOL)=0 S J=$O(ARR(J)) I J,'$O(ARR(J)) S ONEPOL=1
    149         E  S ONEPOL=1
    150         ;
    151         ;
    152         ; -- do not delete if any uncancelled bills
    153         S (J,X)=0 F  S J=$O(^DGCR(399,"AE",DFN,INS,J)) Q:'J  D  Q:X
    154         .;
    155         .N ARRP,POL,K,L,M,MP,S,Z
    156         .S Z=$G(^DGCR(399,J,0)),M=$G(^("M")),MP=$G(^("MP")),S=$G(^("S"))
    157         .;
    158         .; - skip cancelled bills
    159         .I $P(S,"^",17)'="" Q
    160         .;
    161         .; - set flag if the patient has just one policy with the company
    162         .I ONEPOL S X=1 Q
    163         .;
    164         .; - if there are no policy pointers in the claim,
    165         .I '$P(M,"^",12),'$P(M,"^",13),'$P(M,"^",14),'$P(MP,"^",2) D  Q
    166         ..;
    167         ..; - find all policies effective on the event date
    168         ..S K=0 F  S K=$O(ARR(K)) Q:'K  S POL=ARR(K) D
    169         ...I $P(POL,"^",8) Q:$P(Z,"^",3)<$P(POL,"^",8)
    170         ...I $P(POL,"^",4) Q:$P(Z,"^",3)>$P(POL,"^",4)
    171         ...S ARRP(K)=""
    172         ..;
    173         ..; - if there are two such policies, trust user judgement and assume
    174         ..; - policy is not related to this claim.
    175         ..S L=$O(ARRP(0)) I L,$O(ARR(L)) Q
    176         ..;
    177         ..; - if there is just one policy, and it is the same as the one
    178         ..; - passed in, do not allow deletion.
    179         ..I L=IBC S X=1
    180         .;
    181         .; - if one of the claim policy pointers is the same as the policy
    182         .; - passed in, do not allow deletion.
    183         .I $P(MP,"^",2)=IBC S X=1 Q
    184         .I $P(M,"^",12)=IBC!($P(M,"^",13)=IBC)!($P(M,"^",14)=IBC) S X=1
    185         ;
    186         ;
    187 DELPQ   Q X
    188         ;
    189 DUPADDRL(DATA,IBCNS,FLD1,FLD2)  ; Insurance address lines can not be duplicated
    190         ; DATA - Value being compared
    191         ; FLD1 - First field to check against
    192         ; FLD2 - Second field to check against (OPTIONAL)
    193         ;
    194         ; Returns 1 if this field is a duplicate of another field.
    195         ;
    196         N Z1,Z2
    197         Q:$G(DATA)="" 0  ; should not happen because this is invoked as an input transform
    198         Q:'$G(IBCNS) 1  ; stop from editing through fileman
    199         S DATA=$$UP^XLFSTR($G(DATA)),DATA=$$TRIM^XLFSTR(DATA)
    200         S Z1=$$GET1^DIQ(36,+$G(IBCNS),+$G(FLD1),"I")
    201         S Z1=$$UP^XLFSTR(Z1),Z1=$$TRIM^XLFSTR(Z1)
    202         S Z2=$$GET1^DIQ(36,+$G(IBCNS),+$G(FLD2),"I")
    203         S Z2=$$UP^XLFSTR(Z2),Z2=$$TRIM^XLFSTR(Z2)
    204         I DATA=Z1 D CLEAN^DILF Q 1
    205         I DATA=Z2 D CLEAN^DILF Q 1
    206         D CLEAN^DILF
    207         Q 0
    208         ;
     1IBCNSU ;ALB/AAS - INSURANCE UTILITY ROUTINE ; 19-MAY-93
     2 ;;2.0;INTEGRATED BILLING;**28,103**; 21-MAR-94
     3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
     4 ;
     5AB(IBCPOL,IBYR,IBASK) ; -- Return entry in Annual Benefits file
     6 ;  Input:  IBCPOL  = pointer to health insurance policy file
     7 ;          IBYR    = fileman internal date, Default = dt
     8 ;          IBASK   = 1 if want to ask okay to add new entry
     9 ;
     10 ; Output:  IBCAB   = pointer to Annual Benefits file if added, else null
     11 ;
     12 N DIR,IBCAB
     13 S IBCAB=""
     14 I $G(IBCPOL)="" G ABQ
     15 I $G(IBYR)="" S IBYR=DT
     16 ;S IBYR=$E(IBYR,1,3)_"0000"
     17 ;
     18 ; -- try to find entry for policy for year
     19 S IBCAB=$O(^IBA(355.4,"APY",IBCPOL,-IBYR,0))
     20 ;
     21 ; -- if no match add new entry
     22 I 'IBCAB D
     23 .I $G(IBASK) S DIR(0)="Y",DIR("A")="Are you adding a new Annual Benefits YEAR",DIR("B")="YES" D ^DIR I $D(DIRUT)!(Y<1) S VALMQUIT="" Q
     24 .S IBCAB=$$ADDB(IBCPOL,IBYR)
     25 .Q
     26ABQ Q IBCAB
     27 ;
     28ADDB(IBCPOL,IBYR) ; -- add entries to Annual Benefits file
     29 ;  Input:  IBCPOL  = pointer to health insurance policy file
     30 ;          IBYR    = fileman internal date, Default = dt
     31 ;
     32 ; Output:  IBCAB   = pointer to Annual Benefits file if added, else null
     33 ;
     34 N %DT,IBN1,IBCAB,DIC,DIE,DR,DA,DLAYGO,DO,DD
     35 S IBCAB=""
     36 I $G(IBCPOL)="" G ADDBQ
     37 I $G(IBYR)="" S IBYR=DT
     38 K DD,DO,DIC,DR S DIC="^IBA(355.4,",DIC(0)="L",DLAYGO=355.4
     39 ;
     40 ;S X=$E(IBYR,1,3)_"0000"
     41 S X=IBYR D FILE^DICN I +Y<0 G ADDBQ
     42 S (IBCAB,DA)=+Y,DIE="^IBA(355.4,",DR=".02////"_IBCPOL
     43 D ^DIE K DIC,DIE,DA,DR
     44ADDBQ Q IBCAB
     45 ;
     46CHIP(IBCDFND) ; -- convert node with no hip pointer to one with hip pointer
     47 ;   Input:  IBCDFND  = zeroth node of insurance type multiple
     48 ;                    = ^dpt(dfn,.312,ibcdfn,0)
     49 ;
     50 ;  Output:  IBCPOL   = pointer to policy file
     51 ;
     52 N IBCNS,IBGRP,IBGRNA,IBGRNU
     53 S IBCNS=+IBCDFND,IBGRNA=$P(IBCDFND,"^",15),IBGRNU=$P(IBCDFND,"^",3),IBGRP=0
     54 I IBGRNA'=""!(IBGRNU'="") S IBGRP=1
     55 S IBCPOL=$$HIP(IBCNS,IBGRP,IBGRNA,IBGRNU)
     56CHIPQ Q IBCPOL
     57 ;
     58HIP(IBCNS,IBGRP,IBGRNA,IBGRNU) ; -- find internal entry number in policy file
     59 ;  Input:  IBCNS  = pointer to ins co file
     60 ;          IBGRP  = 1 if group policy, 0 if not
     61 ;          IBGRNA = group name
     62 ;          IBGRNU = group number
     63 ;
     64 ; Output:  IBCPOL = pointer to policy file
     65 ;
     66 N %DT
     67 S IBCPOL=""
     68 I $G(^DIC(36,+$G(IBCNS),0))="" G HIPQ
     69 S IBGRP=+$G(IBGRP) ; if undefine, is not a group policy
     70 I 'IBGRP S IBCPOL=$$ADDH(IBCNS,IBGRP) G HIPQ
     71 ;
     72 S:$G(IBGRNU)="" IBGRNU="IB ZZZZZ"
     73 I IBGRNU'="IB ZZZZZ" S IBCPOL=$O(^IBA(355.3,"AGNU",IBCNS,IBGRNU,0))
     74 I IBCPOL,$P($G(^IBA(355.3,+IBCPOL,0)),"^",3)=IBGRNA G HIPQ ; match both
     75 ;
     76 S:$G(IBGRNA)="" IBGRNA="IB ZZZZZ"
     77 S IBCPOL=$O(^IBA(355.3,"AGNA",IBCNS,IBGRNA,0))
     78 I IBCPOL,$P($G(^IBA(355.3,+IBCPOL,0)),"^",4)=IBGRNU G HIPQ ; match both
     79 ;
     80 I 'IBCPOL S IBCPOL=$$ADDH(IBCNS,IBGRP) D
     81 .I IBGRNA="",IBGRNU="" Q
     82 .S:IBGRNA="IB ZZZZZ" IBGRNA="" S:IBGRNU="IB ZZZZZ" IBGRNU=""
     83 .S DA=IBCPOL,DIE="^IBA(355.3,",DR=".03////"_$$STRIP(IBGRNA,";")_";.04////"_$$STRIP(IBGRNU,";")
     84 .D ^DIE K DA,DR,DIC,DIE
     85HIPQ Q IBCPOL
     86 ;
     87ADDH(IBCNS,IBGRP,IBGNA,IBGNU) ; -- add entries to health insurance policy file (355.3)
     88 ;     Input:  IBCNS  = pointer to ins co file
     89 ;             IBGRP  = 1 if group policy, 0 if no
     90 ;
     91 ;    Output:  IBCPOL = pointer to policy file, if added else null
     92 ;
     93 N %DT,IBN1,IBCAB,DIC,DIE,DR,DA,DLAYGO,DO,DD
     94 S IBCPOL=""
     95 I $G(IBCNS)="" G ADDHQ
     96 K DD,DO,DIC,DR S DIC="^IBA(355.3,",DIC(0)="L",DLAYGO=355.3
     97 ;
     98 S X=IBCNS D FILE^DICN I +Y<0 G ADDHQ
     99 S (DA,IBCPOL)=+Y,DIE="^IBA(355.3,",DR=".02////"_+$G(IBGRP)
     100 I IBGRP=0,$G(DFN) S DR=DR_";.1////"_DFN
     101 I $D(IBGNU) S DR=DR_";.04///^S X=IBGNU"
     102 I $D(IBGNA) S DR=DR_";.03///^S X=IBGNA"
     103 D ^DIE K DA,DR,DIE,DIC
     104 I $G(IBCNTP)'="" S IBCNTP=IBCNTP+1
     105ADDHQ Q IBCPOL
     106 ;
     107ODELP(DFN,INS) ; -- can an insurance policy be deleted
     108 ; -- called by ^dd(2.312,0,"del",.01) and by ibcnsm
     109 ; -- input  dfn: ien of patient in file 2.
     110 ;           ins: ien of ins. co in file 36
     111 ;
     112 ; -- output      1 if no deletion allowed
     113 ;                 0 if deletion allowed
     114 N I,X,Y S X=0
     115 ;
     116 ; -- do not delete if any uncancelled bills
     117 S J=0 F  S J=$O(^DGCR(399,"AE",DFN,INS,J)) Q:'J  I $P(^DGCR(399,J,"S"),"^",17)="" S X=1 Q
     118ODELPQ Q X
     119 ;
     120STRIP(X,X1) ; -- strip characters from string
     121 ;    input:  x  = string
     122 ;            x1 = character to strip (default is ";"
     123 N I,X2
     124 S X2="" S:$G(X1)="" X1=";"
     125 S X1=$E(X1)
     126 F I=1:1 S X2=X2_$P(X,X1,I) Q:($P(X,X1,I+1,999)'[X1)
     127 Q X2
     128 ;
     129 ;
     130DELP(DFN,INS,IBC) ; -- can an insurance policy be deleted
     131 ; -- called by ^dd(2.312,0,"del",.01) and by ibcnsm
     132 ; -- input  dfn: ien of patient in file 2.
     133 ;           ins: ien of ins. co in file 36
     134 ;           ibc: ien of policy in file 2.312 to do a match
     135 ;
     136 ; -- output      1 if no deletion allowed
     137 ;                0 if deletion allowed
     138 ;
     139 N ARR,J,ONEPOL,X
     140 ;
     141 ; - check input
     142 I '$G(DFN)!'$G(INS) S X=1 G DELPQ
     143 ;
     144 ; - see if vet has more than one policy with carrier; set flag
     145 ; - also, if no policy is passed, assume the patient has one policy
     146 I $G(IBC) D
     147 .S J=0  F  S J=$O(^DPT("AB",IBC,DFN,J)) Q:'J  S ARR(J)=$G(^DPT(DFN,.312,J,0))
     148 .S (J,ONEPOL)=0 S J=$O(ARR(J)) I J,'$O(ARR(J)) S ONEPOL=1
     149 E  S ONEPOL=1
     150 ;
     151 ;
     152 ; -- do not delete if any uncancelled bills
     153 S (J,X)=0 F  S J=$O(^DGCR(399,"AE",DFN,INS,J)) Q:'J  D  Q:X
     154 .;
     155 .N ARRP,POL,K,L,M,MP,S,Z
     156 .S Z=$G(^DGCR(399,J,0)),M=$G(^("M")),MP=$G(^("MP")),S=$G(^("S"))
     157 .;
     158 .; - skip cancelled bills
     159 .I $P(S,"^",17)'="" Q
     160 .;
     161 .; - set flag if the patient has just one policy with the company
     162 .I ONEPOL S X=1 Q
     163 .;
     164 .; - if there are no policy pointers in the claim,
     165 .I '$P(M,"^",12),'$P(M,"^",13),'$P(M,"^",14),'$P(MP,"^",2) D  Q
     166 ..;
     167 ..; - find all policies effective on the event date
     168 ..S K=0 F  S K=$O(ARR(K)) Q:'K  S POL=ARR(K) D
     169 ...I $P(POL,"^",8) Q:$P(Z,"^",3)<$P(POL,"^",8)
     170 ...I $P(POL,"^",4) Q:$P(Z,"^",3)>$P(POL,"^",4)
     171 ...S ARRP(K)=""
     172 ..;
     173 ..; - if there are two such policies, trust user judgement and assume
     174 ..; - policy is not related to this claim.
     175 ..S L=$O(ARRP(0)) I L,$O(ARR(L)) Q
     176 ..;
     177 ..; - if there is just one policy, and it is the same as the one
     178 ..; - passed in, do not allow deletion.
     179 ..I L=IBC S X=1
     180 .;
     181 .; - if one of the claim policy pointers is the same as the policy
     182 .; - passed in, do not allow deletion.
     183 .I $P(MP,"^",2)=IBC S X=1 Q
     184 .I $P(M,"^",12)=IBC!($P(M,"^",13)=IBC)!($P(M,"^",14)=IBC) S X=1
     185 ;
     186 ;
     187DELPQ Q X

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSU1.m

    r613 r623  
    1 IBCNSU1 ;ALB/AAS - INSURANCE UTILITY ROUTINE ;19-MAY-93
    2         ;;2.0;INTEGRATED BILLING;**103,133,244,371**;21-MAR-94;Build 57
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5 RCHK(X) ; -- Input transform for different revenue codes in file 36
    6         ;    Returns 1 if passes, 0 if not pass input transform
    7         ;
    8         N I,Y,RC,NO S Y=0
    9         I $G(X)="" G RCHKQ
    10         F I=1:1 S RC=$P(X,",",I) Q:RC=""  I $S(RC?3N:0,RC?5N:0,1:1) S NO=1 Q
    11         I '$G(NO) S Y=1
    12 RCHKQ   Q Y
    13         ;
    14 BU(DFN,IBCPOL,IBYR,IBCDFN,IBASK)        ; -- Return entry in Benefits Used file
    15         ;     Input:  IBCDFN  = pointer to patient file policy (2.312)
    16         ;             DFN     = patient pointer       
    17         ;             IBCPOL  = pointer to health insurance policy file
    18         ;             IBYR    = fileman internal date, year will be calendar
    19         ;                       year of the internal date, Default = dt
    20         ;             IBASK   = 1 if want to ask okay to add new entry
    21         ;
    22         ;    Output:  IBCBU   = pointer to Benefits Used file if added,
    23         ;                       else null
    24         ;
    25         N DIR,IBCBU
    26         S IBCBU=""
    27         I $G(IBCPOL)="" G BUQ
    28         I $G(IBYR)="" S IBYR=DT
    29         ;
    30         ;if no match display message
    31         I '$O(^IBA(355.4,"APY",IBCPOL,-IBYR,0)) W !!,"You cannot add a new Benefits Used BENEFIT YEAR",!! G BUQ
    32         ;
    33         ; -- try to find entry for policy for year
    34         S IBCBU=$O(^IBA(355.5,"APPY",DFN,IBCPOL,-IBYR,IBCDFN,0))
    35         ;
    36         ; -- if no match add new entry
    37         I 'IBCBU D
    38         .I $G(IBASK) S DIR(0)="Y",DIR("A")="Are you adding a new Benefits Used YEAR",DIR("B")="YES" D ^DIR I $D(DIRUT)!(Y<1) S VALMQUIT="" Q
    39         .S IBCBU=$$ADDBU(DFN,IBCPOL,IBYR,IBCDFN)
    40         .Q
    41         ;
    42 BUQ     Q IBCBU
    43         ;
    44 ADDBU(DFN,IBCPOL,IBYR,IBCDFN)   ; -- add entries to Benefits Used file
    45         ;     Input:  DFN     = pointer to patient file
    46         ;             IBCDFN  = point to patient policy (2.312)
    47         ;             IBCPOL  = pointer to health insurance policy file
    48         ;             IBYR    = fileman internal date, year will be calendar
    49         ;                       year of the internal date, Default = dt
    50         ;
    51         ;    Output:  IBCBU   = pointer to Benefits Used file if added,
    52         ;                       else null
    53         ;
    54         N %DT,IBN1,IBCBU,DIC,DIE,DR,DA,DLAYGO,DO,DD
    55         S IBCBU=""
    56         I $G(IBCDFN)="" G ADDBUQ
    57         I $G(IBCPOL)="" G ADDBUQ
    58         I $G(IBYR)="" S IBYR=DT
    59         K DD,DO,DIC,DR S DIC="^IBA(355.5,",DIC(0)="L",DLAYGO=355.5
    60         ;
    61         ;S IBYR=$E(IBYR,1,3)_"0000"
    62         S X=IBCPOL D FILE^DICN I +Y<0 G ADDBUQ
    63         S (IBCBU,DA)=+Y,DIE="^IBA(355.5,",DR=".02////"_DFN_";.03////"_IBYR_";.17////"_IBCDFN_";1.01///NOW;1.02////"_DUZ
    64         D ^DIE K DIC,DIE,DA,DR
    65 ADDBUQ  Q IBCBU
    66         ;
    67 VET()   ; -- Input Transform for sub-file 2.312, Name of Insured (#17)
    68         ;    Quit 1 to stuff Patient Name
    69         ;    Quit 0 to not stuff and allow editing
    70         ;
    71         N IBY,IB0 S IBY=0
    72         G VETQ    ; IB*2*371 - Allow edits to the patient name in all cases
    73         S IB0=$G(^DPT(+$G(DA(1)),.312,+$G(DA),0))
    74         I $P(IB0,"^",6)'="v" G VETQ
    75         I +IB0'=+$$GETWNR^IBCNSMM1 S IBY=1 G VETQ
    76         I '$D(X),$P(IB0,"^",17)="" S IBY=1
    77 VETQ    Q IBY
    78         ;
    79         ;
    80 SUBID   ; -- Input Transform for sub-file #2.312, Subscriber ID (#1)
    81         N NODE,L,R,CHAR,X1
    82         S CHAR="~`!@#$%^&*()_-+={}[]|\/?.,<>;:' """
    83         S NODE=^DPT(DA(1),.312,DA,0)
    84         ;
    85         ; - if the policy is a Medicare policy, make sure the subscriber ID
    86         ;   is a valid HICN number
    87         I $P(NODE,U)=+$$GETWNR^IBCNSMM1 S X=$TR(X,"-","") I '$$VALHIC^IBCNSMM(X) D HLP^IBCNSM32 K X Q
    88         ;
    89         S R=$P(NODE,U,16)
    90         S L=$TR($P(^DPT(DA(1),0),U,9),CHAR,"")
    91         S R=$S(R="01":1,R="":1,1:0)
    92         ;
    93         ; - if subscriber ID is the SSN of patient, remove all extraneous
    94         ;   characters
    95         S X1=$TR(X,CHAR,"") I X1?9N,X1=L S X=X1
    96         ;
    97         K:$L(X)>20!($L(X)<3) X
    98         Q
    99         ;
    100         ;
    101 HICN(DFN)       ; -- return Patient's Medicare HIC number
    102         ;    Return HICN of Medicare WNR Part A or Part B
    103         ;    Return -1 if none exits
    104         ;
    105         N IBWNR,IBX,IBY,IB0
    106         S IBWNR=$$GETWNR^IBCNSMM1,IBY=""
    107         I '$O(^DPT(DFN,.312,"B",+IBWNR,0)) S IBY=-1 G HICNQ
    108         S IBX=0 F  S IBX=$O(^DPT(DFN,.312,"B",+IBWNR,IBX)) Q:('IBX)!(IBY]"")  D
    109         .S IB0=$G(^DPT(DFN,.312,IBX,0))
    110         .I $P(IB0,U,18)'=$P(IBWNR,U,3),$P(IB0,U,18)'=$P(IBWNR,U,5) Q
    111         .; 8/18/2003 - Added translation code to remove hyphens if they exist.
    112         .I $P(IB0,U,2)]"" S IBY=$TR($P(IB0,U,2),"- ","")
    113         S:IBY="" IBY=-1
    114 HICNQ   Q IBY
    115         ;
    116 CHKQUAL(DFN,IEN,QUAL,PC1,PC2)   ; check for duplicate qualifiers for patient
    117         ; and subscriber secondary ID's.  All parameters required.
    118         ;
    119         ;   DFN - internal patient#
    120         ;   IEN - ien of 2.312 subfile
    121         ;  QUAL - passed in response of the user (this is what is being
    122         ;         checked to see if it is valid)
    123         ;   PC1 - this is the piece# for one of the other qualifiers
    124         ;   PC2 - this is the piece# for one of the other qualifiers
    125         ;
    126         ; Function returns 1 if the entered qualifier is OK.
    127         ; Function returns 0 if the entered qualifier is not OK.  It is either
    128         ;                    a duplicate or is otherwise invalid.
    129         ;
    130         NEW OK,DATA,INS
    131         S OK=1
    132         I $G(QUAL)="" G CHKQUALX
    133         S DATA=$G(^DPT(+$G(DFN),.312,+$G(IEN),5))
    134         I $G(QUAL)=$P(DATA,U,+$G(PC1)) D CQ1 G CHKQUALX   ; duplicate
    135         I $G(QUAL)=$P(DATA,U,+$G(PC2)) D CQ1 G CHKQUALX   ; duplicate
    136         ;
    137         ; prevent the SSN qualifier when Medicare is the payer
    138         S INS=+$G(^DPT(+$G(DFN),.312,+$G(IEN),0))
    139         I $G(QUAL)="SY",$$MCRWNR^IBEFUNC(INS) D CQ2 G CHKQUALX
    140         ;
    141 CHKQUALX        ;
    142         Q OK
    143         ;
    144 CQ1     ; specific error message#1
    145         S OK=0
    146         D EN^DDIOL("You cannot use the same qualifier more than once.",,"!!")
    147         D EN^DDIOL("",,"!!?5")
    148         Q
    149         ;
    150 CQ2     ; specific error message#2
    151         S OK=0
    152         D EN^DDIOL("You cannot use qualifier 'SY' for Medicare.",,"!!")
    153         D EN^DDIOL("",,"!!?5")
    154         Q
    155         ;
     1IBCNSU1 ;ALB/AAS - INSURANCE UTILITY ROUTINE ; 19-MAY-93
     2 ;;2.0;INTEGRATED BILLING;**103,133,244**;21-MAR-94
     3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
     4 ;
     5RCHK(X) ; -- Input transform for different revenue codes in file 36
     6 ;    Returns 1 if passes, 0 if not pass input transform
     7 ;
     8 N I,Y,RC,NO S Y=0
     9 I $G(X)="" G RCHKQ
     10 F I=1:1 S RC=$P(X,",",I) Q:RC=""  I $S(RC?3N:0,RC?5N:0,1:1) S NO=1 Q
     11 I '$G(NO) S Y=1
     12RCHKQ Q Y
     13 ;
     14BU(DFN,IBCPOL,IBYR,IBCDFN,IBASK) ; -- Return entry in Benefits Used file
     15 ;     Input:  IBCDFN  = pointer to patient file policy (2.312)
     16 ;             DFN     = patient pointer       
     17 ;             IBCPOL  = pointer to health insurance policy file
     18 ;             IBYR    = fileman internal date, year will be calendar
     19 ;                       year of the internal date, Default = dt
     20 ;             IBASK   = 1 if want to ask okay to add new entry
     21 ;
     22 ;    Output:  IBCBU   = pointer to Benefits Used file if added,
     23 ;                       else null
     24 ;
     25 N DIR,IBCBU
     26 S IBCBU=""
     27 I $G(IBCPOL)="" G BUQ
     28 I $G(IBYR)="" S IBYR=DT
     29 ;
     30 ;if no match display message
     31 I '$O(^IBA(355.4,"APY",IBCPOL,-IBYR,0)) W !!,"You cannot add a new Benefits Used BENEFIT YEAR",!! G BUQ
     32 ;
     33 ; -- try to find entry for policy for year
     34 S IBCBU=$O(^IBA(355.5,"APPY",DFN,IBCPOL,-IBYR,IBCDFN,0))
     35 ;
     36 ; -- if no match add new entry
     37 I 'IBCBU D
     38 .I $G(IBASK) S DIR(0)="Y",DIR("A")="Are you adding a new Benefits Used YEAR",DIR("B")="YES" D ^DIR I $D(DIRUT)!(Y<1) S VALMQUIT="" Q
     39 .S IBCBU=$$ADDBU(DFN,IBCPOL,IBYR,IBCDFN)
     40 .Q
     41 ;
     42BUQ Q IBCBU
     43 ;
     44ADDBU(DFN,IBCPOL,IBYR,IBCDFN) ; -- add entries to Benefits Used file
     45 ;     Input:  DFN     = pointer to patient file
     46 ;             IBCDFN  = point to patient policy (2.312)
     47 ;             IBCPOL  = pointer to health insurance policy file
     48 ;             IBYR    = fileman internal date, year will be calendar
     49 ;                       year of the internal date, Default = dt
     50 ;
     51 ;    Output:  IBCBU   = pointer to Benefits Used file if added,
     52 ;                       else null
     53 ;
     54 N %DT,IBN1,IBCBU,DIC,DIE,DR,DA,DLAYGO,DO,DD
     55 S IBCBU=""
     56 I $G(IBCDFN)="" G ADDBUQ
     57 I $G(IBCPOL)="" G ADDBUQ
     58 I $G(IBYR)="" S IBYR=DT
     59 K DD,DO,DIC,DR S DIC="^IBA(355.5,",DIC(0)="L",DLAYGO=355.5
     60 ;
     61 ;S IBYR=$E(IBYR,1,3)_"0000"
     62 S X=IBCPOL D FILE^DICN I +Y<0 G ADDBUQ
     63 S (IBCBU,DA)=+Y,DIE="^IBA(355.5,",DR=".02////"_DFN_";.03////"_IBYR_";.17////"_IBCDFN_";1.01///NOW;1.02////"_DUZ
     64 D ^DIE K DIC,DIE,DA,DR
     65ADDBUQ Q IBCBU
     66 ;
     67VET() ; -- Input Transform for sub-file 2.312, Name of Insured (#17)
     68 ;    Quit 1 to stuff Patient Name
     69 ;    Quit 0 to not stuff and allow editing
     70 ;
     71 N IBY,IB0 S IBY=0
     72 S IB0=$G(^DPT(+$G(DA(1)),.312,+$G(DA),0))
     73 I $P(IB0,"^",6)'="v" G VETQ
     74 I +IB0'=+$$GETWNR^IBCNSMM1 S IBY=1 G VETQ
     75 I '$D(X),$P(IB0,"^",17)="" S IBY=1
     76VETQ Q IBY
     77 ;
     78 ;
     79SUBID ; -- Input Transform for sub-file #2.312, Subscriber ID (#1)
     80 N NODE,L,R,CHAR,X1
     81 S CHAR="~`!@#$%^&*()_-+={}[]|\/?.,<>;:' """
     82 S NODE=^DPT(DA(1),.312,DA,0)
     83 ;
     84 ; - if the policy is a Medicare policy, make sure the subscriber ID
     85 ;   is a valid HICN number
     86 I $P(NODE,U)=+$$GETWNR^IBCNSMM1 S X=$TR(X,"-","") I '$$VALHIC^IBCNSMM(X) D HLP^IBCNSM32 K X Q
     87 ;
     88 S R=$P(NODE,U,16)
     89 S L=$TR($P(^DPT(DA(1),0),U,9),CHAR,"")
     90 S R=$S(R="01":1,R="":1,1:0)
     91 ;
     92 ; - if subscriber ID is the SSN of patient, remove all extraneous
     93 ;   characters
     94 S X1=$TR(X,CHAR,"") I X1?9N,X1=L S X=X1
     95 ;
     96 ; - if "SS" is entered, and the policy belongs to the patient,
     97 ;   convert that string to the patient's SSN
     98 I R=1,X="SS" W "  ",L S X=L
     99 ;
     100 K:$L(X)>20!($L(X)<3) X
     101 Q
     102 ;
     103 ;
     104HICN(DFN) ; -- return Patient's Medicare HIC number
     105 ;    Return HICN of Medicare WNR Part A or Part B
     106 ;    Return -1 if none exits
     107 ;
     108 N IBWNR,IBX,IBY,IB0
     109 S IBWNR=$$GETWNR^IBCNSMM1,IBY=""
     110 I '$O(^DPT(DFN,.312,"B",+IBWNR,0)) S IBY=-1 G HICNQ
     111 S IBX=0 F  S IBX=$O(^DPT(DFN,.312,"B",+IBWNR,IBX)) Q:('IBX)!(IBY]"")  D
     112 .S IB0=$G(^DPT(DFN,.312,IBX,0))
     113 .I $P(IB0,U,18)'=$P(IBWNR,U,3),$P(IB0,U,18)'=$P(IBWNR,U,5) Q
     114 .; 8/18/2003 - Added translation code to remove hyphens if they exist.
     115 .I $P(IB0,U,2)]"" S IBY=$TR($P(IB0,U,2),"- ","")
     116 S:IBY="" IBY=-1
     117HICNQ Q IBY

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRBC.m

    r613 r623  
    1 IBCRBC  ;ALB/ARH - RATES: BILL CALCULATION OF CHARGES ; 22-MAY-1996
    2         ;;2.0;INTEGRATED BILLING;**52,80,106,51,137,245,370**;21-MAR-94;Build 5
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5         ; Variable DGPTUPDT may be defined on entry/exit for inpt bills so the PTF will only be updated once per session
    6         ; Charges may be filed on the bill and if IBRSARR is passed but does not exist it may be updated
    7         ; otherwise there are no other outputs/results of this call.
    8         ;
    9 BILL(IBIFN,IBRSARR)     ; given a bill number calculate and store all charges
    10         ; if IBRSARR is defined it will be used to create charges rather than the standard set for the bills Rate Type
    11         ;
    12         N IB0,IBU,IBBRT,IBBTYPE,IBCTYPE,DFN,PTF,IBDGPT,IBRS,IBCS,IBBEVNT Q:'$G(IBIFN)
    13         K ^TMP($J,"IBCRCC"),^TMP($J,"IBCRCS")
    14         ;
    15         S IB0=$G(^DGCR(399,+IBIFN,0)) Q:IB0=""  S IBU=$G(^DGCR(399,+IBIFN,"U")) Q:'IBU
    16         S IBBRT=+$P(IB0,U,7),IBBTYPE=$S($$INPAT^IBCEF(IBIFN):1,1:3),IBCTYPE=+$P(IB0,U,27),DFN=$P(IB0,U,2) Q:'DFN
    17         ;
    18         ; if who's responsible is insurer, but bill has no insurer defined quit
    19         I $P(IB0,U,11)="i",'$G(^DGCR(399,+IBIFN,"MP")),'$$MCRWNR^IBEFUNC(+$$CURR^IBCEF2(IBIFN)) Q
    20         ;
    21         ; if inpt bill, PTF Status is Open, not a Fee Basis record and not previously done then Update the PTF record
    22         I IBBTYPE<3,'$D(DGPTUPDT) S PTF=$P(IB0,U,8) Q:'PTF  S IBDGPT=$G(^DGPT(+PTF,0)) Q:IBDGPT=""  D
    23         . I '$P(IBDGPT,U,6),'$P(IBDGPT,U,4) D UPDT^DGPTUTL S DGPTUPDT=""
    24         ;
    25         ;
    26         D DSPDL^IBCRBC3,DELALLRC^IBCRBF(IBIFN) ; delete all existing auto charges on the bill
    27         ;
    28         ; get standard set of all rate schedules and charge sets available for entire date range of the bill
    29         I '$D(IBRSARR) D RT^IBCRU3(IBBRT,IBBTYPE,$P(IBU,U,1,2),.IBRSARR,"",IBCTYPE) I 'IBRSARR G END
    30         ;
    31         ; process charge sets - set all charges for the bill into array
    32         S IBRS=0 F  S IBRS=$O(IBRSARR(IBRS)) Q:'IBRS  D
    33         . S IBCS=0 F  S IBCS=$O(IBRSARR(IBRS,IBCS)) Q:'IBCS  I +IBRSARR(IBRS,IBCS) D
    34         .. S IBBEVNT=+$P($G(^IBE(363.1,+IBCS,0)),U,3) Q:'IBBEVNT  S IBBEVNT=$$EMUTL^IBCRU1(IBBEVNT) Q:IBBEVNT=""
    35         .. ;
    36         .. I IBBEVNT["INPATIENT BEDSECTION STAY" D INPTBS^IBCRBC1(IBIFN,IBRS,IBCS)
    37         .. I IBBEVNT["INPATIENT DRG" D INPTDRG^IBCRBC11(IBIFN,IBRS,IBCS)
    38         .. I IBBEVNT["OUTPATIENT VISIT DATE" D OPTVST^IBCRBC1(IBIFN,IBRS,IBCS)
    39         .. I IBBEVNT["PRESCRIPTION" D RX^IBCRBC1(IBIFN,IBRS,IBCS)
    40         .. I IBBEVNT["PROSTHETICS" D PI^IBCRBC1(IBIFN,IBRS,IBCS)
    41         .. I IBBEVNT["PROCEDURE" D CPT^IBCRBC1(IBIFN,IBRS,IBCS)
    42         ;
    43         I '$D(^TMP($J,"IBCRCC")) G END
    44         ;
    45         D SORTCI^IBCRBC3 I '$D(^TMP($J,"IBCRCS")) G END
    46         ;
    47         D ADDBCHGS^IBCRBC3(IBIFN)
    48         ;
    49         D MAILADD(IBIFN,IBBTYPE)
    50         ;
    51 END     I $D(^TMP("IBCRRX",$J)) D CLEANRX^IBCRBC3(IBIFN)
    52         K ^TMP($J,"IBCRCC"),^TMP($J,"IBCRCS")
    53         Q
    54         ;
    55 MAILADD(IBIFN,BTYPE)    ; update the bill mailing address:  it may be based on the types of charges
    56         ; an outpatient bill may go to either the opt or rx mailing addresses depending on the types of charges
    57         N DA,IB01,IB02
    58         I $G(BTYPE)>2,+$G(IBIFN),$D(^IBA(362.4,"C",+IBIFN)),+$$CHGTYPE^IBCU(+IBIFN)=3 S DA=IBIFN D MAILA^IBCU5 D
    59         . I '$D(ZTQUEUED),'$G(IBAUTO) W !!,"Updating Bill Mailing Address"
    60         Q
    61         ;
    62 BILLITEM(IBIFN,IBITMARR)        ; add selected unassociated item charges to the bill
    63         N IBRS,IBCS,IBBEVNT K ^TMP($J,"IBCRCC"),^TMP($J,"IBCRCS")
    64         ;
    65         S IBRS=0 F  S IBRS=$O(IBITMARR(IBRS)) Q:'IBRS  D
    66         . S IBCS=0 F  S IBCS=$O(IBITMARR(IBRS,IBCS)) Q:'IBCS  D
    67         .. S IBBEVNT=+$P($G(^IBE(363.1,+IBCS,0)),U,3) Q:'IBBEVNT  S IBBEVNT=$$EMUTL^IBCRU1(IBBEVNT) Q:IBBEVNT=""
    68         .. ;
    69         .. I IBBEVNT["UNASSOCIATED" D UNASSOC^IBCRBC11(IBIFN,IBRS,IBCS,.IBITMARR)
    70         ;
    71         I $D(^TMP($J,"IBCRCC")) D SORTCI^IBCRBC3
    72         ;
    73         I $D(^TMP($J,"IBCRCS")) D ADDBCHGS^IBCRBC3(IBIFN)
    74         ;
    75         K ^TMP($J,"IBCRCC"),^TMP($J,"IBCRCS")
    76         Q
    77         ;
    78         ;
    79         ;
    80         ; There are 3 types of charges/items:
    81         ; - ITEM: charge for an individual item:  specific item has one or more charge entries in 363.2
    82         ;   for the charge to be applied to the bill the specific item must be found on the bill
    83         ;
    84         ; - EVENT: charge for an event, not an item:  items are defined in 363.2
    85         ;   all charge items active on a date in the set define the charge for the event
    86         ;   the item does not need to be defined on the bill for the charge to be applied to the bill
    87         ;   the charge set on a date becomes the events charge, so effective date cuts across item and applies to event
    88         ;   all charge items with the same effective date are used to calculate the event charge for that date
    89         ;   each charge item effective date in the set overrides all previous entries in the set regardless of item
    90         ;
    91         ; - VA COST:  charge for an individual item but no entries in 363.2
    92         ;   instead the charge is calculated/obtained when it is needed from an interface with the source package
    93         ;
    94         ;
    95         ; Auto calculation and filing of a bills charges
    96         ;
    97         ; IBCRBC (BILL) - determine if charges can be calculated and which rates (RS/CS) should be used
    98         ;                 then find billable items/events, calculate and store the charges
    99         ;                 called anytime a bills charges need to be updated
    100         ;       
    101         ;                 IBCRBC1 (event) - gather billable items/events for each billable event type
    102         ;                                   then accumulate all charges for the bill for each billable event/item
    103         ;
    104         ;                                   IBCRCGx (event) - pull billable items/events from the bill
    105         ;                                   IBCRBC2 (BITMCHRG) - calculate charges for billable item/event
    106         ;
    107         ;                 IBCRBC3 (SORTCI) - sort accumulated charges into order to store on bill, combine if possible
    108         ;                 IBCRBC3 (ADDBCHRGS) -  store the sorted accumulated charges on the bill
    109         ;
    110         ;
    111         ; The Billable Event of the Charge Set is directly related to the Type of charge assigned
    112         ; to the charges calculated for that Charge Set.  So, Billable Event (363.1,.03) <-> Type (399,42,.1)
    113         ;
    114         ;
    115         ;  ^TMP($J,"IBCRCC")  -  array containing raw charges for a bill and related data, created in IBRCBC2
    116         ;  ^TMP($J,"IBCRCC",X) = 1  charge item ifn
    117         ;                        2  charge set ifn
    118         ;                        3  rate schedule ifn
    119         ;                        4  item ptr (to source)
    120         ;                        5  cpt modifier ptr
    121         ;                        6  revenue code ptr
    122         ;                        7  billable bedsection (bill)
    123         ;                        8  event date (visit or st from or admission)
    124         ;                        9  charge per unit/qty
    125         ;                        10 units/qty (qty of item)
    126         ;                        11 total charge per unit/qty
    127         ;                        12 adjusted total charge per unit/qty
    128         ;                        13 units (# item on bill)
    129         ;                        14 CPT ptr
    130         ;                        15 division ptr
    131         ;                        16 item type (source)
    132         ;                        17 item ptr (to source)
    133         ;                        18 charge component
    134         ;                        19 billable bedsection (for item)
    135         ;                        20 procedure provider
    136         ;                        21 procedures associated clinic
    137         ;                        22 procedures Outpatient Encounter, pointer to #409.68
    138         ;                        23 list of all the procedures modifiers, separated by ','
    139         ;
    140         ;  ^TMP($J,"IBCRCC",X,"CC",x) = comments explaining charge adjustements
    141         ;
    142         ;  ^TMP($J,"IBCRCS")  -  array of charges from IBCRCC in sorted order and with only data needed to save on bill
    143         ;  ^TMP($J,"IBCRCS", BS, RV, X) = 1  revenue code ptr
    144         ;                                 2  bedsection ptr
    145         ;                                 3  charge per units (adjusted total charge)
    146         ;                                 4  units (# item on bill)
    147         ;                                 5  CPT ptr
    148         ;                                 6  division ptr
    149         ;                                 7  item type
    150         ;                                 8  item ptr
    151         ;                                 9  charge component
    152         ;
    153         ;
    154         ;
    155         ; Inpatient Bill Dates use follow rules:
    156         ; - admission date is counted as billable
    157         ; - the discharge date is not billable and is not counted
    158         ;
    159         ; - if admission movement is found in the Patient Movement file then the dates of admission and discharge
    160         ;   will be used as the outside limits of the LOS, even if date range of the bill is longer   (LOS^IBCU64)
    161         ;
    162         ; - a day is counted as billable to the bedsection the patient was in at the end of the day (ie. counted
    163         ;   in LOS of next movement after midnight)
    164         ; - if there is a movement on any given date that date is included in the LOS of the bedsection the patient
    165         ;   moved into (same as admission date)
    166         ; - if there is a movement on any given date that date is NOT included in the LOS of the bedsection the
    167         ;   patient moved out of (same as discharge date)
    168         ;
    169         ; - if the time frame of the bill is:
    170         ;   - either interim-first or interim-continuous the last date on the bill should be billed
    171         ;     - if the last date is counted it is added to the LOS of the bedsection the patient was in at the end
    172         ;       of the day
    173         ;   - either NOT interim-first or interim-continuous (final bills) the last date on the bill
    174         ;     should NOT be billed (i.e. this is considered the discharge date)
    175         ;
    176         ; - start with first bedsection after begin date, day is counted in the bedsection the patient is in at midnight
    177         ; - continuous: last bedsection counted is the bedsection the patient is in at midnight of the end date
    178         ; - final:last bedsection counted is the bedsection the patient is in at midnight of the day before the end date
    179         ;
     1IBCRBC ;ALB/ARH - RATES: BILL CALCULATION OF CHARGES ; 22-MAY-1996
     2 ;;2.0;INTEGRATED BILLING;**52,80,106,51,137,245**;21-MAR-94
     3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
     4 ;
     5 ; Variable DGPTUPDT may be defined on entry/exit for inpt bills so the PTF will only be updated once per session
     6 ; Charges may be filed on the bill and if IBRSARR is passed but does not exist it may be updated
     7 ; otherwise there are no other outputs/results of this call.
     8 ;
     9BILL(IBIFN,IBRSARR) ; given a bill number calculate and store all charges
     10 ; if IBRSARR is defined it will be used to create charges rather than the standard set for the bills Rate Type
     11 ;
     12 N IB0,IBU,IBBRT,IBBTYPE,IBCTYPE,DFN,PTF,IBDGPT,IBRS,IBCS,IBBEVNT Q:'$G(IBIFN)
     13 K ^TMP($J,"IBCRCC"),^TMP($J,"IBCRCS")
     14 ;
     15 S IB0=$G(^DGCR(399,+IBIFN,0)) Q:IB0=""  S IBU=$G(^DGCR(399,+IBIFN,"U")) Q:'IBU
     16 S IBBRT=+$P(IB0,U,7),IBBTYPE=$S($$INPAT^IBCEF(IBIFN):1,1:3),IBCTYPE=+$P(IB0,U,27),DFN=$P(IB0,U,2) Q:'DFN
     17 ;
     18 ; if who's responsible is insurer, but bill has no insurer defined quit
     19 I $P(IB0,U,11)="i",'$G(^DGCR(399,+IBIFN,"MP")),'$$MCRWNR^IBEFUNC(+$$CURR^IBCEF2(IBIFN)) Q
     20 ;
     21 ; if inpt bill, PTF Status is Open, not a Fee Basis record and not previously done then Update the PTF record
     22 I IBBTYPE<3,'$D(DGPTUPDT) S PTF=$P(IB0,U,8) Q:'PTF  S IBDGPT=$G(^DGPT(+PTF,0)) Q:IBDGPT=""  D
     23 . I '$P(IBDGPT,U,6),'$P(IBDGPT,U,4) D UPDT^DGPTUTL S DGPTUPDT=""
     24 ;
     25 ;
     26 D DSPDL^IBCRBC3,DELALLRC^IBCRBF(IBIFN) ; delete all existing auto charges on the bill
     27 ;
     28 ; get standard set of all rate schedules and charge sets available for entire date range of the bill
     29 I '$D(IBRSARR) D RT^IBCRU3(IBBRT,IBBTYPE,$P(IBU,U,1,2),.IBRSARR,"",IBCTYPE) I 'IBRSARR G END
     30 ;
     31 ; process charge sets - set all charges for the bill into array
     32 S IBRS=0 F  S IBRS=$O(IBRSARR(IBRS)) Q:'IBRS  D
     33 . S IBCS=0 F  S IBCS=$O(IBRSARR(IBRS,IBCS)) Q:'IBCS  I +IBRSARR(IBRS,IBCS) D
     34 .. S IBBEVNT=+$P($G(^IBE(363.1,+IBCS,0)),U,3) Q:'IBBEVNT  S IBBEVNT=$$EMUTL^IBCRU1(IBBEVNT) Q:IBBEVNT=""
     35 .. ;
     36 .. I IBBEVNT["INPATIENT BEDSECTION STAY" D INPTBS^IBCRBC1(IBIFN,IBRS,IBCS)
     37 .. I IBBEVNT["INPATIENT DRG" D INPTDRG^IBCRBC11(IBIFN,IBRS,IBCS)
     38 .. I IBBEVNT["OUTPATIENT VISIT DATE" D OPTVST^IBCRBC1(IBIFN,IBRS,IBCS)
     39 .. I IBBEVNT["PRESCRIPTION" D RX^IBCRBC1(IBIFN,IBRS,IBCS)
     40 .. I IBBEVNT["PROSTHETICS" D PI^IBCRBC1(IBIFN,IBRS,IBCS)
     41 .. I IBBEVNT["PROCEDURE" D CPT^IBCRBC1(IBIFN,IBRS,IBCS)
     42 ;
     43 I '$D(^TMP($J,"IBCRCC")) G END
     44 ;
     45 D MULTCPT^IBCRBCA1 ; adjust charges for Multiple Surgical Procedure Discount
     46 D PSB^IBCRBCA2 ;     adjust charges for Primary/Secondary Bundling
     47 D MODADJ^IBCRBCA3 ;  adjust charges for Modifier Adjustment
     48 ;
     49 D SORTCI^IBCRBC3 I '$D(^TMP($J,"IBCRCS")) G END
     50 ;
     51 D ADDBCHGS^IBCRBC3(IBIFN)
     52 ;
     53 D MAILADD(IBIFN,IBBTYPE)
     54 ;
     55END I $D(^TMP("IBCRRX",$J)) D CLEANRX^IBCRBC3(IBIFN)
     56 K ^TMP($J,"IBCRCC"),^TMP($J,"IBCRCS")
     57 Q
     58 ;
     59MAILADD(IBIFN,BTYPE) ; update the bill mailing address:  it may be based on the types of charges
     60 ; an outpatient bill may go to either the opt or rx mailing addresses depending on the types of charges
     61 N DA,IB01,IB02
     62 I $G(BTYPE)>2,+$G(IBIFN),$D(^IBA(362.4,"C",+IBIFN)),+$$CHGTYPE^IBCU(+IBIFN)=3 S DA=IBIFN D MAILA^IBCU5 D
     63 . I '$D(ZTQUEUED),'$G(IBAUTO) W !!,"Updating Bill Mailing Address"
     64 Q
     65 ;
     66BILLITEM(IBIFN,IBITMARR) ; add selected unassociated item charges to the bill
     67 N IBRS,IBCS,IBBEVNT K ^TMP($J,"IBCRCC"),^TMP($J,"IBCRCS")
     68 ;
     69 S IBRS=0 F  S IBRS=$O(IBITMARR(IBRS)) Q:'IBRS  D
     70 . S IBCS=0 F  S IBCS=$O(IBITMARR(IBRS,IBCS)) Q:'IBCS  D
     71 .. S IBBEVNT=+$P($G(^IBE(363.1,+IBCS,0)),U,3) Q:'IBBEVNT  S IBBEVNT=$$EMUTL^IBCRU1(IBBEVNT) Q:IBBEVNT=""
     72 .. ;
     73 .. I IBBEVNT["UNASSOCIATED" D UNASSOC^IBCRBC11(IBIFN,IBRS,IBCS,.IBITMARR)
     74 ;
     75 I $D(^TMP($J,"IBCRCC")) D SORTCI^IBCRBC3
     76 ;
     77 I $D(^TMP($J,"IBCRCS")) D ADDBCHGS^IBCRBC3(IBIFN)
     78 ;
     79 K ^TMP($J,"IBCRCC"),^TMP($J,"IBCRCS")
     80 Q
     81 ;
     82 ;
     83 ;
     84 ; There are 3 types of charges/items:
     85 ; - ITEM: charge for an individual item:  specific item has one or more charge entries in 363.2
     86 ;   for the charge to be applied to the bill the specific item must be found on the bill
     87 ;
     88 ; - EVENT: charge for an event, not an item:  items are defined in 363.2
     89 ;   all charge items active on a date in the set define the charge for the event
     90 ;   the item does not need to be defined on the bill for the charge to be applied to the bill
     91 ;   the charge set on a date becomes the events charge, so effective date cuts across item and applies to event
     92 ;   all charge items with the same effective date are used to calculate the event charge for that date
     93 ;   each charge item effective date in the set overrides all previous entries in the set regardless of item
     94 ;
     95 ; - VA COST:  charge for an individual item but no entries in 363.2
     96 ;   instead the charge is calculated/obtained when it is needed from an interface with the source package
     97 ;
     98 ;
     99 ; Auto calculation and filing of a bills charges
     100 ;
     101 ; IBCRBC (BILL) - determine if charges can be calculated and which rates (RS/CS) should be used
     102 ;                 then find billable items/events, calculate and store the charges
     103 ;                 called anytime a bills charges need to be updated
     104 ;       
     105 ;                 IBCRBC1 (event) - gather billable items/events for each billable event type
     106 ;                                   then accumulate all charges for the bill for each billable event/item
     107 ;
     108 ;                                   IBCRCGx (event) - pull billable items/events from the bill
     109 ;                                   IBCRBC2 (BITMCHRG) - calculate charges for billable item/event
     110 ;
     111 ;                 IBCRBC3 (SORTCI) - sort accumulated charges into order to store on bill, combine if possible
     112 ;                 IBCRBC3 (ADDBCHRGS) -  store the sorted accumulated charges on the bill
     113 ;
     114 ;
     115 ; The Billable Event of the Charge Set is directly related to the Type of charge assigned
     116 ; to the charges calculated for that Charge Set.  So, Billable Event (363.1,.03) <-> Type (399,42,.1)
     117 ;
     118 ;
     119 ;  ^TMP($J,"IBCRCC")  -  array containing raw charges for a bill and related data, created in IBRCBC2
     120 ;  ^TMP($J,"IBCRCC",X) = 1  charge item ifn
     121 ;                        2  charge set ifn
     122 ;                        3  rate schedule ifn
     123 ;                        4  item ptr (to source)
     124 ;                        5  cpt modifier ptr
     125 ;                        6  revenue code ptr
     126 ;                        7  billable bedsection (bill)
     127 ;                        8  event date (visit or st from or admission)
     128 ;                        9  charge per unit/qty
     129 ;                        10 units/qty (qty of item)
     130 ;                        11 total charge per unit/qty
     131 ;                        12 adjusted total charge per unit/qty
     132 ;                        13 units (# item on bill)
     133 ;                        14 CPT ptr
     134 ;                        15 division ptr
     135 ;                        16 item type (source)
     136 ;                        17 item ptr (to source)
     137 ;                        18 charge component
     138 ;                        19 billable bedsection (for item)
     139 ;                        20 procedure provider
     140 ;                        21 procedures associated clinic
     141 ;                        22 procedures Outpatient Encounter, pointer to #409.68
     142 ;
     143 ;  ^TMP($J,"IBCRCC",X,"CC",x) = comments explaining charge adjustements
     144 ;
     145 ;  ^TMP($J,"IBCRCS")  -  array of charges from IBCRCC in sorted order and with only data needed to save on bill
     146 ;  ^TMP($J,"IBCRCS", BS, RV, X) = 1  revenue code ptr
     147 ;                                 2  bedsection ptr
     148 ;                                 3  charge per units (adjusted total charge)
     149 ;                                 4  units (# item on bill)
     150 ;                                 5  CPT ptr
     151 ;                                 6  division ptr
     152 ;                                 7  item type
     153 ;                                 8  item ptr
     154 ;                                 9  charge component
     155 ;
     156 ;
     157 ;
     158 ; Inpatient Bill Dates use follow rules:
     159 ; - admission date is counted as billable
     160 ; - the discharge date is not billable and is not counted
     161 ;
     162 ; - if admission movement is found in the Patient Movement file then the dates of admission and discharge
     163 ;   will be used as the outside limits of the LOS, even if date range of the bill is longer   (LOS^IBCU64)
     164 ;
     165 ; - a day is counted as billable to the bedsection the patient was in at the end of the day (ie. counted
     166 ;   in LOS of next movement after midnight)
     167 ; - if there is a movement on any given date that date is included in the LOS of the bedsection the patient
     168 ;   moved into (same as admission date)
     169 ; - if there is a movement on any given date that date is NOT included in the LOS of the bedsection the
     170 ;   patient moved out of (same as discharge date)
     171 ;
     172 ; - if the time frame of the bill is:
     173 ;   - either interim-first or interim-continuous the last date on the bill should be billed
     174 ;     - if the last date is counted it is added to the LOS of the bedsection the patient was in at the end
     175 ;       of the day
     176 ;   - either NOT interim-first or interim-continuous (final bills) the last date on the bill
     177 ;     should NOT be billed (i.e. this is considered the discharge date)
     178 ;
     179 ; - start with first bedsection after begin date, day is counted in the bedsection the patient is in at midnight
     180 ; - continuous: last bedsection counted is the bedsection the patient is in at midnight of the end date
     181 ; - final:last bedsection counted is the bedsection the patient is in at midnight of the day before the end date
     182 ;

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRBC1.m

    r613 r623  
    1 IBCRBC1 ;ALB/ARH - RATES: BILL CALCULATION BILLABLE EVENTS ; 22 MAY 96
    2         ;;2.0;INTEGRATED BILLING;**52,80,106,138,51,148,245,270,370**;21-MAR-94;Build 5
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5         ; For each type of Billable Event, search for items on the bill and calculate the charges
    6         ;  1) search the bill for items of the billable event type
    7         ;  2) determine how the charges should be calculated, based on Billable Item and Charge Method of the Set's Rate
    8         ;  3) calculate charges
    9         ; For per diem Billing Rates, no item pointers are passed since all items have a standard charge
    10         ; The Insurance Company Different Revenue Codes to Use (36,.07) is passed so standard rev codes can be replaced
    11         ; The Charge Type (363.1,.04) is passed so it can be added to the charge on the bill if it is defined for a Set
    12         ; Output:  ^TMP($J,"IBCRCC")= ..., (created in IBCRBC2 based on charge items found here)
    13         ;
    14 INPTBS(IBIFN,RS,CS)     ; Determine charges for INPATIENT BEDSECTION STAY billable events
    15         ; - the billable events are billable bedsections based on the patient movement treating specialties,
    16         ;   these are pulled from the PTF record each time the charges are calculated (INPTPTF^IBCRCG)
    17         ; - each day of billable care is calculated separately in case a rate becomes inactive
    18         ;
    19         N IBX,IBBLITEM,IBCHGMTH,IBEVDT,IBIDRC,IBBDIV,IBITM,IBDIV,IBTYPE,IBCMPNT,IBSAVE I '$G(IBIFN)!'$G(CS) Q
    20         ;
    21         D INPTPTF^IBCRBG(IBIFN,CS)
    22         ;
    23         S IBTYPE=1,IBCMPNT=$P($G(^IBE(363.1,+CS,0)),U,4),IBX=$$CSBR^IBCRU3(CS),IBBLITEM=$P(IBX,U,4),IBCHGMTH=$P(IBX,U,5)
    24         S IBIDRC=+$G(^DGCR(399,+IBIFN,"MP"))
    25         I 'IBIDRC,$$MCRWNR^IBEFUNC($$CURR^IBCEF2(IBIFN)) S IBIDRC=$$CURR^IBCEF2(IBIFN)
    26         S IBIDRC=$G(^DIC(36,+IBIDRC,0)),IBIDRC=$P(IBIDRC,U,7)
    27         ;
    28         S IBBDIV=$P($G(^DGCR(399,+IBIFN,0)),U,22) ; bill's default division
    29         ;
    30         I IBBLITEM=1,IBCHGMTH=1 D  ; inpt/bedsection/per diem
    31         . S IBEVDT="" F  S IBEVDT=$O(^TMP($J,"IBCRC-INDT",IBEVDT)) Q:'IBEVDT  D
    32         .. S IBX=$G(^TMP($J,"IBCRC-INDT",IBEVDT)),IBITM=+$P(IBX,U,2),IBDIV=$P(IBX,U,5)
    33         .. ;
    34         .. I $$CSDV^IBCRU3(CS,IBDIV,IBBDIV)<0 Q  ; check division
    35         .. ;
    36         .. S IBSAVE="1^^"_IBDIV_"^"_IBTYPE_"^^"_IBCMPNT
    37         .. D BITMCHG^IBCRBC2(RS,CS,IBITM,IBEVDT,1,"","",IBIDRC,IBSAVE)
    38         K ^TMP($J,"IBCRC-INDT")
    39         Q
    40         ;
    41 OPTVST(IBIFN,RS,CS)     ; Determine charges for OUTPATIENT VISIT DATE billable events
    42         ; - the billable event is the outpatient visit date(s) on the bill (399,43)
    43         ;
    44         N IBX,IBBLITEM,IBCHGMTH,IBIDRC,IBOPVARR,IBI,IBEVDT,IBTYPE,IBCMPNT,IBSAVE I '$G(IBIFN)!'$G(CS) Q
    45         ;
    46         D OPTVD^IBCRBG1(IBIFN,.IBOPVARR) Q:'IBOPVARR
    47         ;
    48         S IBTYPE=2,IBCMPNT=$P($G(^IBE(363.1,+CS,0)),U,4),IBX=$$CSBR^IBCRU3(CS),IBBLITEM=$P(IBX,U,4),IBCHGMTH=$P(IBX,U,5)
    49         S IBIDRC=+$G(^DGCR(399,+IBIFN,"MP"))
    50         I 'IBIDRC,$$MCRWNR^IBEFUNC($$CURR^IBCEF2(IBIFN)) S IBIDRC=$$CURR^IBCEF2(IBIFN)
    51         S IBIDRC=$G(^DIC(36,+IBIDRC,0)),IBIDRC=$P(IBIDRC,U,7)
    52         ;
    53         I IBBLITEM=1,IBCHGMTH=1 D  ; opt vst/bedsection/per diem
    54         . S IBI="" F  S IBI=$O(IBOPVARR(IBI)) Q:IBI=""  D
    55         .. S IBEVDT=IBOPVARR(IBI)
    56         .. S IBSAVE="1^^^"_IBTYPE_"^^"_IBCMPNT
    57         .. D ALLBEDS^IBCRBC2(RS,CS,IBEVDT,"",IBIDRC,IBSAVE)
    58         Q
    59         ;
    60 RX(IBIFN,RS,CS) ; Determine charges for PRESCRIPTION billable events
    61         ; - the billable event is an rx that has been added to the bill (362.4)
    62         ; - the insurance company Prescription Refill Rev Code (36,.15) is passed to the calculator to be used as
    63         ;   the rev code for all Rx charges, all types, this overrides the rev codes for the set or item
    64         ; - on HCFA 1500, the site parameter Default Rx Refill CPT (350.9,1.3) is added as the CPT to all Rx RC entries
    65         ;
    66         N IBX,IBBLITEM,IBCHGMTH,IBRXCPT,IBIDRC,IBIRC,IBRXARR,IBRX,IBEVDT,IBUNIT,IBITM,IBNDC,IBTYPE,IBCMPNT,IBSAVE
    67         I '$G(IBIFN)!'$G(CS) Q
    68         ;
    69         D SET^IBCSC5A(IBIFN,.IBRXARR) Q:'$P(IBRXARR,U,2)
    70         ;
    71         S IBTYPE=3,IBCMPNT=$P($G(^IBE(363.1,+CS,0)),U,4),IBX=$$CSBR^IBCRU3(CS),IBBLITEM=$P(IBX,U,4),IBCHGMTH=$P(IBX,U,5)
    72         S IBIDRC=+$G(^DGCR(399,+IBIFN,"MP"))
    73         I 'IBIDRC,$$MCRWNR^IBEFUNC($$CURR^IBCEF2(IBIFN)) S IBIDRC=$$CURR^IBCEF2(IBIFN)
    74         S IBIDRC=$G(^DIC(36,+IBIDRC,0)),IBIRC=$P(IBIDRC,U,15),IBIDRC=$P(IBIDRC,U,7)
    75         ;
    76         S IBRXCPT="" I $$FT^IBCU3(IBIFN)=2 S IBRXCPT=$P($G(^IBE(350.9,1,1)),U,30)
    77         ;
    78         I IBBLITEM=1,IBCHGMTH=1 D  ; rx refill/bedsection/per diem
    79         . S IBRX="" F  S IBRX=$O(IBRXARR(IBRX)) Q:IBRX=""  D
    80         .. S IBEVDT=0 F  S IBEVDT=$O(IBRXARR(IBRX,IBEVDT)) Q:'IBEVDT  D
    81         ... ;
    82         ... S IBSAVE="1^"_IBRXCPT_"^^"_IBTYPE_"^"_+IBRXARR(IBRX,IBEVDT)_"^"_IBCMPNT
    83         ... D ALLBEDS^IBCRBC2(RS,CS,IBEVDT,IBIRC,IBIDRC,IBSAVE)
    84         ;
    85         I IBBLITEM=3,IBCHGMTH=3 D  ; ndc/quantity
    86         . S IBRX="" F  S IBRX=$O(IBRXARR(IBRX)) Q:IBRX=""  D
    87         .. S IBEVDT=0 F  S IBEVDT=$O(IBRXARR(IBRX,IBEVDT)) Q:'IBEVDT  D
    88         ... S IBX=IBRXARR(IBRX,IBEVDT),IBITM=+IBX,IBUNIT=$P(IBX,U,4),IBNDC=$P(IBX,U,5) Q:IBNDC=""
    89         ... S IBNDC=$O(^IBA(363.21,"B",IBNDC,0)) Q:'IBNDC
    90         ... S IBSAVE="1^"_IBRXCPT_"^^"_IBTYPE_"^"_IBITM_"^"_IBCMPNT
    91         ... D BITMCHG^IBCRBC2(RS,CS,IBNDC,IBEVDT,IBUNIT,"",IBIRC,IBIDRC,IBSAVE)
    92         ;
    93         I IBCHGMTH=2 D  ; va cost
    94         . S IBRX="" F  S IBRX=$O(IBRXARR(IBRX)) Q:IBRX=""  D
    95         .. S IBEVDT=0 F  S IBEVDT=$O(IBRXARR(IBRX,IBEVDT)) Q:'IBEVDT  D
    96         ... S IBX=IBRXARR(IBRX,IBEVDT),IBITM=+IBX,IBUNIT=$P(IBX,U,4) Q:'IBITM
    97         ... S IBSAVE="1^"_IBRXCPT_"^^"_IBTYPE_"^"_IBITM_"^"_IBCMPNT
    98         ... D BITMCHG^IBCRBC2(RS,CS,IBITM,IBEVDT,IBUNIT,"",IBIRC,IBIDRC,IBSAVE)
    99         ;
    100         Q
    101         ;
    102 CPT(IBIFN,RS,CS)        ; Determine charges for PROCEDURE billable events
    103         ; - the billable event is a CPT procedure from the bill (399,304)
    104         ; - the item to be billed is a CPT, this may include Modifier
    105         ; - for each CPT found on the bill that has a modifier, will first check to see if that CPT-modifier
    106         ;   combination is billable (ie. is defined as a charge item for the Billing Rate, does not have to be active)
    107         ;   if it does not then assumes the charge should be the CPT charge
    108         ; - if the charge set is limited by region then either the CPT's division or if no CPT division then the bill's
    109         ;   Default Division must be contained in the sets region
    110         ; - the billable CPT is added as the CPT of the charge entry, Division is also added if defined for the CPT
    111         ; - the procedures provider may affect the charges due to a provider discount
    112         ; - if an inpatient bill then the bedsection on date of procedure will be used as the default bedsection
    113         ; - different sets of charges apply to SNF and Inpatient care although the bill is defined as inpatient
    114         ; - the Default Rx CPT should not be billed the CPT charge, instead the Rx is charged
    115         ;
    116         N IBX,IBBLITEM,IBCHGMTH,IBBR,IBBDIV,IBIDRC,IBCPTARR,IBCPT,IBCPTFN,IBEVDT,IBMOD,IBDIV,IBTYPE,IBCMPNT
    117         N IBPPRV,IBBS,IBCLIN,IBOE,IBSAVE,IBUNIT,IBCPTRX,IBMODS I '$G(IBIFN)!'$G(CS) Q
    118         ;
    119         D CPT^IBCRBG1(IBIFN,.IBCPTARR) Q:'IBCPTARR
    120         ;
    121         S IBTYPE=4,IBCMPNT=$P($G(^IBE(363.1,+CS,0)),U,4),IBX=$$CSBR^IBCRU3(CS),IBBLITEM=$P(IBX,U,4),IBCHGMTH=$P(IBX,U,5)
    122         S IBIDRC=+$G(^DGCR(399,+IBIFN,"MP"))
    123         I 'IBIDRC,$$MCRWNR^IBEFUNC($$CURR^IBCEF2(IBIFN)) S IBIDRC=$$CURR^IBCEF2(IBIFN)
    124         S IBIDRC=$G(^DIC(36,+IBIDRC,0)),IBIDRC=$P(IBIDRC,U,7)
    125         S IBBR=$P(IBX,U,3) S IBCPTRX="" I $O(^IBA(362.4,"C",IBIFN,0)) S IBCPTRX=+$P($G(^IBE(350.9,1,1)),U,30)
    126         ;
    127         S IBBDIV=$P($G(^DGCR(399,+IBIFN,0)),U,22) ; bill's default division
    128         D INPTPTF^IBCRBG(IBIFN,CS) ; get inpatient bedsections
    129         ;
    130         I IBBLITEM=2 D  ; cpt/count/minutes/miles/hours
    131         . S IBCPT=0 F  S IBCPT=$O(IBCPTARR(IBCPT)) Q:'IBCPT  D
    132         .. S IBCPTFN=0 F  S IBCPTFN=$O(IBCPTARR(IBCPT,IBCPTFN)) Q:'IBCPTFN  D
    133         ... S IBX=IBCPTARR(IBCPT,IBCPTFN),IBEVDT=$P(IBX,U,1),(IBMOD,IBMODS)=$P(IBX,U,2)
    134         ... S IBDIV=$P(IBX,U,3),IBPPRV=$P(IBX,U,4),IBCLIN=$P(IBX,U,5),IBOE=$P(IBX,U,6)
    135         ... ;
    136         ... I '$$CHGOTH^IBCRBC2(IBIFN,RS,IBEVDT) Q
    137         ... I +IBCPTRX,'IBOE,IBCPT=IBCPTRX Q  ; site parameter rx procedure
    138         ... ;
    139         ... S IBUNIT=$$CPTUNITS^IBCRBC2(CS,IBCHGMTH,IBX) Q:'IBUNIT
    140         ... ;
    141         ... S IBBS=$P($G(^TMP($J,"IBCRC-INDT",IBEVDT)),U,2) ; get inpatient bedsection
    142         ... I 'IBBS S IBX=$O(^TMP($J,"IBCRC-INDT",IBEVDT),-1) I +IBX S IBBS=$P($G(^TMP($J,"IBCRC-INDT",IBX)),U,2)
    143         ... ;
    144         ... I '$P($$CPT^ICPTCOD(+IBCPT,+IBEVDT),U,7) Q  ; check is a valid active CPT
    145         ... I $$CSDV^IBCRU3(CS,IBDIV,IBBDIV)<0 Q  ; check division
    146         ... I +IBMOD S IBMOD=$P($$CPTMOD^IBCRCU1(CS,IBCPT,IBMOD,IBEVDT),",",1) ; check CPT-MODs for billable combination
    147         ... ;
    148         ... S IBSAVE="1^"_IBCPT_U_IBDIV_U_IBTYPE_U_IBCPTFN_U_IBCMPNT_U_IBBS_U_IBPPRV_U_IBCLIN_U_IBOE_U_IBMODS
    149         ... D BITMCHG^IBCRBC2(RS,CS,IBCPT,IBEVDT,IBUNIT,IBMOD,"",IBIDRC,IBSAVE)
    150         K ^TMP($J,"IBCRC-INDT")
    151         Q
    152         ;
    153 PI(IBIFN,RS,CS) ; Determine charges for PROSTHETICS billable events
    154         ; - the billable event is a prosthetic item that has been added to the bill (362.5)
    155         ;
    156         N IBX,IBBLITEM,IBCHGMTH,IBPIARR,IBIDRC,IBEVDT,IBPI,IBITM,IBTYPE,IBCMPNT,IBSAVE I '$G(IBIFN)!'$G(CS) Q
    157         ;
    158         D SET^IBCSC5B(IBIFN,.IBPIARR) Q:'$P(IBPIARR,U,2)
    159         ;
    160         S IBTYPE=5,IBCMPNT=$P($G(^IBE(363.1,+CS,0)),U,4),IBX=$$CSBR^IBCRU3(CS),IBBLITEM=$P(IBX,U,4),IBCHGMTH=$P(IBX,U,5)
    161         S IBIDRC=+$G(^DGCR(399,+IBIFN,"MP"))
    162         I 'IBIDRC,$$MCRWNR^IBEFUNC($$CURR^IBCEF2(IBIFN)) S IBIDRC=$$CURR^IBCEF2(IBIFN)
    163         S IBIDRC=$G(^DIC(36,+IBIDRC,0)),IBIDRC=$P(IBIDRC,U,7)
    164         ;
    165         I IBBLITEM=1,IBCHGMTH=1 D  ; pros/bedsection/per diem
    166         . S IBEVDT="" F  S IBEVDT=$O(IBPIARR(IBEVDT)) Q:'IBEVDT  D
    167         .. S IBPI=0 F  S IBPI=$O(IBPIARR(IBEVDT,IBPI)) Q:'IBPI  D
    168         ... S IBSAVE="1^^^"_IBTYPE_"^^"_IBCMPNT
    169         ... D ALLBEDS^IBCRBC2(RS,CS,IBEVDT,"",IBIDRC,IBSAVE)
    170         ;
    171         I IBCHGMTH=2 D  ; va cost
    172         . S IBEVDT="" F  S IBEVDT=$O(IBPIARR(IBEVDT)) Q:'IBEVDT  D
    173         .. S IBPI=0 F  S IBPI=$O(IBPIARR(IBEVDT,IBPI)) Q:'IBPI  D
    174         ... S IBITM=IBPIARR(IBEVDT,IBPI) Q:'IBITM
    175         ... S IBSAVE="1^^^"_IBTYPE_"^"_+IBITM_"^"_IBCMPNT
    176         ... D BITMCHG^IBCRBC2(RS,CS,+IBITM,IBEVDT,1,"","",IBIDRC,IBSAVE)
    177         ;
    178         Q
     1IBCRBC1 ;ALB/ARH - RATES: BILL CALCULATION BILLABLE EVENTS ; 22 MAY 96
     2 ;;2.0;INTEGRATED BILLING;**52,80,106,138,51,148,245,270**;21-MAR-94
     3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
     4 ;
     5 ; For each type of Billable Event, search for items on the bill and calculate the charges
     6 ;  1) search the bill for items of the billable event type
     7 ;  2) determine how the charges should be calculated, based on Billable Item and Charge Method of the Set's Rate
     8 ;  3) calculate charges
     9 ; For per diem Billing Rates, no item pointers are passed since all items have a standard charge
     10 ; The Insurance Company Different Revenue Codes to Use (36,.07) is passed so standard rev codes can be replaced
     11 ; The Charge Type (363.1,.04) is passed so it can be added to the charge on the bill if it is defined for a Set
     12 ; Output:  ^TMP($J,"IBCRCC")= ..., (created in IBCRBC2 based on charge items found here)
     13 ;
     14INPTBS(IBIFN,RS,CS) ; Determine charges for INPATIENT BEDSECTION STAY billable events
     15 ; - the billable events are billable bedsections based on the patient movement treating specialties,
     16 ;   these are pulled from the PTF record each time the charges are calculated (INPTPTF^IBCRCG)
     17 ; - each day of billable care is calculated separately in case a rate becomes inactive
     18 ;
     19 N IBX,IBBLITEM,IBCHGMTH,IBEVDT,IBIDRC,IBBDIV,IBITM,IBDIV,IBTYPE,IBCMPNT,IBSAVE I '$G(IBIFN)!'$G(CS) Q
     20 ;
     21 D INPTPTF^IBCRBG(IBIFN,CS)
     22 ;
     23 S IBTYPE=1,IBCMPNT=$P($G(^IBE(363.1,+CS,0)),U,4),IBX=$$CSBR^IBCRU3(CS),IBBLITEM=$P(IBX,U,4),IBCHGMTH=$P(IBX,U,5)
     24 S IBIDRC=+$G(^DGCR(399,+IBIFN,"MP"))
     25 I 'IBIDRC,$$MCRWNR^IBEFUNC($$CURR^IBCEF2(IBIFN)) S IBIDRC=$$CURR^IBCEF2(IBIFN)
     26 S IBIDRC=$G(^DIC(36,+IBIDRC,0)),IBIDRC=$P(IBIDRC,U,7)
     27 ;
     28 S IBBDIV=$P($G(^DGCR(399,+IBIFN,0)),U,22) ; bill's default division
     29 ;
     30 I IBBLITEM=1,IBCHGMTH=1 D  ; inpt/bedsection/per diem
     31 . S IBEVDT="" F  S IBEVDT=$O(^TMP($J,"IBCRC-INDT",IBEVDT)) Q:'IBEVDT  D
     32 .. S IBX=$G(^TMP($J,"IBCRC-INDT",IBEVDT)),IBITM=+$P(IBX,U,2),IBDIV=$P(IBX,U,5)
     33 .. ;
     34 .. I $$CSDV^IBCRU3(CS,IBDIV,IBBDIV)<0 Q  ; check division
     35 .. ;
     36 .. S IBSAVE="1^^"_IBDIV_"^"_IBTYPE_"^^"_IBCMPNT
     37 .. D BITMCHG^IBCRBC2(RS,CS,IBITM,IBEVDT,1,"","",IBIDRC,IBSAVE)
     38 K ^TMP($J,"IBCRC-INDT")
     39 Q
     40 ;
     41OPTVST(IBIFN,RS,CS) ; Determine charges for OUTPATIENT VISIT DATE billable events
     42 ; - the billable event is the outpatient visit date(s) on the bill (399,43)
     43 ;
     44 N IBX,IBBLITEM,IBCHGMTH,IBIDRC,IBOPVARR,IBI,IBEVDT,IBTYPE,IBCMPNT,IBSAVE I '$G(IBIFN)!'$G(CS) Q
     45 ;
     46 D OPTVD^IBCRBG1(IBIFN,.IBOPVARR) Q:'IBOPVARR
     47 ;
     48 S IBTYPE=2,IBCMPNT=$P($G(^IBE(363.1,+CS,0)),U,4),IBX=$$CSBR^IBCRU3(CS),IBBLITEM=$P(IBX,U,4),IBCHGMTH=$P(IBX,U,5)
     49 S IBIDRC=+$G(^DGCR(399,+IBIFN,"MP"))
     50 I 'IBIDRC,$$MCRWNR^IBEFUNC($$CURR^IBCEF2(IBIFN)) S IBIDRC=$$CURR^IBCEF2(IBIFN)
     51 S IBIDRC=$G(^DIC(36,+IBIDRC,0)),IBIDRC=$P(IBIDRC,U,7)
     52 ;
     53 I IBBLITEM=1,IBCHGMTH=1 D  ; opt vst/bedsection/per diem
     54 . S IBI="" F  S IBI=$O(IBOPVARR(IBI)) Q:IBI=""  D
     55 .. S IBEVDT=IBOPVARR(IBI)
     56 .. S IBSAVE="1^^^"_IBTYPE_"^^"_IBCMPNT
     57 .. D ALLBEDS^IBCRBC2(RS,CS,IBEVDT,"",IBIDRC,IBSAVE)
     58 Q
     59 ;
     60RX(IBIFN,RS,CS) ; Determine charges for PRESCRIPTION billable events
     61 ; - the billable event is an rx that has been added to the bill (362.4)
     62 ; - the insurance company Prescription Refill Rev Code (36,.15) is passed to the calculator to be used as
     63 ;   the rev code for all Rx charges, all types, this overrides the rev codes for the set or item
     64 ; - on HCFA 1500, the site parameter Default Rx Refill CPT (350.9,1.3) is added as the CPT to all Rx RC entries
     65 ;
     66 N IBX,IBBLITEM,IBCHGMTH,IBRXCPT,IBIDRC,IBIRC,IBRXARR,IBRX,IBEVDT,IBUNIT,IBITM,IBNDC,IBTYPE,IBCMPNT,IBSAVE
     67 I '$G(IBIFN)!'$G(CS) Q
     68 ;
     69 D SET^IBCSC5A(IBIFN,.IBRXARR) Q:'$P(IBRXARR,U,2)
     70 ;
     71 S IBTYPE=3,IBCMPNT=$P($G(^IBE(363.1,+CS,0)),U,4),IBX=$$CSBR^IBCRU3(CS),IBBLITEM=$P(IBX,U,4),IBCHGMTH=$P(IBX,U,5)
     72 S IBIDRC=+$G(^DGCR(399,+IBIFN,"MP"))
     73 I 'IBIDRC,$$MCRWNR^IBEFUNC($$CURR^IBCEF2(IBIFN)) S IBIDRC=$$CURR^IBCEF2(IBIFN)
     74 S IBIDRC=$G(^DIC(36,+IBIDRC,0)),IBIRC=$P(IBIDRC,U,15),IBIDRC=$P(IBIDRC,U,7)
     75 ;
     76 S IBRXCPT="" I $$FT^IBCU3(IBIFN)=2 S IBRXCPT=$P($G(^IBE(350.9,1,1)),U,30)
     77 ;
     78 I IBBLITEM=1,IBCHGMTH=1 D  ; rx refill/bedsection/per diem
     79 . S IBRX="" F  S IBRX=$O(IBRXARR(IBRX)) Q:IBRX=""  D
     80 .. S IBEVDT=0 F  S IBEVDT=$O(IBRXARR(IBRX,IBEVDT)) Q:'IBEVDT  D
     81 ... ;
     82 ... S IBSAVE="1^"_IBRXCPT_"^^"_IBTYPE_"^"_+IBRXARR(IBRX,IBEVDT)_"^"_IBCMPNT
     83 ... D ALLBEDS^IBCRBC2(RS,CS,IBEVDT,IBIRC,IBIDRC,IBSAVE)
     84 ;
     85 I IBBLITEM=3,IBCHGMTH=3 D  ; ndc/quantity
     86 . S IBRX="" F  S IBRX=$O(IBRXARR(IBRX)) Q:IBRX=""  D
     87 .. S IBEVDT=0 F  S IBEVDT=$O(IBRXARR(IBRX,IBEVDT)) Q:'IBEVDT  D
     88 ... S IBX=IBRXARR(IBRX,IBEVDT),IBITM=+IBX,IBUNIT=$P(IBX,U,4),IBNDC=$P(IBX,U,5) Q:IBNDC=""
     89 ... S IBNDC=$O(^IBA(363.21,"B",IBNDC,0)) Q:'IBNDC
     90 ... S IBSAVE="1^"_IBRXCPT_"^^"_IBTYPE_"^"_IBITM_"^"_IBCMPNT
     91 ... D BITMCHG^IBCRBC2(RS,CS,IBNDC,IBEVDT,IBUNIT,"",IBIRC,IBIDRC,IBSAVE)
     92 ;
     93 I IBCHGMTH=2 D  ; va cost
     94 . S IBRX="" F  S IBRX=$O(IBRXARR(IBRX)) Q:IBRX=""  D
     95 .. S IBEVDT=0 F  S IBEVDT=$O(IBRXARR(IBRX,IBEVDT)) Q:'IBEVDT  D
     96 ... S IBX=IBRXARR(IBRX,IBEVDT),IBITM=+IBX,IBUNIT=$P(IBX,U,4) Q:'IBITM
     97 ... S IBSAVE="1^"_IBRXCPT_"^^"_IBTYPE_"^"_IBITM_"^"_IBCMPNT
     98 ... D BITMCHG^IBCRBC2(RS,CS,IBITM,IBEVDT,IBUNIT,"",IBIRC,IBIDRC,IBSAVE)
     99 ;
     100 Q
     101 ;
     102CPT(IBIFN,RS,CS) ; Determine charges for PROCEDURE billable events
     103 ; - the billable event is a CPT procedure from the bill (399,304)
     104 ; - the item to be billed is a CPT, this may include Modifier
     105 ; - for each CPT found on the bill that has a modifier, will first check to see if that CPT-modifier
     106 ;   combination is billable (ie. is defined as a charge item for the Billing Rate, does not have to be active)
     107 ;   if it does not then assumes the charge should be the CPT charge
     108 ; - if the charge set is limited by region then either the CPT's division or if no CPT division then the bill's
     109 ;   Default Division must be contained in the sets region
     110 ; - the billable CPT is added as the CPT of the charge entry, Division is also added if defined for the CPT
     111 ; - the procedures provider may affect the charges due to a provider discount
     112 ; - if an inpatient bill then the bedsection on date of procedure will be used as the default bedsection
     113 ; - different sets of charges apply to SNF and Inpatient care although the bill is defined as inpatient
     114 ; - the Default Rx CPT should not be billed the CPT charge, instead the Rx is charged
     115 ;
     116 N IBX,IBBLITEM,IBCHGMTH,IBBR,IBBDIV,IBIDRC,IBCPTARR,IBCPT,IBCPTFN,IBEVDT,IBMOD,IBDIV,IBTYPE,IBCMPNT
     117 N IBPPRV,IBBS,IBCLIN,IBOE,IBSAVE,IBUNIT,IBCPTRX I '$G(IBIFN)!'$G(CS) Q
     118 ;
     119 D CPT^IBCRBG1(IBIFN,.IBCPTARR) Q:'IBCPTARR
     120 ;
     121 S IBTYPE=4,IBCMPNT=$P($G(^IBE(363.1,+CS,0)),U,4),IBX=$$CSBR^IBCRU3(CS),IBBLITEM=$P(IBX,U,4),IBCHGMTH=$P(IBX,U,5)
     122 S IBIDRC=+$G(^DGCR(399,+IBIFN,"MP"))
     123 I 'IBIDRC,$$MCRWNR^IBEFUNC($$CURR^IBCEF2(IBIFN)) S IBIDRC=$$CURR^IBCEF2(IBIFN)
     124 S IBIDRC=$G(^DIC(36,+IBIDRC,0)),IBIDRC=$P(IBIDRC,U,7)
     125 S IBBR=$P(IBX,U,3) S IBCPTRX="" I $O(^IBA(362.4,"C",IBIFN,0)) S IBCPTRX=+$P($G(^IBE(350.9,1,1)),U,30)
     126 ;
     127 S IBBDIV=$P($G(^DGCR(399,+IBIFN,0)),U,22) ; bill's default division
     128 D INPTPTF^IBCRBG(IBIFN,CS) ; get inpatient bedsections
     129 ;
     130 I IBBLITEM=2 D  ; cpt/count/minutes/miles/hours
     131 . S IBCPT=0 F  S IBCPT=$O(IBCPTARR(IBCPT)) Q:'IBCPT  D
     132 .. S IBCPTFN=0 F  S IBCPTFN=$O(IBCPTARR(IBCPT,IBCPTFN)) Q:'IBCPTFN  D
     133 ... S IBX=IBCPTARR(IBCPT,IBCPTFN),IBEVDT=$P(IBX,U,1),IBMOD=$P(IBX,U,2)
     134 ... S IBDIV=$P(IBX,U,3),IBPPRV=$P(IBX,U,4),IBCLIN=$P(IBX,U,5),IBOE=$P(IBX,U,6)
     135 ... ;
     136 ... I '$$CHGOTH^IBCRBC2(IBIFN,RS,IBEVDT) Q
     137 ... I +IBCPTRX,'IBOE,IBCPT=IBCPTRX Q  ; site parameter rx procedure
     138 ... ;
     139 ... S IBUNIT=$$CPTUNITS^IBCRBC2(CS,IBCHGMTH,IBX) Q:'IBUNIT
     140 ... ;
     141 ... S IBBS=$P($G(^TMP($J,"IBCRC-INDT",IBEVDT)),U,2) ; get inpatient bedsection
     142 ... I 'IBBS S IBX=$O(^TMP($J,"IBCRC-INDT",IBEVDT),-1) I +IBX S IBBS=$P($G(^TMP($J,"IBCRC-INDT",IBX)),U,2)
     143 ... ;
     144 ... I '$P($$CPT^ICPTCOD(+IBCPT,+IBEVDT),U,7) Q  ; check is a valid active CPT
     145 ... I $$CSDV^IBCRU3(CS,IBDIV,IBBDIV)<0 Q  ; check division
     146 ... I +IBMOD S IBMOD=$P($$CPTMOD^IBCRCU1(CS,IBCPT,IBMOD,IBEVDT),",",1) ; check CPT-MODs for billable combination
     147 ... ;
     148 ... S IBSAVE="1^"_IBCPT_U_IBDIV_U_IBTYPE_U_IBCPTFN_U_IBCMPNT_U_IBBS_U_IBPPRV_U_IBCLIN_U_IBOE
     149 ... D BITMCHG^IBCRBC2(RS,CS,IBCPT,IBEVDT,IBUNIT,IBMOD,"",IBIDRC,IBSAVE)
     150 K ^TMP($J,"IBCRC-INDT")
     151 Q
     152 ;
     153PI(IBIFN,RS,CS) ; Determine charges for PROSTHETICS billable events
     154 ; - the billable event is a prosthetic item that has been added to the bill (362.5)
     155 ;
     156 N IBX,IBBLITEM,IBCHGMTH,IBPIARR,IBIDRC,IBEVDT,IBPI,IBITM,IBTYPE,IBCMPNT,IBSAVE I '$G(IBIFN)!'$G(CS) Q
     157 ;
     158 D SET^IBCSC5B(IBIFN,.IBPIARR) Q:'$P(IBPIARR,U,2)
     159 ;
     160 S IBTYPE=5,IBCMPNT=$P($G(^IBE(363.1,+CS,0)),U,4),IBX=$$CSBR^IBCRU3(CS),IBBLITEM=$P(IBX,U,4),IBCHGMTH=$P(IBX,U,5)
     161 S IBIDRC=+$G(^DGCR(399,+IBIFN,"MP"))
     162 I 'IBIDRC,$$MCRWNR^IBEFUNC($$CURR^IBCEF2(IBIFN)) S IBIDRC=$$CURR^IBCEF2(IBIFN)
     163 S IBIDRC=$G(^DIC(36,+IBIDRC,0)),IBIDRC=$P(IBIDRC,U,7)
     164 ;
     165 I IBBLITEM=1,IBCHGMTH=1 D  ; pros/bedsection/per diem
     166 . S IBEVDT="" F  S IBEVDT=$O(IBPIARR(IBEVDT)) Q:'IBEVDT  D
     167 .. S IBPI=0 F  S IBPI=$O(IBPIARR(IBEVDT,IBPI)) Q:'IBPI  D
     168 ... S IBSAVE="1^^^"_IBTYPE_"^^"_IBCMPNT
     169 ... D ALLBEDS^IBCRBC2(RS,CS,IBEVDT,"",IBIDRC,IBSAVE)
     170 ;
     171 I IBCHGMTH=2 D  ; va cost
     172 . S IBEVDT="" F  S IBEVDT=$O(IBPIARR(IBEVDT)) Q:'IBEVDT  D
     173 .. S IBPI=0 F  S IBPI=$O(IBPIARR(IBEVDT,IBPI)) Q:'IBPI  D
     174 ... S IBITM=IBPIARR(IBEVDT,IBPI) Q:'IBITM
     175 ... S IBSAVE="1^^^"_IBTYPE_"^"_+IBITM_"^"_IBCMPNT
     176 ... D BITMCHG^IBCRBC2(RS,CS,+IBITM,IBEVDT,1,"","",IBIDRC,IBSAVE)
     177 ;
     178 Q

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRBC2.m

    r613 r623  
    1 IBCRBC2 ;ALB/ARH - RATES: BILL CALCULATION OF ITEM CHARGE ; 22-MAY-1996
    2         ;;2.0;INTEGRATED BILLING;**52,106,138,148,245,370**;21-MAR-94;Build 5
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5         ; Input:  RS     - rate schedule necessary to calculated modified charges
    6         ;         CS     - required, charge set which defines the charges to calculate
    7         ;         ITEM   - required, ptr to source item to be billed, type defined by billable item of the rate
    8         ;         EVDT   - date of event, to be used when searching for a charge effective date, default=DT
    9         ;         UNITS  - required, used only for Quantity:  # of units of Charge Item Charge for each Item
    10         ;         MOD    - CPT Modifier if any
    11         ;         INSRC  - special revenue code to use (from ins comp), if any (overrides set and item rv cd)
    12         ;         IDFRC  - different revenue codes to use, these replace the standard set in CM (DRC:SRC,DRC:SRC)
    13         ;         SAVE   - serveral data items not needed here but passed on to next step (store) in TMP array:
    14         ;                  TUNITS - required to add charge to bill, total # of the Item on the bill
    15         ;                  CPT    - default CPT to be added to the bill for the charge
    16         ;                  DIV    - division charges apply to
    17         ;                  TYPE   - type of item being billed - defines the source of the item on the bill
    18         ;                  ITMPTR - soft pointer to the item on the bill:  may be a multiple or file IFN
    19         ;                  CMPNT  - what component of the total charge: institutional or professional
    20         ;                  BEDS   - billable bedsection to use if not a bedsection item, if null uses set default
    21         ;                  PROV   - procedure provider
    22         ;                  CLINIC - procedures associated clinic
    23         ;                  IBOE   - Outpatient Encounter, pointer to #408.69
    24         ;                  MODS   - list of all modifiers define for the procedure, separated by ','
    25         ;
    26         ; Total charge is calculated:  X = UNITS * UNIT CHARGE of the item         (per unit charge (un-adjusted))
    27         ;                              Y = X modified by Rate Schedule Adjustment  (per unit charge (adjusted))
    28         ; the Units are used to calculate the per item charge: 30 pills for an rx, 1 bs per bs
    29         ; and the Tunits are the number of that Item on the bill: 1 rx of 30 pills, 11 days of bs stay
    30         ;
    31         ; Output: TMP($J,"IBCRCC", containing all chargable items and all related info needed to file them on the bill
    32         ;         each charge will have it's own entry, nothing combined (12 = per unit charge (adjusted), p13 = Tunits)
    33         ;         TMP is not killed on entry so each items charges are compiled and added to existing charges
    34         ;         
    35 BITMCHG(RS,CS,ITEM,EVDT,UNITS,MOD,INSRC,IDFRC,SAVE)     ; get bill charges for a specific item, rate schedule and charge set and date set into temp array
    36         ;
    37         N IBCS0,IBDRVCD,IBBS,IBCHGARR,IBI,IBCNT,IBLN,IBCI,IBRVCD,IBPPRV,IBCHRG,IBTCHRG,IBRCHRG,IBPCHRG,IBACHRG
    38         N IBMCHRG,IBMODS,IBBASE,IBCOM I '$G(ITEM)!'$G(CS)!'$G(UNITS) Q
    39         ;
    40         S RS=$G(RS),EVDT=$S(+$G(EVDT):+EVDT\1,1:DT),MOD=$G(MOD),INSRC=$G(INSRC),IDFRC=$G(IDFRC),SAVE=$G(SAVE)
    41         S IBCS0=$G(^IBE(363.1,+CS,0)),IBDRVCD=$P(IBCS0,U,5),IBPPRV=$P(SAVE,U,8),IBMODS=$P(SAVE,U,11)
    42         S IBBS=+ITEM I $P($G(^IBE(363.3,+$P(IBCS0,U,2),0)),U,4)'=1 S IBBS=$P(SAVE,U,7) I 'IBBS S IBBS=$P(IBCS0,U,6)
    43         I 'IBBS Q
    44         ;
    45         D ITMCHG^IBCRCC(CS,ITEM,EVDT,MOD,.IBCHGARR)
    46         ;
    47         S IBCNT=+$G(^TMP($J,"IBCRCC"))
    48         S IBI=0 F  S IBI=$O(IBCHGARR(IBI)) Q:'IBI  D
    49         . S IBLN=IBCHGARR(IBI),IBCI=+IBLN,IBCHRG=$P(IBLN,U,3),(IBPCHRG,IBRCHRG)="" Q:'IBCHRG  S IBBASE=$P(IBLN,U,4)
    50         . S IBRVCD=INSRC I 'IBRVCD S IBRVCD=$P(IBLN,U,2)
    51         . I 'IBRVCD S IBRVCD=$P($$RVLNK^IBCRU6(+ITEM,"",+CS),U,2) I 'IBRVCD S IBRVCD=IBDRVCD Q:'IBRVCD
    52         . I +IDFRC,+$P(IDFRC,IBRVCD_":",2) S IBRVCD=+$P(IDFRC,IBRVCD_":",2) Q:IBRVCD'?3N
    53         . ;
    54         . S IBCHRG=IBCHRG*UNITS
    55         . S IBCHRG=IBCHRG+IBBASE
    56         . S IBPCHRG=IBCHRG I +IBPPRV S IBPCHRG=$$PRVCHG^IBCRCC(CS,IBCHRG,IBPPRV,EVDT,ITEM)
    57         . S IBMCHRG=+IBPCHRG I +IBMODS S IBMCHRG=$$MODCHG^IBCRCC(CS,IBPCHRG,IBMODS)
    58         . S (IBCHRG,IBTCHRG)=+IBMCHRG
    59         . S IBACHRG=IBTCHRG I +RS,+IBTCHRG S IBRCHRG=$$RATECHG^IBCRCC(RS,IBTCHRG,EVDT),IBACHRG=+IBRCHRG
    60         . ;
    61         . S IBCNT=IBCNT+1,^TMP($J,"IBCRCC")=IBCNT
    62         . S ^TMP($J,"IBCRCC",IBCNT)=IBCI_U_CS_U_RS_U_ITEM_U_MOD_U_IBRVCD_U_IBBS_U_EVDT_U_IBCHRG_U_UNITS_U_IBTCHRG_U_IBACHRG_U_$G(SAVE)
    63         . ;
    64         . I (UNITS>1)!(+IBBASE) S IBCOM=$$COMMUB(CS,UNITS,IBBASE) I IBCOM'="" D COMMENT(IBCNT,IBCOM)
    65         . I $P(IBPCHRG,U,2)'="" S IBCOM=$P(IBPCHRG,U,2) I IBCOM'="" D COMMENT(IBCNT,IBCOM)
    66         . I $P(IBMCHRG,U,2)'="" S IBCOM=$P(IBMCHRG,U,2) I IBCOM'="" D COMMENT(IBCNT,IBCOM)
    67         . I $P(IBRCHRG,U,2)'="" S IBCOM=$P(IBRCHRG,U,2) I IBCOM'="" D COMMENT(IBCNT,IBCOM)
    68         Q
    69         ;
    70 COMMENT(LINE,COMM)      ; set comment into charge array for a particular line item
    71         I +$D(^TMP($J,"IBCRCC",+$G(LINE))) N IBX D
    72         . S IBX=$O(^TMP($J,"IBCRCC",+LINE,"CC",9999),-1) S IBX=IBX+1
    73         . S ^TMP($J,"IBCRCC",+LINE,"CC",IBX)=$G(COMM)
    74         Q
    75         ;
    76 COMMUB(CS,UNITS,BASE)   ; return comment for special units and base
    77         N IBX,IBY,IBCM S IBX="",IBY="Charge calculated"
    78         S IBCM=$P($G(^IBE(363.1,+CS,0)),U,2),IBCM=$P($G(^IBE(363.3,+IBCM,0)),U,5)
    79         S IBCM=$S(IBCM=4:"Miles",IBCM=5:"SubUnits",IBCM=6:"Hours",1:"")
    80         I +$G(UNITS) S IBX=IBY_" for "_UNITS_" "_IBCM,IBY=""
    81         I +$G(BASE) S IBX=IBY_IBX_" with a Base Charge="_$J(BASE,0,2)
    82         Q IBX
    83         ;
    84 ALLBEDS(RS,CS,EVDT,RC,DFRC,SAVE)        ; get charges for all bedsections active on date of visit
    85         ; each effective date supercedes all previous effective date, regardless of the item
    86         ; used for per diem rates where the charges are associated with a bedsection, but the item being billed is not
    87         ; a bedsection, so the count of the item on the bill is found and applied as the units to all bedsections active
    88         ; on the event date  (the 3 opt visit dates on a bill are the units for the Outpatient Visit bedsection charge)
    89         ;
    90         N IBITM,IBITEMS I '$G(CS)!'$G(EVDT) Q
    91         ;
    92         D CSALL^IBCRCU1(CS,EVDT,.IBITEMS)
    93         ;
    94         I +IBITEMS S IBITM="" F  S IBITM=$O(IBITEMS(IBITM)) Q:'IBITM  D
    95         . D BITMCHG($G(RS),CS,IBITM,EVDT,1,"",$G(RC),$G(DFRC),$G(SAVE))
    96         Q
    97         ;
    98         ;
    99 CPTUNITS(CS,CHGMTH,ITLINE)      ; return CPT units based on Charge Method and CPT data
    100         ; Input:  CS is the related Charge Set
    101         ;         CHGMTH is the Rate Schedule Charge Method (363.3, .05)
    102         ;         ITLINE is item data from CPT^IBCRBG1
    103         ; Output: calculated units for CPT, 1 or calculated for miles/minutes/hours
    104         N IBUNIT S IBUNIT=1,CHGMTH=$G(CHGMTH),ITLINE=$G(ITLINE),CS=$G(CS)
    105         I CHGMTH=4 S IBUNIT=+$P(ITLINE,U,8) ; miles
    106         I CHGMTH=5 S IBUNIT=+$P(ITLINE,U,7) ; minutes
    107         I CHGMTH=6 S IBUNIT=+$P(ITLINE,U,9) ; hours
    108         S IBUNIT=$$CPTUNITS^IBCRCU1(CS,IBUNIT)
    109         Q IBUNIT
    110         ;
    111 CHGOTH(IBIFN,RS,EVDT)   ; check if the Rate Schedule charges are applicable to the event date for the bill
    112         ; this is relevent to RC v2.0 and type of care of Other
    113         ; both Rate Schedule is SNF and event date is SNF care or neither can be otherwise no charge
    114         ; SNF charges can't be used for non-SNF care and non-SNF charges can't be used for SNF care
    115         ; Output: returns true if charges and bill date are of same type, SNF or non-SNF
    116         N IBOK,IBRSTY,IBDTTY S (IBRSTY,IBDTTY)=0,IBOK=1
    117         I $G(EVDT)<$$VERSDT^IBCRU8(2) G CHGOTHQ
    118         I '$G(IBIFN)!'$G(RS) G CHGOTHQ
    119         ;
    120         S IBRSTY=$$RSOTHER^IBCRU8(RS) ; are charges for other type of care
    121         S IBDTTY=$$BOTHER^IBCU3(IBIFN,EVDT) ; is date other type of care
    122         ;
    123         I +IBRSTY,'IBDTTY S IBOK=0
    124         I 'IBRSTY,+IBDTTY S IBOK=0
    125         ;
    126 CHGOTHQ Q IBOK
    127         ;
    128 CHGICU(CS,BS)   ; check if charge and bedsection match relative to ICU RC 2.0+, compares Charge Set Name and Bedsection
    129         ; both the charge set and the bedsection have to be ICU or neither of them can be ICU otherwise no charge
    130         ; ICU charges can't be used with non-ICU bedsections and non-ICU charges can't be used with ICU bedsection
    131         ; Output: returns true if charges and bedsection are of same type, ICU or non-ICU
    132         N IBCSICU,IBCSN,IBICU,IBOK S (IBOK,IBCSICU)=0,BS=+$G(BS)
    133         S IBICU=$$MCCRUTL^IBCRU1("ICU",5)
    134         S IBCSN=$G(^IBE(363.1,+$G(CS),0)) I $E(IBCSN,1,2)'="RC" S IBOK=1
    135         I $P(IBCSN,U,1)["ICU" S IBCSICU=1 ; charge set is icu
    136         ;
    137         I BS=IBICU,+IBCSICU S IBOK=1 ; both bedsection and charge set are icu
    138         I BS'=IBICU,'IBCSICU S IBOK=1 ; niether bedsection nor charge set are icu
    139         Q IBOK
     1IBCRBC2 ;ALB/ARH - RATES: BILL CALCULATION OF ITEM CHARGE ; 22-MAY-1996
     2 ;;2.0;INTEGRATED BILLING;**52,106,138,148,245**;21-MAR-94
     3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
     4 ;
     5 ; Input:  RS     - rate schedule necessary to calculated modified charges
     6 ;         CS     - required, charge set which defines the charges to calculate
     7 ;         ITEM   - required, ptr to source item to be billed, type defined by billable item of the rate
     8 ;         EVDT   - date of event, to be used when searching for a charge effective date, default=DT
     9 ;         UNITS  - required, used only for Quantity:  # of units of Charge Item Charge for each Item
     10 ;         MOD    - CPT Modifier if any
     11 ;         INSRC  - special revenue code to use (from ins comp), if any (overrides set and item rv cd)
     12 ;         IDFRC  - different revenue codes to use, these replace the standard set in CM (DRC:SRC,DRC:SRC)
     13 ;         SAVE   - serveral data items not needed here but passed on to next step (store) in TMP array:
     14 ;                  TUNITS - required to add charge to bill, total # of the Item on the bill
     15 ;                  CPT    - default CPT to be added to the bill for the charge
     16 ;                  DIV    - division charges apply to
     17 ;                  TYPE   - type of item being billed - defines the source of the item on the bill
     18 ;                  ITMPTR - soft pointer to the item on the bill:  may be a multiple or file IFN
     19 ;                  CMPNT  - what component of the total charge: institutional or professional
     20 ;                  BEDS   - billable bedsection to use if not a bedsection item, if null uses set default
     21 ;                  PROV   - procedure provider
     22 ;                  CLINIC - procedures associated clinic
     23 ;                  IBOE   - Outpatient Encounter, pointer to #408.69
     24 ;
     25 ; Total charge is calculated:  X = UNITS * UNIT CHARGE of the item         (per unit charge (un-adjusted))
     26 ;                              Y = X modified by Rate Schedule Adjustment  (per unit charge (adjusted))
     27 ; the Units are used to calculate the per item charge: 30 pills for an rx, 1 bs per bs
     28 ; and the Tunits are the number of that Item on the bill: 1 rx of 30 pills, 11 days of bs stay
     29 ;
     30 ; Output: TMP($J,"IBCRCC", containing all chargable items and all related info needed to file them on the bill
     31 ;         each charge will have it's own entry, nothing combined (12 = per unit charge (adjusted), p13 = Tunits)
     32 ;         TMP is not killed on entry so each items charges are compiled and added to existing charges
     33 ;         
     34BITMCHG(RS,CS,ITEM,EVDT,UNITS,MOD,INSRC,IDFRC,SAVE) ; get bill charges for a specific item, rate schedule and charge set and date set into temp array
     35 ;
     36 N IBCS0,IBDRVCD,IBBS,IBCHGARR,IBI,IBCNT,IBLN,IBCI,IBRVCD,IBPPRV,IBCHRG,IBTCHRG,IBRCHRG,IBPCHRG,IBACHRG,IBBASE,IBCOM
     37 I '$G(ITEM)!'$G(CS)!'$G(UNITS) Q
     38 ;
     39 S RS=$G(RS),EVDT=$S(+$G(EVDT):+EVDT\1,1:DT),MOD=$G(MOD),INSRC=$G(INSRC),IDFRC=$G(IDFRC),SAVE=$G(SAVE)
     40 S IBCS0=$G(^IBE(363.1,+CS,0)),IBDRVCD=$P(IBCS0,U,5),IBPPRV=$P(SAVE,U,8)
     41 S IBBS=+ITEM I $P($G(^IBE(363.3,+$P(IBCS0,U,2),0)),U,4)'=1 S IBBS=$P(SAVE,U,7) I 'IBBS S IBBS=$P(IBCS0,U,6)
     42 I 'IBBS Q
     43 ;
     44 D ITMCHG^IBCRCC(CS,ITEM,EVDT,MOD,.IBCHGARR)
     45 ;
     46 S IBCNT=+$G(^TMP($J,"IBCRCC"))
     47 S IBI=0 F  S IBI=$O(IBCHGARR(IBI)) Q:'IBI  D
     48 . S IBLN=IBCHGARR(IBI),IBCI=+IBLN,IBCHRG=$P(IBLN,U,3),(IBPCHRG,IBRCHRG)="" Q:'IBCHRG  S IBBASE=$P(IBLN,U,4)
     49 . S IBRVCD=INSRC I 'IBRVCD S IBRVCD=$P(IBLN,U,2)
     50 . I 'IBRVCD S IBRVCD=$P($$RVLNK^IBCRU6(+ITEM,"",+CS),U,2) I 'IBRVCD S IBRVCD=IBDRVCD Q:'IBRVCD
     51 . I +IDFRC,+$P(IDFRC,IBRVCD_":",2) S IBRVCD=+$P(IDFRC,IBRVCD_":",2) Q:IBRVCD'?3N
     52 . ;
     53 . S IBCHRG=IBCHRG*UNITS
     54 . S IBCHRG=IBCHRG+IBBASE
     55 . S IBPCHRG=IBCHRG I +IBPPRV S IBPCHRG=$$PRVCHG^IBCRCC(CS,IBCHRG,IBPPRV,EVDT,ITEM)
     56 . S (IBCHRG,IBTCHRG)=+IBPCHRG
     57 . S IBACHRG=IBTCHRG I +RS,+IBTCHRG S IBRCHRG=$$RATECHG^IBCRCC(RS,IBTCHRG,EVDT),IBACHRG=+IBRCHRG
     58 . ;
     59 . S IBCNT=IBCNT+1,^TMP($J,"IBCRCC")=IBCNT
     60 . S ^TMP($J,"IBCRCC",IBCNT)=IBCI_U_CS_U_RS_U_ITEM_U_MOD_U_IBRVCD_U_IBBS_U_EVDT_U_IBCHRG_U_UNITS_U_IBTCHRG_U_IBACHRG_U_$G(SAVE)
     61 . ;
     62 . I (UNITS>1)!(+IBBASE) S IBCOM=$$COMMUB(CS,UNITS,IBBASE) I IBCOM'="" D COMMENT(IBCNT,IBCOM)
     63 . I $P(IBPCHRG,U,2)'="" S IBCOM=$P(IBPCHRG,U,2) I IBCOM'="" D COMMENT(IBCNT,IBCOM)
     64 . I $P(IBRCHRG,U,2)'="" S IBCOM=$P(IBRCHRG,U,2) I IBCOM'="" D COMMENT(IBCNT,IBCOM)
     65 Q
     66 ;
     67COMMENT(LINE,COMM) ; set comment into charge array for a particular line item
     68 I +$D(^TMP($J,"IBCRCC",+$G(LINE))) N IBX D
     69 . S IBX=$O(^TMP($J,"IBCRCC",+LINE,"CC",9999),-1) S IBX=IBX+1
     70 . S ^TMP($J,"IBCRCC",+LINE,"CC",IBX)=$G(COMM)
     71 Q
     72 ;
     73COMMUB(CS,UNITS,BASE) ; return comment for special units and base
     74 N IBX,IBY,IBCM S IBX="",IBY="Charge calculated"
     75 S IBCM=$P($G(^IBE(363.1,+CS,0)),U,2),IBCM=$P($G(^IBE(363.3,+IBCM,0)),U,5)
     76 S IBCM=$S(IBCM=4:"Miles",IBCM=5:"SubUnits",IBCM=6:"Hours",1:"")
     77 I +$G(UNITS) S IBX=IBY_" for "_UNITS_" "_IBCM,IBY=""
     78 I +$G(BASE) S IBX=IBY_IBX_" with a Base Charge="_$J(BASE,0,2)
     79 Q IBX
     80 ;
     81ALLBEDS(RS,CS,EVDT,RC,DFRC,SAVE) ; get charges for all bedsections active on date of visit
     82 ; each effective date supercedes all previous effective date, regardless of the item
     83 ; used for per diem rates where the charges are associated with a bedsection, but the item being billed is not
     84 ; a bedsection, so the count of the item on the bill is found and applied as the units to all bedsections active
     85 ; on the event date  (the 3 opt visit dates on a bill are the units for the Outpatient Visit bedsection charge)
     86 ;
     87 N IBITM,IBITEMS I '$G(CS)!'$G(EVDT) Q
     88 ;
     89 D CSALL^IBCRCU1(CS,EVDT,.IBITEMS)
     90 ;
     91 I +IBITEMS S IBITM="" F  S IBITM=$O(IBITEMS(IBITM)) Q:'IBITM  D
     92 . D BITMCHG($G(RS),CS,IBITM,EVDT,1,"",$G(RC),$G(DFRC),$G(SAVE))
     93 Q
     94 ;
     95 ;
     96CPTUNITS(CS,CHGMTH,ITLINE) ; return CPT units based on Charge Method and CPT data
     97 ; Input:  CS is the related Charge Set
     98 ;         CHGMTH is the Rate Schedule Charge Method (363.3, .05)
     99 ;         ITLINE is item data from CPT^IBCRBG1
     100 ; Output: calculated units for CPT, 1 or calculated for miles/minutes/hours
     101 N IBUNIT S IBUNIT=1,CHGMTH=$G(CHGMTH),ITLINE=$G(ITLINE),CS=$G(CS)
     102 I CHGMTH=4 S IBUNIT=+$P(ITLINE,U,8) ; miles
     103 I CHGMTH=5 S IBUNIT=+$P(ITLINE,U,7) ; minutes
     104 I CHGMTH=6 S IBUNIT=+$P(ITLINE,U,9) ; hours
     105 S IBUNIT=$$CPTUNITS^IBCRCU1(CS,IBUNIT)
     106 Q IBUNIT
     107 ;
     108CHGOTH(IBIFN,RS,EVDT) ; check if the Rate Schedule charges are applicable to the event date for the bill
     109 ; this is relevent to RC v2.0 and type of care of Other
     110 ; both Rate Schedule is SNF and event date is SNF care or neither can be otherwise no charge
     111 ; SNF charges can't be used for non-SNF care and non-SNF charges can't be used for SNF care
     112 ; Output: returns true if charges and bill date are of same type, SNF or non-SNF
     113 N IBOK,IBRSTY,IBDTTY S (IBRSTY,IBDTTY)=0,IBOK=1
     114 I $G(EVDT)<$$VERSDT^IBCRU8(2) G CHGOTHQ
     115 I '$G(IBIFN)!'$G(RS) G CHGOTHQ
     116 ;
     117 S IBRSTY=$$RSOTHER^IBCRU8(RS) ; are charges for other type of care
     118 S IBDTTY=$$BOTHER^IBCU3(IBIFN,EVDT) ; is date other type of care
     119 ;
     120 I +IBRSTY,'IBDTTY S IBOK=0
     121 I 'IBRSTY,+IBDTTY S IBOK=0
     122 ;
     123CHGOTHQ Q IBOK
     124 ;
     125CHGICU(CS,BS) ; check if charge and bedsection match relative to ICU RC 2.0+, compares Charge Set Name and Bedsection
     126 ; both the charge set and the bedsection have to be ICU or neither of them can be ICU otherwise no charge
     127 ; ICU charges can't be used with non-ICU bedsections and non-ICU charges can't be used with ICU bedsection
     128 ; Output: returns true if charges and bedsection are of same type, ICU or non-ICU
     129 N IBCSICU,IBCSN,IBICU,IBOK S (IBOK,IBCSICU)=0,BS=+$G(BS)
     130 S IBICU=$$MCCRUTL^IBCRU1("ICU",5)
     131 S IBCSN=$G(^IBE(363.1,+$G(CS),0)) I $E(IBCSN,1,2)'="RC" S IBOK=1
     132 I $P(IBCSN,U,1)["ICU" S IBCSICU=1 ; charge set is icu
     133 ;
     134 I BS=IBICU,+IBCSICU S IBOK=1 ; both bedsection and charge set are icu
     135 I BS'=IBICU,'IBCSICU S IBOK=1 ; niether bedsection nor charge set are icu
     136 Q IBOK

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRBG.m

    r613 r623  
    1 IBCRBG  ;ALB/ARH - RATES: BILL SOURCE EVENTS (INPT) ; 21 MAY 96
    2         ;;2.0;INTEGRATED BILLING;**52,80,106,51,142,159,210,245,382,389**;21-MAR-94;Build 6
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5 INPTPTF(IBIFN,CS)       ; search PTF record for billable bedsections, transfer DRGs, and length of stay
    6         ; - screens out days for pass, leave and SC treatment
    7         ; - adds charges for only one BS if the ins company does not allow multiple bedsections per bill (36,.06)
    8         ; Output: ^TMP($J,"IBCRC-INDT", BILLABLE DATE) = MOVE DT/TM ^ BILL BS ^ SC FLAG ^ DRG ^ DIV ^ SPECIALTY ^ MOVE #
    9         ;
    10         N IB0,DFN,PTF,IBU,IBBDT,IBEDT,IBTF,IBADM,IBX,IBINSMBS
    11         K ^TMP($J,"IBCRC-PTF"),^TMP($J,"IBCRC-DIV"),^TMP($J,"IBCRC-INDT")
    12         ;
    13         S IB0=$G(^DGCR(399,+$G(IBIFN),0)),DFN=$P(IB0,U,2) Q:'DFN
    14         S IBTF=$P(IB0,U,6),PTF="" S:$P(IB0,U,5)<3 PTF=$P(IB0,U,8) Q:'PTF
    15         S IBINSMBS=0,IBX=+$G(^DGCR(399,+IBIFN,"MP"))
    16         I 'IBX,$$MCRWNR^IBEFUNC($$CURR^IBCEF2(IBIFN)) S IBX=$$CURR^IBCEF2(IBIFN)
    17         I $P($G(^DIC(36,+IBX,0)),U,6)=0 S IBINSMBS=1 ; 1 bs per bill
    18         ;
    19         S IBU=$G(^DGCR(399,+IBIFN,"U")) Q:'IBU
    20         S IBBDT=+IBU,IBEDT=$P(IBU,U,2) Q:'IBEDT
    21         ;
    22         S IBADM=$O(^DGPM("APTF",PTF,0)) ; find corresponding admission
    23         ;
    24         D PTF(PTF) ; get movements and bedsections
    25         D PTFDV(PTF) ; reset movements and bedsections for ward/division
    26         D PTFFY(PTF,IBBDT,IBEDT) ; reset movements for FY DRG change
    27         ;
    28         D BSLOS(IBBDT,IBEDT,IBTF,IBADM,IBINSMBS) ; calculate days in bedsections within timeframe of the bill
    29         ;
    30         K ^TMP($J,"IBCRC-PTF"),^TMP($J,"IBCRC-DIV")
    31         ;
    32         D INPTRSET^IBCRBG2(IBIFN,$G(CS))
    33         Q
    34         ;
    35 PTF(PTF)        ; find all movements in PTF for the admission by date and billing bedsection (501 movement)
    36         ; the movement date is the date the patient left the bedsection
    37         ; Output: ^TMP($J,"IBCRC-PTF", MOVE DT/TM)=MOVE DT/TM ^ BILL BED ^ SC FLAG ^ TRANSFER DRG ^ ^ SPECIALTY ^ MOVE #
    38         ;
    39         N IBMOVE,IBMVLN,IBBILLBS,IBENDDT,IBMSC,IBMDRG S PTF=+$G(PTF)
    40         S IBMOVE=0 F  S IBMOVE=$O(^DGPT(PTF,"M",IBMOVE)) Q:'IBMOVE  D
    41         . S IBMVLN=^DGPT(PTF,"M",IBMOVE,0)
    42         . S IBBILLBS=+$$SPBB($P(IBMVLN,U,2)) ;                                 billable bedsection
    43         . S IBENDDT=+$P(IBMVLN,U,10) I 'IBENDDT S IBENDDT=DT ;                 movement date (last date in bedsection)
    44         . S IBMSC="" I +$P(IBMVLN,U,18)=1 S IBMSC=1 ;                          sc movement
    45         . S IBMDRG=$$MVDRG(PTF,IBMOVE) ;                                       movement DRG
    46         . S ^TMP($J,"IBCRC-PTF",IBENDDT)=IBENDDT_U_IBBILLBS_U_IBMSC_U_IBMDRG_U_U_+$P(IBMVLN,U,2)_U_IBMOVE
    47         Q
    48         ;
    49 SPBB(SPCLTY)    ; find the billable bedsection for a Specialty (42.4)
    50         ; returns billable bedsection IFN ^ billable bedsection name
    51         N IBX,IBY,IBZ S IBZ=0
    52         S IBX=$P($G(^DIC(42.4,+$G(SPCLTY),0)),U,5)
    53         I IBX'="" S IBY=$O(^DGCR(399.1,"B",IBX,0)) I +IBY S IBZ=IBY_U_IBX
    54         Q IBZ
    55         ;
    56 BSLOS(IBBDT,IBEDT,IBTF,IBADM,IBINSMBS)  ; from the array of PTF movments get all bedsections and their LOS covered by date range of the bill
    57         ; adds all days for first cronological bs if ins comp wants only a single bs per bill, even if not sequential
    58         ; the movement date is the date the patient left the bedsection, so admission date is not in PTF array
    59         ;
    60         ; Input:  ^TMP($J,"IBCRC-PTF", MOVE DT/TM) = MOVE DT/TM ^ BILL BS ^ SC FLAG ^ DRG ^ DIV ^ SPECIALTY ^ MOVE #
    61         ; Output: ^TMP($J,"IBCRC-INDT", BILLABLE DATE) = MOVE DT/TM ^ BILL BS ^ SC FLAG ^ DRG ^ DIV ^ SPECIALTY ^ MOVE #
    62         ;
    63         N IBSBDT,IBSEDT,IBS,IBLASTDT,IBX
    64         S IBSBDT=IBBDT+.3 ;                        discount any movements ending on or before the begin date
    65         S IBSEDT=IBEDT\1
    66         ;
    67         I ",2,3,"'[IBTF S IBSEDT=IBSEDT-.01 ;      final bill, do not count last day
    68         ;
    69         I +$G(IBADM) S IBX=$$AD^IBCU64(IBADM) I +IBX,($P(IBX,U,1)\1)=($P(IBX,U,2)\1) S IBSBDT=IBBDT ; reset 1 day stays
    70         ;
    71         S IBS=IBSBDT-.01 F  S IBS=$O(^TMP($J,"IBCRC-PTF",IBS)) Q:'IBS  D SET S IBLASTDT=IBS Q:(IBLASTDT\1)>IBSEDT
    72         ;
    73         Q
    74         ;
    75 SET     ; checks a specific movement to determine if it should be billed and what the length of stay is
    76         ; setting of the movement date determines how many days are counted in the bedsection
    77         N IBMVLN,IBMBDT,IBMEDT,IBMTF,IBMLOS,IBI,IBCHGDT
    78         S IBMVLN=$G(^TMP($J,"IBCRC-PTF",IBS))
    79         I '$P(IBMVLN,U,2) Q  ;                                              non-billable bedsection
    80         I +$P(IBMVLN,U,3) Q  ;                                              sc movement
    81         I +IBINSMBS,+$G(IBLASTDT) Q  ;                                      ins does not allow multiple bs
    82         ;
    83         S IBMBDT=$S(IBBDT>$G(IBLASTDT):IBBDT,1:IBLASTDT),IBMBDT=IBMBDT\1 ;  start cnt on begin dt or last move dt
    84         S IBMEDT=$S(IBS<IBEDT:IBS,1:IBEDT),IBMEDT=IBMEDT\1 ;                end cnt on move dt or end dt
    85         S IBMTF=$S(IBEDT<(IBS\1):IBTF,1:1) ;                                last movement gets timeframe
    86         S IBMLOS=$$LOS^IBCU64(IBMBDT,IBMEDT,IBMTF,IBADM) Q:'IBMLOS  ;       calculate the LOS for the movement
    87         ;
    88         F IBI=1:1:IBMLOS S IBCHGDT=$$FMADD^XLFDT(IBMBDT,(IBI-1)),^TMP($J,"IBCRC-INDT",+IBCHGDT)=IBMVLN
    89         Q
    90         ;
    91 BBS(X)  ; returns true if pointer passed in is a billable bedsection ^ bedsection name
    92         N IBX,IBY S IBY=0,IBX=$G(^DGCR(399.1,+$G(X),0)) I +$P(IBX,U,5) S IBY=1_U_$P(IBX,U,1)
    93         Q IBY
    94         ;
    95         Q
    96         ;
    97 PTFDV(PTF)      ; find all ward/location transfers in PTF for the patient to determine the site/division the patient was in
    98         ; the division of the ward will be added to the PTF bedsection movements
    99         ; Input:  ^TMP($J,"IBCRC-PTF", move dt/tm) = move dt/tm ^ bill bs ^ sc flag ^ move drg ^ ^ specialty ^ move #
    100         ; Output: ^TMP($J,"IBCRC-PTF", move dt/tm) = move dt/tm ^ bill bs ^ sc flag ^ move drg ^ WARD DIV ^ spec ^ move#
    101         ;          ^TMP($J,"IBCRC-DIV", TRANSFER DATE/TIME) = WARD DIVISION
    102         N IBTRNSF,IBTRLN,IBENDDT,IBTRDV,IBMVDT,IBTRDT
    103         ;
    104         I '$O(^TMP($J,"IBCRC-PTF",0)) Q
    105         ;
    106         ; get all ward transfers
    107         S IBTRNSF=0 F  S IBTRNSF=$O(^DGPT(PTF,535,IBTRNSF)) Q:'IBTRNSF  D
    108         . S IBTRLN=$G(^DGPT(PTF,535,+IBTRNSF,0))
    109         . S IBENDDT=$P(IBTRLN,U,10) I 'IBENDDT S IBENDDT=DT ;                  transfer date (last date in ward)
    110         . S IBTRDV=$P($G(^DIC(42,+$P(IBTRLN,U,6),0)),U,11) Q:'IBTRDV  ;        losing ward division
    111         . S ^TMP($J,"IBCRC-DIV",IBENDDT)=IBTRDV
    112         ;
    113         ; if the ward transfer does not coincide with a specialty transfer add bedsection move on the transfer date
    114         S IBENDDT=0 F  S IBENDDT=$O(^TMP($J,"IBCRC-DIV",IBENDDT)) Q:'IBENDDT  D
    115         . S IBMVDT=$O(^TMP($J,"IBCRC-PTF",(IBENDDT-.0000001)))
    116         . I 'IBMVDT Q  ; - transfer movement dates after the discharge date in the PTF file (inconsistent)
    117         . I $P(IBENDDT,".")'=$P(IBMVDT,".") S ^TMP($J,"IBCRC-PTF",IBENDDT)=$G(^TMP($J,"IBCRC-PTF",IBMVDT))
    118         ;
    119         ; add the ward division to the bedsection/specialty
    120         S IBENDDT=0 F  S IBENDDT=$O(^TMP($J,"IBCRC-PTF",IBENDDT)) Q:'IBENDDT  D
    121         . S IBTRDT=$O(^TMP($J,"IBCRC-DIV",(IBENDDT-.0000001))) ;              ward transfer covering this bedsection
    122         . S IBTRDV=$G(^TMP($J,"IBCRC-DIV",+IBTRDT)) ;                         ward division
    123         . I +IBTRDV S $P(^TMP($J,"IBCRC-PTF",IBENDDT),U,5)=IBTRDV
    124         Q
    125         ;
    126 PTFFY(PTF,BEGDT,ENDDT)  ; add movement for FY (10/1) if date range covers FY and DRG changes
    127         ; the DRG may change on FY so check and if necessary add movement for pre-FY with old DRG
    128         ; Input:  ^TMP($J,"IBCRC-PTF", move dt/tm) = move dt/tm ^ bill bs ^ sc flag ^ move drg ^ ^ specialty ^ move #
    129         ; Output: ^TMP($J,"IBCRC-PTF", move dt/tm) = move dt/tm ^ bill bs ^ sc flag ^ MOVE DRG ^ ward div ^ spec ^ move#
    130         N IBBEGDT,IBENDDT,IBYRB,IBYRE,IBYR,IBFY,IBMVLN,IBMVDRG,IBMOVE,IBFYDRG Q:'$G(PTF)
    131         Q:'$G(BEGDT)  S IBFY=$E(BEGDT,1,3)_"1001"
    132         ;
    133         S IBBEGDT=BEGDT,IBENDDT=BEGDT\1 F  S IBENDDT=$O(^TMP($J,"IBCRC-PTF",IBENDDT)) Q:'IBENDDT  D  S IBBEGDT=IBENDDT
    134         . S IBYRB=$E(IBBEGDT,1,3),IBYRE=$E(IBENDDT,1,3) I (IBYRE-IBYRB)>10 Q
    135         . F IBYR=IBYRB:1:IBYRE S IBFY=IBYR_"1001" I IBBEGDT<IBFY,IBENDDT>IBFY D
    136         .. S IBMVLN=$G(^TMP($J,"IBCRC-PTF",IBENDDT)),IBMVDRG=$P(IBMVLN,U,4),IBMOVE=$P(IBMVLN,U,7)
    137         .. S IBFYDRG=$$MVDRG(PTF,IBMOVE,IBYR_"0930")
    138         .. I IBMVDRG'=IBFYDRG S $P(IBMVLN,U,4)=IBFYDRG S ^TMP($J,"IBCRC-PTF",IBFY)=IBMVLN
    139         Q
    140         ;
    141 MVDRG(PTF,M,CDATE)      ; Return the DRG for a specific PTF Movememt (M=move ifn)
    142         ; CDATE is optional, used if need to calculate DRG for some day within the move, not at the end date
    143         N DPT0,PTF0,PTFM0,PTF70,IBBEG,IBEND,IBDSST,IBDX,IBPRC0,IBPRC,IBDRG,IBI,IBJ,IBP
    144         N SEX,AGE,ICDDX,ICDPRC,ICDEXP,ICDDMS,ICDTRS,ICDDRG,ICDMDC,ICDRTC,ICDDATE
    145         S IBDRG=""
    146         ;
    147         S PTF0=$G(^DGPT(+$G(PTF),0)),DPT0=$G(^DPT(+$P(PTF0,U,1),0)) I DPT0="" G MVDRGQ
    148         S PTFM0=$G(^DGPT(+PTF,"M",+$G(M),0)) I 'PTFM0 G MVDRGQ
    149         S PTF70=$G(^DGPT(+PTF,70)),IBDSST=+$P(PTF70,U,3)
    150         ;
    151         S IBEND=+$P(PTFM0,U,10) I 'IBEND S IBEND=DT+.9
    152         S IBBEG=$O(^DGPT(+PTF,"M","AM",IBEND),-1) I 'IBBEG S IBBEG=$P(PTF0,U,2)
    153         ;
    154         S SEX=$P(DPT0,U,2)
    155         S AGE=$P(DPT0,U,3),AGE=$$FMDIFF^XLFDT(IBEND,AGE)\365.25
    156         ;
    157         S (ICDEXP,ICDDMS,ICDTRS)=0 I +PTF70,+PTF70=$P(PTFM0,U,10) D
    158         . I IBDSST>5 S ICDEXP=1 ;  patient expired
    159         . I IBDSST=4 S ICDDMS=1 ;  patient left against medical advice
    160         . I IBDSST=5,+$P(PTF70,U,13) S ICDTRS=1 ; patient transfered to another facility
    161         ;
    162         S IBJ=0 F IBI=5:1:9 S IBDX=$P(PTFM0,U,IBI) I +IBDX,($$ICD9^IBACSV(+IBDX)'="") S IBJ=IBJ+1,ICDDX(IBJ)=IBDX
    163         ;
    164         I '$O(ICDDX(0)) G MVDRGQ
    165         ;
    166         S IBJ=0
    167         S IBP=0 F  S IBP=$O(^DGPT(+PTF,"S",IBP)) Q:'IBP  D  ; surguries
    168         . S IBPRC0=$G(^DGPT(+PTF,"S",IBP,0)) Q:'IBPRC0
    169         . I +IBPRC0'<IBBEG,+IBPRC0'>IBEND D
    170         .. F IBI=8:1:12 S IBPRC=$P(IBPRC0,U,IBI) I +IBPRC,($$ICD0^IBACSV(+IBPRC)'="") S IBJ=IBJ+1,ICDPRC(IBJ)=+IBPRC
    171         ;
    172         S IBP=0 F  S IBP=$O(^DGPT(+PTF,"P",IBP)) Q:'IBP  D  ; procedures
    173         . S IBPRC0=$G(^DGPT(+PTF,"P",IBP,0)) Q:'IBPRC0
    174         . I +IBPRC0'<IBBEG,+IBPRC0'>IBEND D
    175         .. F IBI=5:1:9 S IBPRC=$P(IBPRC0,U,IBI) I +IBPRC,($$ICD0^IBACSV(+IBPRC)'="") S IBJ=IBJ+1,ICDPRC(IBJ)=+IBPRC
    176         ;
    177         S ICDDATE=$S(+$G(CDATE):CDATE,+$P(PTFM0,U,10):+$P(PTFM0,U,10),1:DT) ; date for the DRG Grouper versioning
    178         D ^ICDDRG S IBDRG=$G(ICDDRG)
    179         ;
    180 MVDRGQ  Q IBDRG
     1IBCRBG ;ALB/ARH - RATES: BILL SOURCE EVENTS (INPT) ; 21 MAY 96
     2 ;;2.0;INTEGRATED BILLING;**52,80,106,51,142,159,210,245**;21-MAR-94
     3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
     4 ;
     5INPTPTF(IBIFN,CS) ; search PTF record for billable bedsections, transfer DRGs, and length of stay
     6 ; - screens out days for pass, leave and SC treatment
     7 ; - adds charges for only one BS if the ins company does not allow multiple bedsections per bill (36,.06)
     8 ; Output:  ^TMP($J,"IBCRC-INDT", BILLABLE DATE) = MOVE DT/TM ^ BILL BS ^ SC FLAG ^ DRG ^ DIVISION ^ SPECIALTY
     9 ;
     10 N IB0,DFN,PTF,IBU,IBBDT,IBEDT,IBTF,IBADM,IBX,IBINSMBS
     11 K ^TMP($J,"IBCRC-PTF"),^TMP($J,"IBCRC-DIV"),^TMP($J,"IBCRC-INDT")
     12 ;
     13 S IB0=$G(^DGCR(399,+$G(IBIFN),0)),DFN=$P(IB0,U,2) Q:'DFN
     14 S IBTF=$P(IB0,U,6),PTF="" S:$P(IB0,U,5)<3 PTF=$P(IB0,U,8) Q:'PTF
     15 S IBINSMBS=0,IBX=+$G(^DGCR(399,+IBIFN,"MP"))
     16 I 'IBX,$$MCRWNR^IBEFUNC($$CURR^IBCEF2(IBIFN)) S IBX=$$CURR^IBCEF2(IBIFN)
     17 I $P($G(^DIC(36,+IBX,0)),U,6)=0 S IBINSMBS=1 ; 1 bs per bill
     18 ;
     19 S IBU=$G(^DGCR(399,+IBIFN,"U")) Q:'IBU
     20 S IBBDT=+IBU,IBEDT=$P(IBU,U,2) Q:'IBEDT
     21 ;
     22 S IBADM=$O(^DGPM("APTF",PTF,0)) ; find corresponding admission
     23 ;
     24 D PTF(PTF) ; get movements and bedsections
     25 D PTFDV(PTF) ; reset movements and bedsections for ward/division
     26 ;
     27 D BSLOS(IBBDT,IBEDT,IBTF,IBADM,IBINSMBS) ; calculate days in bedsections within timeframe of the bill
     28 ;
     29 K ^TMP($J,"IBCRC-PTF"),^TMP($J,"IBCRC-DIV")
     30 ;
     31 D INPTRSET^IBCRBG2(IBIFN,$G(CS))
     32 Q
     33 ;
     34PTF(PTF) ; find all movements in PTF for the admission by date and billing bedsection (501 movement)
     35 ; the movement date is the date the patient left the bedsection
     36 ; Output:  ^TMP($J,"IBCRC-PTF", MOVE DT/TM)=MOVE DT/TM ^ BILL BEDSECTION ^ SC FLAG ^ TRANSFER DRG ^ ^ SPECIALTY
     37 ;
     38 N IBMOVE,IBMVLN,IBBILLBS,IBENDDT,IBMSC,IBMDRG S PTF=+$G(PTF)
     39 S IBMOVE=0 F  S IBMOVE=$O(^DGPT(PTF,"M",IBMOVE)) Q:'IBMOVE  D
     40 . S IBMVLN=^DGPT(PTF,"M",IBMOVE,0)
     41 . S IBBILLBS=+$$SPBB($P(IBMVLN,U,2)) ;                                 billable bedsection
     42 . S IBENDDT=+$P(IBMVLN,U,10) I 'IBENDDT S IBENDDT=DT ;                 movement date (last date in bedsection)
     43 . S IBMSC="" I +$P(IBMVLN,U,18)=1 S IBMSC=1 ;                          sc movement
     44 . S IBMDRG=$$MVDRG(PTF,IBMOVE) ;                                       movement DRG
     45 . S ^TMP($J,"IBCRC-PTF",IBENDDT)=IBENDDT_U_IBBILLBS_U_IBMSC_U_IBMDRG_U_U_+$P(IBMVLN,U,2)
     46 Q
     47 ;
     48SPBB(SPCLTY) ; find the billable bedsection for a Specialty (42.4)
     49 ; returns billable bedsection IFN ^ billable bedsection name
     50 N IBX,IBY,IBZ S IBZ=0
     51 S IBX=$P($G(^DIC(42.4,+$G(SPCLTY),0)),U,5)
     52 I IBX'="" S IBY=$O(^DGCR(399.1,"B",IBX,0)) I +IBY S IBZ=IBY_U_IBX
     53 Q IBZ
     54 ;
     55BSLOS(IBBDT,IBEDT,IBTF,IBADM,IBINSMBS) ; from the array of PTF movments get all bedsections and their LOS covered by date range of the bill
     56 ; adds all days for first cronological bs if ins comp wants only a single bs per bill, even if not sequential
     57 ; the movement date is the date the patient left the bedsection, so admission date is not in PTF array
     58 ;
     59 ; Input:   ^TMP($J,"IBCRC-PTF", MOVE DT/TM) = MOVE DT/TM ^ BILL BS ^ SC FLAG ^ DRG ^ DIVISION ^ SPECIALTY
     60 ; Output:  ^TMP($J,"IBCRC-INDT", BILLABLE DATE) = MOVE DT/TM ^ BILL BS ^ SC FLAG ^ DRG ^ DIVISION ^ SPECIALTY
     61 ;
     62 N IBSBDT,IBSEDT,IBS,IBLASTDT,IBX
     63 S IBSBDT=IBBDT+.3 ;                        discount any movements ending on or before the begin date
     64 S IBSEDT=IBEDT\1
     65 ;
     66 I ",2,3,"'[IBTF S IBSEDT=IBSEDT-.01 ;      final bill, do not count last day
     67 ;
     68 I +$G(IBADM) S IBX=$$AD^IBCU64(IBADM) I +IBX,($P(IBX,U,1)\1)=($P(IBX,U,2)\1) S IBSBDT=IBBDT ; reset 1 day stays
     69 ;
     70 S IBS=IBSBDT-.01 F  S IBS=$O(^TMP($J,"IBCRC-PTF",IBS)) Q:'IBS  D SET S IBLASTDT=IBS Q:(IBLASTDT\1)>IBSEDT
     71 ;
     72 Q
     73 ;
     74SET ; checks a specific movement to determine if it should be billed and what the length of stay is
     75 ; setting of the movement date determines how many days are counted in the bedsection
     76 N IBMVLN,IBMBDT,IBMEDT,IBMTF,IBMLOS,IBI,IBCHGDT
     77 S IBMVLN=$G(^TMP($J,"IBCRC-PTF",IBS))
     78 I '$P(IBMVLN,U,2) Q  ;                                              non-billable bedsection
     79 I +$P(IBMVLN,U,3) Q  ;                                              sc movement
     80 I +IBINSMBS,+$G(IBLASTDT) Q  ;                                      ins does not allow multiple bs
     81 ;
     82 S IBMBDT=$S(IBBDT>$G(IBLASTDT):IBBDT,1:IBLASTDT),IBMBDT=IBMBDT\1 ;  start cnt on begin dt or last move dt
     83 S IBMEDT=$S(IBS<IBEDT:IBS,1:IBEDT),IBMEDT=IBMEDT\1 ;                end cnt on move dt or end dt
     84 S IBMTF=$S(IBEDT<(IBS\1):IBTF,1:1) ;                                last movement gets timeframe
     85 S IBMLOS=$$LOS^IBCU64(IBMBDT,IBMEDT,IBMTF,IBADM) Q:'IBMLOS  ;       calculate the LOS for the movement
     86 ;
     87 F IBI=1:1:IBMLOS S IBCHGDT=$$FMADD^XLFDT(IBMBDT,(IBI-1)),^TMP($J,"IBCRC-INDT",+IBCHGDT)=IBMVLN
     88 Q
     89 ;
     90BBS(X) ; returns true if pointer passed in is a billable bedsection ^ bedsection name
     91 N IBX,IBY S IBY=0,IBX=$G(^DGCR(399.1,+$G(X),0)) I +$P(IBX,U,5) S IBY=1_U_$P(IBX,U,1)
     92 Q IBY
     93 ;
     94 Q
     95 ;
     96PTFDV(PTF) ; find all ward/location transfers in PTF for the patient to determine the site/division the patient was in
     97 ; the division of the ward will be added to the PTF bedsection movements
     98 ; Input:   ^TMP($J,"IBCRC-PTF", move dt/tm) = move dt/tm ^ bill bs ^ sc flag ^ move drg ^^ specialty
     99 ; Output:  ^TMP($J,"IBCRC-PTF", move dt/tm) = move dt/tm ^ bill bs ^ sc flag ^ move drg ^ WARD DIV ^ specialty
     100 ;          ^TMP($J,"IBCRC-DIV", TRANSFER DATE/TIME) = WARD DIVISION
     101 N IBTRNSF,IBTRLN,IBENDDT,IBTRDV,IBMVDT,IBTRDT
     102 ;
     103 I '$O(^TMP($J,"IBCRC-PTF",0)) Q
     104 ;
     105 ; get all ward transfers
     106 S IBTRNSF=0 F  S IBTRNSF=$O(^DGPT(PTF,535,IBTRNSF)) Q:'IBTRNSF  D
     107 . S IBTRLN=$G(^DGPT(PTF,535,+IBTRNSF,0))
     108 . S IBENDDT=$P(IBTRLN,U,10) I 'IBENDDT S IBENDDT=DT ;                  transfer date (last date in ward)
     109 . S IBTRDV=$P($G(^DIC(42,+$P(IBTRLN,U,6),0)),U,11) Q:'IBTRDV  ;        losing ward division
     110 . S ^TMP($J,"IBCRC-DIV",IBENDDT)=IBTRDV
     111 ;
     112 ; if the ward transfer does not coincide with a specialty transfer add bedsection move on the transfer date
     113 S IBENDDT=0 F  S IBENDDT=$O(^TMP($J,"IBCRC-DIV",IBENDDT)) Q:'IBENDDT  D
     114 . S IBMVDT=$O(^TMP($J,"IBCRC-PTF",(IBENDDT-.0000001)))
     115 . I 'IBMVDT Q  ; - transfer movement dates after the discharge date in the PTF file (inconsistent)
     116 . I $P(IBENDDT,".")'=$P(IBMVDT,".") S ^TMP($J,"IBCRC-PTF",IBENDDT)=$G(^TMP($J,"IBCRC-PTF",IBMVDT))
     117 ;
     118 ; add the ward division to the bedsection/specialty
     119 S IBENDDT=0 F  S IBENDDT=$O(^TMP($J,"IBCRC-PTF",IBENDDT)) Q:'IBENDDT  D
     120 . S IBTRDT=$O(^TMP($J,"IBCRC-DIV",(IBENDDT-.0000001))) ;              ward transfer covering this bedsection
     121 . S IBTRDV=$G(^TMP($J,"IBCRC-DIV",+IBTRDT)) ;                         ward division
     122 . I +IBTRDV S $P(^TMP($J,"IBCRC-PTF",IBENDDT),U,5)=IBTRDV
     123 Q
     124 ;
     125MVDRG(PTF,M) ; Return the DRG for a specific PTF Movememt (M=move ifn)
     126 N DPT0,PTF0,PTFM0,PTF70,IBBEG,IBEND,IBDSST,IBDX,IBPRC0,IBPRC,IBDRG,IBI,IBJ,IBP
     127 N SEX,AGE,ICDDX,ICDPRC,ICDEXP,ICDDMS,ICDTRS,ICDDRG,ICDMDC,ICDRTC,ICDDATE
     128 S IBDRG=""
     129 ;
     130 S PTF0=$G(^DGPT(+$G(PTF),0)),DPT0=$G(^DPT(+$P(PTF0,U,1),0)) I DPT0="" G MVDRGQ
     131 S PTFM0=$G(^DGPT(+PTF,"M",+$G(M),0)) I 'PTFM0 G MVDRGQ
     132 S PTF70=$G(^DGPT(+PTF,70)),IBDSST=+$P(PTF70,U,3)
     133 ;
     134 S IBEND=+$P(PTFM0,U,10) I 'IBEND S IBEND=DT+.9
     135 S IBBEG=$O(^DGPT(+PTF,"M","AM",IBEND),-1) I 'IBBEG S IBBEG=$P(PTF0,U,2)
     136 ;
     137 S SEX=$P(DPT0,U,2)
     138 S AGE=$P(DPT0,U,3),AGE=$$FMDIFF^XLFDT(IBEND,AGE)\365.25
     139 ;
     140 S (ICDEXP,ICDDMS,ICDTRS)=0 I +PTF70,+PTF70=$P(PTFM0,U,10) D
     141 . I IBDSST>5 S ICDEXP=1 ;  patient expired
     142 . I IBDSST=4 S ICDDMS=1 ;  patient left against medical advice
     143 . I IBDSST=5,+$P(PTF70,U,13) S ICDTRS=1 ; patient transfered to another facility
     144 ;
     145 S IBJ=0 F IBI=5:1:9 S IBDX=$P(PTFM0,U,IBI) I +IBDX,($$ICD9^IBACSV(+IBDX)'="") S IBJ=IBJ+1,ICDDX(IBJ)=IBDX
     146 ;
     147 I '$O(ICDDX(0)) G MVDRGQ
     148 ;
     149 S IBJ=0
     150 S IBP=0 F  S IBP=$O(^DGPT(+PTF,"S",IBP)) Q:'IBP  D  ; surguries
     151 . S IBPRC0=$G(^DGPT(+PTF,"S",IBP,0)) Q:'IBPRC0
     152 . I +IBPRC0'<IBBEG,+IBPRC0'>IBEND D
     153 .. F IBI=8:1:12 S IBPRC=$P(IBPRC0,U,IBI) I +IBPRC,($$ICD0^IBACSV(+IBPRC)'="") S IBJ=IBJ+1,ICDPRC(IBJ)=+IBPRC
     154 ;
     155 S IBP=0 F  S IBP=$O(^DGPT(+PTF,"P",IBP)) Q:'IBP  D  ; procedures
     156 . S IBPRC0=$G(^DGPT(+PTF,"P",IBP,0)) Q:'IBPRC0
     157 . I +IBPRC0'<IBBEG,+IBPRC0'>IBEND D
     158 .. F IBI=5:1:9 S IBPRC=$P(IBPRC0,U,IBI) I +IBPRC,($$ICD0^IBACSV(+IBPRC)'="") S IBJ=IBJ+1,ICDPRC(IBJ)=+IBPRC
     159 ;
     160 S ICDDATE=$P(PTFM0,U,10) ; use the movement date for the DRG Grouper versioning
     161 D ^ICDDRG S IBDRG=$G(ICDDRG)
     162 ;
     163MVDRGQ Q IBDRG

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRBH1.m

    r613 r623  
    1 IBCRBH1 ;ALB/ARH - RATES: BILL HELP DISPLAYS - CHARGES ; 10-OCT-1998
    2         ;;2.0;INTEGRATED BILLING;**106,245,370**;21-MAR-94;Build 5
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5 DISPCHG(IBIFN)  ; display a bills items and their charges, display only, does not change the charges on the bill
    6         ;
    7         D BILL(IBIFN,1),SORTCI(IBIFN),DSPCHRG(1) ;     display auto add charges
    8         K ^TMP($J,"IBCRCC"),^TMP($J,"IBCRCSX"),^TMP($J,"IBCRCSXR"),^TMP($J,"IBCRCSXN")
    9         D BILL(IBIFN,""),SORTCI(IBIFN),DSPCHRG("") ;   display non-auto add charges
    10         K ^TMP($J,"IBCRCC"),^TMP($J,"IBCRCSX"),^TMP($J,"IBCRCSXR"),^TMP($J,"IBCRCSXN")
    11         D NOTES(IBIFN,1)
    12         Q
    13         ;
    14 BILL(IBIFN,IBAA,IBRSARR)        ; given a bill number calculate charges using schedules that match the auto add flag
    15         ; if IBRSARR is defined it will be used to create charges rather than the standard set for the bills Rate Type
    16         ; Output:  ^TMP($J,"IBCRCC" - same as would be calculated if the charges were being added to bill
    17         ;
    18         N IB0,IBU,IBBRT,IBBTYPE,IBCTYPE,IBRS,IBCS,IBBEVNT Q:'$G(IBIFN)
    19         K ^TMP($J,"IBCRCC")
    20         ;
    21         S IB0=$G(^DGCR(399,+IBIFN,0)) Q:IB0=""  S IBU=$G(^DGCR(399,+IBIFN,"U")) Q:'IBU
    22         S IBBRT=+$P(IB0,U,7),IBBTYPE=$S($P(IB0,U,5)<3:1,1:3),IBCTYPE=+$P(IB0,U,27)
    23         ;
    24         ; get standard set of all rate schedules and charge sets available for the bill
    25         I '$D(IBRSARR) D RT^IBCRU3(IBBRT,IBBTYPE,$P(IBU,U,1,2),.IBRSARR,"",IBCTYPE) I 'IBRSARR G END
    26         ;
    27         ; process charge sets - set all charges for the bill into array
    28         S IBRS=0 F  S IBRS=$O(IBRSARR(IBRS)) Q:'IBRS  D
    29         . S IBCS=0 F  S IBCS=$O(IBRSARR(IBRS,IBCS)) Q:'IBCS  I IBRSARR(IBRS,IBCS)=IBAA D
    30         .. S IBBEVNT=+$P($G(^IBE(363.1,+IBCS,0)),U,3) Q:'IBBEVNT  S IBBEVNT=$$EMUTL^IBCRU1(IBBEVNT) Q:IBBEVNT=""
    31         .. ;
    32         .. I IBBEVNT["INPATIENT BEDSECTION STAY" D INPTBS^IBCRBC1(IBIFN,IBRS,IBCS)
    33         .. I IBBEVNT["INPATIENT DRG" D INPTDRG^IBCRBC11(IBIFN,IBRS,IBCS)
    34         .. I IBBEVNT["OUTPATIENT VISIT DATE" D OPTVST^IBCRBC1(IBIFN,IBRS,IBCS)
    35         .. I IBBEVNT["PRESCRIPTION" D RX^IBCRBC1(IBIFN,IBRS,IBCS)
    36         .. I IBBEVNT["PROSTHETICS" D PI^IBCRBC1(IBIFN,IBRS,IBCS)
    37         .. I IBBEVNT["PROCEDURE" D CPT^IBCRBC1(IBIFN,IBRS,IBCS)
    38         ;
    39 END     Q
    40         ;
    41         ;
    42 SORTCI(IBIFN)   ; process charge array - create new array in sorted order with items combined, if possible
    43         ; if bs, rv cd, charge, cpt, div, item type, item ptr and component all match then charge is combined
    44         ; Input:  TMP($J,"IBCRCC",X) = ...  (from IBCRBC2)
    45         ; Output: TMP($J,"IBCRCSX",X) =
    46         ;         RV CD ^ BS ^ CHG ^ UNITS ^ CPT ^ DIV ^ ITM TYPE ^ ITM PTR ^ CHRG CMPNT ^ CHRG SET ^ EVNT DT ^ ITM NAME
    47         ;         TMP($J,"IBCRCSX",X,"CC",Y) = charge adjustment messages
    48         ;         TMP($J,"IBCRCSXR",BS,RV CD,X) = ""
    49         ;         TMP($J,"IBCRCSXN",DATE,ITEM NAME,X) = ""
    50         ;
    51         N IBI,IBLN,IBRVCD,IBBS,IBCHG,IBUNITS,IBCPT,IBDV,IBIT,IBIP,IBCMPT,IBCS,IBDT,IBNM,IBTUNITS,IBK,IBJ,IBX,IBY
    52         K ^TMP($J,"IBCRCSX"),^TMP($J,"IBCRCSXR"),^TMP($J,"IBCRCSXN")
    53         ;
    54         S IBI=0 F  S IBI=$O(^TMP($J,"IBCRCC",IBI)) Q:'IBI  D
    55         . ;
    56         . S IBLN=^TMP($J,"IBCRCC",IBI)
    57         . S IBRVCD=$P(IBLN,U,6),IBBS=$P(IBLN,U,7),IBCHG=+$FN($P(IBLN,U,12),"",2),IBUNITS=$P(IBLN,U,13)
    58         . S IBCPT=$P(IBLN,U,14),IBDV=$P(IBLN,U,15),IBIT=$P(IBLN,U,16),IBIP=$P(IBLN,U,17),IBCMPT=$P(IBLN,U,18)
    59         . S IBCS=$P(IBLN,U,2),IBDT=$P(IBLN,U,8),IBNM=$$ITMNM($G(IBIFN),IBBS,IBIT,IBIP,IBCPT)
    60         . ;
    61         . ; combine like charges, unless there are comments
    62         . S (IBTUNITS,IBK,IBJ)=0 F  S IBJ=$O(^TMP($J,"IBCRCSXR",+IBBS,+IBRVCD,IBJ)) Q:'IBJ  S IBK=IBJ D  Q:+IBTUNITS
    63         .. I $D(^TMP($J,"IBCRCC",IBI,"CC")) Q
    64         .. S IBX=$G(^TMP($J,"IBCRCSX",IBJ))
    65         .. I IBCHG=$P(IBX,U,3),IBCPT=$P(IBX,U,5),IBDV=$P(IBX,U,6),IBIT=$P(IBX,U,7),IBIP=$P(IBX,U,8),IBCMPT=$P(IBX,U,9) D
    66         ... S IBTUNITS=$P(IBX,U,4),IBDT=$P(IBX,U,11)
    67         . ;
    68         . I 'IBTUNITS S IBK=IBI ; no combination, new line item charge
    69         . S IBTUNITS=IBTUNITS+IBUNITS
    70         . ;
    71         . S ^TMP($J,"IBCRCSXR",+IBBS,+IBRVCD,IBK)=""
    72         . S ^TMP($J,"IBCRCSXN",IBDT_" ",IBNM_" ",IBK)=""
    73         . S ^TMP($J,"IBCRCSX",IBK)=IBRVCD_U_+IBBS_U_IBCHG_U_IBTUNITS_U_IBCPT_U_IBDV_U_IBIT_U_IBIP_U_IBCMPT_U_IBCS_U_IBDT_U_IBNM
    74         . S IBY=0 F  S IBY=$O(^TMP($J,"IBCRCC",IBI,"CC",IBY)) Q:'IBY  S ^TMP($J,"IBCRCSX",IBK,"CC",IBY)=^TMP($J,"IBCRCC",IBI,"CC",IBY)
    75         Q
    76         ;
    77 DSPCHRG(AA)     ; display charges
    78         ; Input: TMP($J,"IBCRCSx",...) = ... (from SORTCI)
    79         ;
    80         N IBX,IBI,IBJ,IBK,IBLN,IBCNT,IBRVCD,IBCHG,IBUNITS,IBDV,IBCMPT,IBCS,IBDT,IBNM,IBTOTAL,IBQUIT,IBY S (IBTOTAL,IBQUIT)=0
    81         ;
    82         D DSPHDR(AA) S IBCNT=4
    83         ;
    84         S IBI="" F  S IBI=$O(^TMP($J,"IBCRCSXN",IBI)) Q:IBI=""  D  Q:IBQUIT
    85         . S IBJ="" F  S IBJ=$O(^TMP($J,"IBCRCSXN",IBI,IBJ)) Q:IBJ=""  D  Q:IBQUIT
    86         .. S IBK=0 F  S IBK=$O(^TMP($J,"IBCRCSXN",IBI,IBJ,IBK)) Q:'IBK  D  Q:IBQUIT
    87         ... S IBLN=$G(^TMP($J,"IBCRCSX",IBK)) Q:IBLN=""
    88         ... ;
    89         ... ; add charges to RC multiple
    90         ... S IBRVCD=$P(IBLN,U,1),IBCHG=$P(IBLN,U,3),IBUNITS=$P(IBLN,U,4),IBDV=$P(IBLN,U,6)
    91         ... S IBCMPT=$P(IBLN,U,9),IBCS=$P(IBLN,U,10),IBDT=$P(IBLN,U,11),IBNM=$P(IBLN,U,12)
    92         ... S IBTOTAL=IBTOTAL+(IBCHG*IBUNITS),IBCNT=IBCNT+1
    93         ... ;
    94         ... S IBX=IBRVCD_U_IBCHG_U_IBUNITS_U_IBCMPT_U_IBCS_U_IBDT_U_IBDV_U_IBNM D DSPLN(IBX)
    95         ... ;
    96         ... S IBY=0 F  S IBY=$O(^TMP($J,"IBCRCSX",IBK,"CC",IBY)) Q:'IBY  D
    97         .... S IBX=$G(^TMP($J,"IBCRCSX",IBK,"CC",IBY)) I IBX'="" D DISPLNC(IBX) S IBCNT=IBCNT+1
    98         ... I $O(^TMP($J,"IBCRCSX",IBK,"CC",0)) D DISPLNC("") S IBCNT=IBCNT+1
    99         ... ;
    100         ... I IBCNT>20 S IBQUIT=$$PAUSE(IBCNT) Q:IBQUIT  D DSPHDR(AA) S IBCNT=4
    101         ;
    102         I +IBTOTAL W !,?72,"--------",!,?70,$J(IBTOTAL,10,2) S IBCNT=IBCNT+2
    103         I 'IBQUIT S IBQUIT=$$PAUSE(IBCNT)
    104         Q
    105         ;
    106 DSPHDR(AA)      ;
    107         W @IOF,!,"Items and Charges on this Bill ("_$S('AA:"NOT ",1:"")_"Auto Add)"
    108         W !,"Item",?18,"Date",?28,"Charge Set",?40,"Div",?47,"Type",?52,"RvCd",?57,"Units",?64,"Charge",?75,"Total"
    109         W !,"--------------------------------------------------------------------------------"
    110         Q
    111         ;
    112 DSPLN(LN)       ;
    113         N CS,DIV,CMP,RVCD,ITM,CHG,UNIT S LN=$G(LN)
    114         S CS=$P(LN,U,5) I +CS S CS=$P($G(^IBE(363.1,+$P(LN,U,5),0)),U,1)
    115         S DIV=$P($G(^DG(40.8,+$P(LN,U,7),0)),U,2)
    116         S CMP=$S($P(LN,U,4)=1:"INST",$P(LN,U,4)=2:"PROF",1:"")
    117         S RVCD=$P($G(^DGCR(399.2,+LN,0)),U,1)
    118         S ITM=$P(LN,U,8),CHG=+$P(LN,U,2),UNIT=$P(LN,U,3)
    119         W !,$E(ITM,1,15),?18,$$DATE($P(LN,U,6)),?28,$E(CS,1,7),?40,DIV,?47,CMP,?52,RVCD,?57,$J(UNIT,3),?62,$J(CHG,8,2),?71,$J((UNIT*CHG),9,2)
    120         Q
    121         ;
    122 DISPLNC(LN)     ; display charge adjustment commenmts
    123         W !,?18,$G(LN)
    124         Q
    125         ;
    126 DATE(X) ;
    127         S X=$G(X),X=$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3)
    128         Q X
    129         ;
    130 PAUSE(CNT)      ;
    131         N IBI F IBI=CNT:1:22 W !
    132         N DIR,DUOUT,DTOUT,DIRUT,IBX,X,Y S IBX=0,DIR(0)="E" D ^DIR K DIR I $D(DIRUT) S IBX=1
    133         Q IBX
    134         ;
    135 ITMNM(IBIFN,IBBS,IBIT,IBIP,IBCPT)       ; return external form of the item name
    136         N ITM S ITM="",IBBS=$G(IBBS),IBIT=$G(IBIT),IBIP=$G(IBIP),IBCPT=$G(IBCPT)
    137         I +IBIP S ITM=$$NAME^IBCSC61(IBIT,IBIP)
    138         I ITM="",+IBIT=4,+$G(IBIFN) S ITM=$$CPTNM(IBIFN,IBIT,IBIP)
    139         I ITM="",+IBCPT S ITM=$P($$CPT^ICPTCOD(+IBCPT,DT),U,2)
    140         I ITM="" S ITM=$$EMUTL^IBCRU1(IBBS)
    141         Q ITM
    142         ;
    143 CPTNM(IBIFN,TYPE,ITEM)  ; retrurn external name of the charge item if it is a CPT item (type=399,42,.1)
    144         N IBX,NAME S IBX=0,NAME=""
    145         I +$G(TYPE)=4 S IBX=$G(^DGCR(399,+$G(IBIFN),"CP",+$G(ITEM),0))
    146         I +IBX S NAME=$P($$CPT^ICPTCOD(+$P(IBX,U,1),DT),U,2)
    147         I +IBX S IBX=$$GETMOD^IBEFUNC(+$G(IBIFN),+$G(ITEM),1) I IBX'="" S NAME=NAME_"-"_IBX
    148         Q NAME
    149         ;
    150         ;
    151         ;
    152         ;
    153 NOTES(IBIFN,PAUSE)      ; compile and print charge notes for a bill
    154         ;
    155         ; Current Checks are for those Treating Specialties that should not be billed using DRG:
    156         ; - Inpatient Institutional Reasonable Charges bill contains SNF Treating Specialty
    157         ; - Inpatient Institutional Reasonable Charges bill contains Observation Treating Specialty
    158         ;
    159         I $D(ZTQUEUED)!(+$G(IBAUTO)) Q
    160         N IB0,IBU,PTF,BEG,END,IBMVLN,IBENDDT,IBMDRG,IBFND,IBMSG,IBX S IBFND=0 K ^TMP($J,"IBCRC-PTF")
    161         S IB0=$G(^DGCR(399,+$G(IBIFN),0)) Q:IB0=""  S IBU=$G(^DGCR(399,+$G(IBIFN),"U")) Q:'IBU
    162         ;
    163         I '$$BILLRATE^IBCRU3($P(IB0,U,7),$P(IB0,U,5),$P(IB0,U,3),"RC") Q  ; not Reasonable Charges bill
    164         ;
    165         ; Outpatient Freestanding bill: display message if this is a non-provider based freestanding bill
    166         I $P(IB0,U,5)=3,$P(IB0,U,3)'<$$VERSDT^IBCRU8(2),$P($$RCDV^IBCRU8(+$P(IB0,U,22)),U,3)=3 D
    167         . S IBFND=IBFND+1,IBX=">>> Bill Division is Freestanding Non-Provider with Professional Charges only.",IBMSG(IBFND)=IBX
    168         ;
    169         ; Inpatient Institutional bill: check for treating specialties that should not be billed by DRG
    170         I +$P(IB0,U,8),$P(IB0,U,5)<3,$P(IB0,U,27)<2 D
    171         . ;
    172         . S PTF=+$P(IB0,U,8),BEG=+$P(IBU,U,1)\1,END=$S(+$P(IBU,U,2):+$P(IBU,U,2)\1,1:DT)
    173         . ;
    174         . D PTF^IBCRBG(PTF)
    175         . ;
    176         . S IBENDDT=BEG F  S IBENDDT=$O(^TMP($J,"IBCRC-PTF",IBENDDT)) Q:'IBENDDT  D  I IBENDDT>END Q
    177         .. I (IBENDDT\1)=BEG,BEG'=END Q
    178         .. ;
    179         .. S IBMVLN=$G(^TMP($J,"IBCRC-PTF",IBENDDT)),IBMVLN=+$P(IBMVLN,U,6) Q:'IBMVLN
    180         .. S IBMDRG=$$NODRG^IBCRBG2(IBMVLN) Q:'IBMDRG
    181         .. ;
    182         .. S IBFND=IBFND+1,IBX=">>> "_$P(IBMDRG,U,2)_" ("_$$FMTE^XLFDT(IBENDDT,2)_") not billed using DRG"
    183         .. S:IBMDRG["Nursing" IBX=IBX_", use SNF." S:IBMDRG["Observa" IBX=IBX_", use Procedures."
    184         .. S IBMSG(IBFND)=$G(IBX)
    185         ;
    186         I +IBFND D  I +$G(PAUSE) S IBFND=$$PAUSE(21)
    187         . W ! S IBX="" F  S IBX=$O(IBMSG(IBX)) Q:IBX=""  W !,IBMSG(IBX)
    188         K ^TMP($J,"IBCRC-PTF")
    189         Q
     1IBCRBH1 ;ALB/ARH - RATES: BILL HELP DISPLAYS - CHARGES ; 10-OCT-1998
     2 ;;2.0;INTEGRATED BILLING;**106,245**;21-MAR-94
     3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
     4 ;
     5DISPCHG(IBIFN) ; display a bills items and their charges, display only, does not change the charges on the bill
     6 ;
     7 D BILL(IBIFN,1),SORTCI(IBIFN),DSPCHRG(1) ;     display auto add charges
     8 K ^TMP($J,"IBCRCC"),^TMP($J,"IBCRCSX"),^TMP($J,"IBCRCSXR"),^TMP($J,"IBCRCSXN")
     9 D BILL(IBIFN,""),SORTCI(IBIFN),DSPCHRG("") ;   display non-auto add charges
     10 K ^TMP($J,"IBCRCC"),^TMP($J,"IBCRCSX"),^TMP($J,"IBCRCSXR"),^TMP($J,"IBCRCSXN")
     11 D NOTES(IBIFN,1)
     12 Q
     13 ;
     14BILL(IBIFN,IBAA,IBRSARR) ; given a bill number calculate charges using schedules that match the auto add flag
     15 ; if IBRSARR is defined it will be used to create charges rather than the standard set for the bills Rate Type
     16 ; Output:  ^TMP($J,"IBCRCC" - same as would be calculated if the charges were being added to bill
     17 ;
     18 N IB0,IBU,IBBRT,IBBTYPE,IBCTYPE,IBRS,IBCS,IBBEVNT Q:'$G(IBIFN)
     19 K ^TMP($J,"IBCRCC")
     20 ;
     21 S IB0=$G(^DGCR(399,+IBIFN,0)) Q:IB0=""  S IBU=$G(^DGCR(399,+IBIFN,"U")) Q:'IBU
     22 S IBBRT=+$P(IB0,U,7),IBBTYPE=$S($P(IB0,U,5)<3:1,1:3),IBCTYPE=+$P(IB0,U,27)
     23 ;
     24 ; get standard set of all rate schedules and charge sets available for the bill
     25 I '$D(IBRSARR) D RT^IBCRU3(IBBRT,IBBTYPE,$P(IBU,U,1,2),.IBRSARR,"",IBCTYPE) I 'IBRSARR G END
     26 ;
     27 ; process charge sets - set all charges for the bill into array
     28 S IBRS=0 F  S IBRS=$O(IBRSARR(IBRS)) Q:'IBRS  D
     29 . S IBCS=0 F  S IBCS=$O(IBRSARR(IBRS,IBCS)) Q:'IBCS  I IBRSARR(IBRS,IBCS)=IBAA D
     30 .. S IBBEVNT=+$P($G(^IBE(363.1,+IBCS,0)),U,3) Q:'IBBEVNT  S IBBEVNT=$$EMUTL^IBCRU1(IBBEVNT) Q:IBBEVNT=""
     31 .. ;
     32 .. I IBBEVNT["INPATIENT BEDSECTION STAY" D INPTBS^IBCRBC1(IBIFN,IBRS,IBCS)
     33 .. I IBBEVNT["INPATIENT DRG" D INPTDRG^IBCRBC11(IBIFN,IBRS,IBCS)
     34 .. I IBBEVNT["OUTPATIENT VISIT DATE" D OPTVST^IBCRBC1(IBIFN,IBRS,IBCS)
     35 .. I IBBEVNT["PRESCRIPTION" D RX^IBCRBC1(IBIFN,IBRS,IBCS)
     36 .. I IBBEVNT["PROSTHETICS" D PI^IBCRBC1(IBIFN,IBRS,IBCS)
     37 .. I IBBEVNT["PROCEDURE" D CPT^IBCRBC1(IBIFN,IBRS,IBCS)
     38 ;
     39 I '$D(^TMP($J,"IBCRCC")) G END
     40 ;
     41 D MULTCPT^IBCRBCA1
     42 D PSB^IBCRBCA2
     43 D MODADJ^IBCRBCA3
     44 ;
     45END Q
     46 ;
     47 ;
     48SORTCI(IBIFN) ; process charge array - create new array in sorted order with items combined, if possible
     49 ; if bs, rv cd, charge, cpt, div, item type, item ptr and component all match then charge is combined
     50 ; Input:  TMP($J,"IBCRCC",X) = ...  (from IBCRBC2)
     51 ; Output: TMP($J,"IBCRCSX",X) =
     52 ;         RV CD ^ BS ^ CHG ^ UNITS ^ CPT ^ DIV ^ ITM TYPE ^ ITM PTR ^ CHRG CMPNT ^ CHRG SET ^ EVNT DT ^ ITM NAME
     53 ;         TMP($J,"IBCRCSX",X,"CC",Y) = charge adjustment messages
     54 ;         TMP($J,"IBCRCSXR",BS,RV CD,X) = ""
     55 ;         TMP($J,"IBCRCSXN",DATE,ITEM NAME,X) = ""
     56 ;
     57 N IBI,IBLN,IBRVCD,IBBS,IBCHG,IBUNITS,IBCPT,IBDV,IBIT,IBIP,IBCMPT,IBCS,IBDT,IBNM,IBTUNITS,IBK,IBJ,IBX,IBY
     58 K ^TMP($J,"IBCRCSX"),^TMP($J,"IBCRCSXR"),^TMP($J,"IBCRCSXN")
     59 ;
     60 S IBI=0 F  S IBI=$O(^TMP($J,"IBCRCC",IBI)) Q:'IBI  D
     61 . ;
     62 . S IBLN=^TMP($J,"IBCRCC",IBI)
     63 . S IBRVCD=$P(IBLN,U,6),IBBS=$P(IBLN,U,7),IBCHG=+$FN($P(IBLN,U,12),"",2),IBUNITS=$P(IBLN,U,13)
     64 . S IBCPT=$P(IBLN,U,14),IBDV=$P(IBLN,U,15),IBIT=$P(IBLN,U,16),IBIP=$P(IBLN,U,17),IBCMPT=$P(IBLN,U,18)
     65 . S IBCS=$P(IBLN,U,2),IBDT=$P(IBLN,U,8),IBNM=$$ITMNM($G(IBIFN),IBBS,IBIT,IBIP,IBCPT)
     66 . ;
     67 . ; combine like charges, unless there are comments
     68 . S (IBTUNITS,IBK,IBJ)=0 F  S IBJ=$O(^TMP($J,"IBCRCSXR",+IBBS,+IBRVCD,IBJ)) Q:'IBJ  S IBK=IBJ D  Q:+IBTUNITS
     69 .. I $D(^TMP($J,"IBCRCC",IBI,"CC")) Q
     70 .. S IBX=$G(^TMP($J,"IBCRCSX",IBJ))
     71 .. I IBCHG=$P(IBX,U,3),IBCPT=$P(IBX,U,5),IBDV=$P(IBX,U,6),IBIT=$P(IBX,U,7),IBIP=$P(IBX,U,8),IBCMPT=$P(IBX,U,9) D
     72 ... S IBTUNITS=$P(IBX,U,4),IBDT=$P(IBX,U,11)
     73 . ;
     74 . I 'IBTUNITS S IBK=IBI ; no combination, new line item charge
     75 . S IBTUNITS=IBTUNITS+IBUNITS
     76 . ;
     77 . S ^TMP($J,"IBCRCSXR",+IBBS,+IBRVCD,IBK)=""
     78 . S ^TMP($J,"IBCRCSXN",IBDT_" ",IBNM_" ",IBK)=""
     79 . S ^TMP($J,"IBCRCSX",IBK)=IBRVCD_U_+IBBS_U_IBCHG_U_IBTUNITS_U_IBCPT_U_IBDV_U_IBIT_U_IBIP_U_IBCMPT_U_IBCS_U_IBDT_U_IBNM
     80 . S IBY=0 F  S IBY=$O(^TMP($J,"IBCRCC",IBI,"CC",IBY)) Q:'IBY  S ^TMP($J,"IBCRCSX",IBK,"CC",IBY)=^TMP($J,"IBCRCC",IBI,"CC",IBY)
     81 Q
     82 ;
     83DSPCHRG(AA) ; display charges
     84 ; Input: TMP($J,"IBCRCSx",...) = ... (from SORTCI)
     85 ;
     86 N IBX,IBI,IBJ,IBK,IBLN,IBCNT,IBRVCD,IBCHG,IBUNITS,IBDV,IBCMPT,IBCS,IBDT,IBNM,IBTOTAL,IBQUIT,IBY S (IBTOTAL,IBQUIT)=0
     87 ;
     88 D DSPHDR(AA) S IBCNT=4
     89 ;
     90 S IBI="" F  S IBI=$O(^TMP($J,"IBCRCSXN",IBI)) Q:IBI=""  D  Q:IBQUIT
     91 . S IBJ="" F  S IBJ=$O(^TMP($J,"IBCRCSXN",IBI,IBJ)) Q:IBJ=""  D  Q:IBQUIT
     92 .. S IBK=0 F  S IBK=$O(^TMP($J,"IBCRCSXN",IBI,IBJ,IBK)) Q:'IBK  D  Q:IBQUIT
     93 ... S IBLN=$G(^TMP($J,"IBCRCSX",IBK)) Q:IBLN=""
     94 ... ;
     95 ... ; add charges to RC multiple
     96 ... S IBRVCD=$P(IBLN,U,1),IBCHG=$P(IBLN,U,3),IBUNITS=$P(IBLN,U,4),IBDV=$P(IBLN,U,6)
     97 ... S IBCMPT=$P(IBLN,U,9),IBCS=$P(IBLN,U,10),IBDT=$P(IBLN,U,11),IBNM=$P(IBLN,U,12)
     98 ... S IBTOTAL=IBTOTAL+(IBCHG*IBUNITS),IBCNT=IBCNT+1
     99 ... ;
     100 ... S IBX=IBRVCD_U_IBCHG_U_IBUNITS_U_IBCMPT_U_IBCS_U_IBDT_U_IBDV_U_IBNM D DSPLN(IBX)
     101 ... ;
     102 ... S IBY=0 F  S IBY=$O(^TMP($J,"IBCRCSX",IBK,"CC",IBY)) Q:'IBY  D
     103 .... S IBX=$G(^TMP($J,"IBCRCSX",IBK,"CC",IBY)) I IBX'="" D DISPLNC(IBX) S IBCNT=IBCNT+1
     104 ... I $O(^TMP($J,"IBCRCSX",IBK,"CC",0)) D DISPLNC("") S IBCNT=IBCNT+1
     105 ... ;
     106 ... I IBCNT>20 S IBQUIT=$$PAUSE(IBCNT) Q:IBQUIT  D DSPHDR(AA) S IBCNT=4
     107 ;
     108 I +IBTOTAL W !,?72,"--------",!,?70,$J(IBTOTAL,10,2) S IBCNT=IBCNT+2
     109 I 'IBQUIT S IBQUIT=$$PAUSE(IBCNT)
     110 Q
     111 ;
     112DSPHDR(AA) ;
     113 W @IOF,!,"Items and Charges on this Bill ("_$S('AA:"NOT ",1:"")_"Auto Add)"
     114 W !,"Item",?18,"Date",?28,"Charge Set",?40,"Div",?47,"Type",?52,"RvCd",?57,"Units",?64,"Charge",?75,"Total"
     115 W !,"--------------------------------------------------------------------------------"
     116 Q
     117 ;
     118DSPLN(LN) ;
     119 N CS,DIV,CMP,RVCD,ITM,CHG,UNIT S LN=$G(LN)
     120 S CS=$P(LN,U,5) I +CS S CS=$P($G(^IBE(363.1,+$P(LN,U,5),0)),U,1)
     121 S DIV=$P($G(^DG(40.8,+$P(LN,U,7),0)),U,2)
     122 S CMP=$S($P(LN,U,4)=1:"INST",$P(LN,U,4)=2:"PROF",1:"")
     123 S RVCD=$P($G(^DGCR(399.2,+LN,0)),U,1)
     124 S ITM=$P(LN,U,8),CHG=+$P(LN,U,2),UNIT=$P(LN,U,3)
     125 W !,$E(ITM,1,15),?18,$$DATE($P(LN,U,6)),?28,$E(CS,1,7),?40,DIV,?47,CMP,?52,RVCD,?57,$J(UNIT,3),?62,$J(CHG,8,2),?71,$J((UNIT*CHG),9,2)
     126 Q
     127 ;
     128DISPLNC(LN) ; display charge adjustment commenmts
     129 W !,?18,$G(LN)
     130 Q
     131 ;
     132DATE(X) ;
     133 S X=$G(X),X=$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3)
     134 Q X
     135 ;
     136PAUSE(CNT) ;
     137 N IBI F IBI=CNT:1:22 W !
     138 N DIR,DUOUT,DTOUT,DIRUT,IBX,X,Y S IBX=0,DIR(0)="E" D ^DIR K DIR I $D(DIRUT) S IBX=1
     139 Q IBX
     140 ;
     141ITMNM(IBIFN,IBBS,IBIT,IBIP,IBCPT) ; return external form of the item name
     142 N ITM S ITM="",IBBS=$G(IBBS),IBIT=$G(IBIT),IBIP=$G(IBIP),IBCPT=$G(IBCPT)
     143 I +IBIP S ITM=$$NAME^IBCSC61(IBIT,IBIP)
     144 I ITM="",+IBIT=4,+$G(IBIFN) S ITM=$$CPTNM(IBIFN,IBIT,IBIP)
     145 I ITM="",+IBCPT S ITM=$P($$CPT^ICPTCOD(+IBCPT,DT),U,2)
     146 I ITM="" S ITM=$$EMUTL^IBCRU1(IBBS)
     147 Q ITM
     148 ;
     149CPTNM(IBIFN,TYPE,ITEM) ; retrurn external name of the charge item if it is a CPT item (type=399,42,.1)
     150 N IBX,NAME S IBX=0,NAME=""
     151 I +$G(TYPE)=4 S IBX=$G(^DGCR(399,+$G(IBIFN),"CP",+$G(ITEM),0))
     152 I +IBX S NAME=$P($$CPT^ICPTCOD(+$P(IBX,U,1),DT),U,2)
     153 I +IBX S IBX=$$GETMOD^IBEFUNC(+$G(IBIFN),+$G(ITEM),1) I IBX'="" S NAME=NAME_"-"_IBX
     154 Q NAME
     155 ;
     156 ;
     157 ;
     158 ;
     159NOTES(IBIFN,PAUSE) ; compile and print charge notes for a bill
     160 ;
     161 ; Current Checks are for those Treating Specialties that should not be billed using DRG:
     162 ; - Inpatient Institutional Reasonable Charges bill contains SNF Treating Specialty
     163 ; - Inpatient Institutional Reasonable Charges bill contains Observation Treating Specialty
     164 ;
     165 I $D(ZTQUEUED)!(+$G(IBAUTO)) Q
     166 N IB0,IBU,PTF,BEG,END,IBMVLN,IBENDDT,IBMDRG,IBFND,IBMSG,IBX S IBFND=0 K ^TMP($J,"IBCRC-PTF")
     167 S IB0=$G(^DGCR(399,+$G(IBIFN),0)) Q:IB0=""  S IBU=$G(^DGCR(399,+$G(IBIFN),"U")) Q:'IBU
     168 ;
     169 I '$$BILLRATE^IBCRU3($P(IB0,U,7),$P(IB0,U,5),$P(IB0,U,3),"RC") Q  ; not Reasonable Charges bill
     170 ;
     171 ; Outpatient Freestanding bill: display message if this is a non-provider based freestanding bill
     172 I $P(IB0,U,5)=3,$P(IB0,U,3)'<$$VERSDT^IBCRU8(2),$P($$RCDV^IBCRU8(+$P(IB0,U,22)),U,3)=3 D
     173 . S IBFND=IBFND+1,IBX=">>> Bill Division is Freestanding Non-Provider with Professional Charges only.",IBMSG(IBFND)=IBX
     174 ;
     175 ; Inpatient Institutional bill: check for treating specialties that should not be billed by DRG
     176 I +$P(IB0,U,8),$P(IB0,U,5)<3,$P(IB0,U,27)<2 D
     177 . ;
     178 . S PTF=+$P(IB0,U,8),BEG=+$P(IBU,U,1)\1,END=$S(+$P(IBU,U,2):+$P(IBU,U,2)\1,1:DT)
     179 . ;
     180 . D PTF^IBCRBG(PTF)
     181 . ;
     182 . S IBENDDT=BEG F  S IBENDDT=$O(^TMP($J,"IBCRC-PTF",IBENDDT)) Q:'IBENDDT  D  I IBENDDT>END Q
     183 .. I (IBENDDT\1)=BEG,BEG'=END Q
     184 .. ;
     185 .. S IBMVLN=$G(^TMP($J,"IBCRC-PTF",IBENDDT)),IBMVLN=+$P(IBMVLN,U,6) Q:'IBMVLN
     186 .. S IBMDRG=$$NODRG^IBCRBG2(IBMVLN) Q:'IBMDRG
     187 .. ;
     188 .. S IBFND=IBFND+1,IBX=">>> "_$P(IBMDRG,U,2)_" ("_$$FMTE^XLFDT(IBENDDT,2)_") not billed using DRG"
     189 .. S:IBMDRG["Nursing" IBX=IBX_", use SNF." S:IBMDRG["Observa" IBX=IBX_", use Procedures."
     190 .. S IBMSG(IBFND)=$G(IBX)
     191 ;
     192 I +IBFND D  I +$G(PAUSE) S IBFND=$$PAUSE(21)
     193 . W ! S IBX="" F  S IBX=$O(IBMSG(IBX)) Q:IBX=""  W !,IBMSG(IBX)
     194 K ^TMP($J,"IBCRC-PTF")
     195 Q

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRCC.m

    r613 r623  
    1 IBCRCC  ;ALB/ARH - RATES: CALCULATION OF ITEM CHARGE ;22-MAY-1996
    2         ;;2.0;INTEGRATED BILLING;**52,80,106,138,245,223,309,347,370**;21-MAR-94;Build 5
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5         ; ITMCHG and RATECHG are basic item/set/rate charge functions, IBCRCI contains more standard callable functions
    6         ;
    7 ITMCHG(CS,ITEM,EVDT,MOD,ARR)    ; get the base unit charges for a specific item, given a charge set, item and date
    8         ; this is the primary function to get an item charge and works for all Charge Methods, given an Item
    9         ; returns ARR = count of items in array ^ total charge for item ^ total base charge
    10         ;         ARR(x) = charge item IFN (if any) ^ rev code (if any) ^ $ charge ^ $ base charge
    11         ; checks Item effective and inactive dates, modifier match, and only sets array if the charge is non-zero
    12         ; each item will be passed back separately in the array, no combination of charges
    13         ;
    14         N IBCSBR,IBEVDT,IBEFDT,IBXREF,IBITEM,IBDA,IBLN,IBCHRG,IBITMFND K ARR S ARR=0
    15         S CS=+$G(CS),IBEVDT=$S(+$G(EVDT):+EVDT,1:DT),IBITEM=+$G(ITEM),MOD=$G(MOD) I 'CS!'IBITEM Q
    16         S IBCSBR=$$CSBR^IBCRU3(CS)
    17         ;
    18         ; va cost
    19         I $P(IBCSBR,U,5)=2 D  Q  ; va cost
    20         . I $P(IBCSBR,U,1)["PROSTHETICS" S IBCHRG=$$PICOST(IBITEM)  I +IBCHRG D SETARR(0,0,+IBCHRG,.ARR) Q
    21         . I $P(IBCSBR,U,1)["PRESCRIPTION" S IBCHRG=$$RXCOST(IBITEM) I +IBCHRG D SETARR(0,0,+IBCHRG,.ARR) Q
    22         ;
    23         ; all others - have Charge Item entries
    24         ;
    25         ; find most recent Charge Item for the item, search until modifiers match (only BI=CPT should have mods defined)
    26         S IBXREF="AIVDTS"_CS,IBITMFND=0
    27         S IBEFDT=-(IBEVDT+.01) F  S IBEFDT=$O(^IBA(363.2,IBXREF,IBITEM,IBEFDT)) Q:'IBEFDT  D  Q:IBITMFND
    28         . S IBDA=0 F  S IBDA=$O(^IBA(363.2,IBXREF,IBITEM,IBEFDT,IBDA)) Q:'IBDA  D
    29         .. S IBLN=$G(^IBA(363.2,IBDA,0))
    30         .. I +$P(IBLN,U,7)'=+MOD Q  ; charge item modifier does not match modifier passed in
    31         .. S IBITMFND=1 ; item found
    32         .. I +$P(IBLN,U,4),+$P(IBLN,U,4)<IBEVDT Q  ; charge is inactive on event date
    33         .. I +$P(IBLN,U,5) D SETARR(IBDA,+$P(IBLN,U,6),+$P(IBLN,U,5),.ARR,$P(IBLN,U,8))
    34         Q
    35         ;
    36 SETARR(CI,RVCD,CHRG,ARR,CHRGB)  ; set charges into an array, does not allow zero charge, a new entry is created each time,
    37         ; no attempt to combine like items, the new item charge is added to any that may already be in the array
    38         ; returns ARR = count of items in array ^ total charge for item
    39         ;         ARR(x) = charge item IFN (if any) ^ item rev code (if any) ^ $ charge
    40         ;
    41         N CNT,TCHRG,TCHRGB
    42         S CNT=+$G(ARR)+1,TCHRG=$P($G(ARR),U,2)+$G(CHRG) I +$G(CHRGB) S TCHRGB=+$P($G(ARR),U,3)+CHRGB
    43         I +$G(CHRG) S ARR=CNT_U_+TCHRG_U_$G(TCHRGB),ARR(CNT)=$G(CI)_U_+$G(RVCD)_U_+CHRG_U_$G(TCHRGB)
    44         Q
    45         ;
    46 PICOST(PI)      ; returns (PI=ptr 362.5): total VA cost of an item (660,14) ^ quantity (660,5) from prosthetics ^ bill IFN
    47         ;
    48         N IBPIP,IBLN,IBX,IBIFN S (IBPIP,IBX)=0
    49         I +$G(PI) S IBLN=$G(^IBA(362.5,+PI,0)),IBPIP=$P(IBLN,U,4),IBIFN=$P(IBLN,U,2)
    50         I +IBPIP S IBLN=$G(^RMPR(660,+IBPIP,0)) I IBLN'="" S IBX=$P(IBLN,U,16)_U_$P(IBLN,U,7)_U_IBIFN
    51         Q IBX
    52         ;
    53 RATECHG(RS,CHG,EVDT,FEE)        ; returns modifed item charge based on rate schedule:  check effective dates, apply adjustment
    54         ; adjusted amount ^ comment (if there is an adjustment)
    55         ; if FEE passed by reference, returns disp fee^admin fee
    56         ;
    57         N IBX,IBRS0,IBRS10,IBEFDT,IBINADT,IBRTY,X S IBRTY=""
    58         S IBX=+$G(CHG),IBRS0=$G(^IBE(363,+$G(RS),0)),IBRS10=$G(^IBE(363,+$G(RS),10))
    59         S EVDT=$S(+$G(EVDT):EVDT,1:DT),IBEFDT=$P(IBRS0,U,5),IBINADT=$P(IBRS0,U,6)
    60         I +IBEFDT>EVDT!(+IBINADT&(IBINADT<EVDT)) S IBX=0
    61         I +IBX,IBRS10'="" S X=IBX X IBRS10 S IBX=X,IBRTY="^Rate Schedule Adjustment ("_$J(CHG,"",2)_")"
    62         S FEE=$P($G(^IBE(363,+$G(RS),1)),"^",1,2)
    63         Q IBX_IBRTY
    64         ;
    65 RXCOST(RX)      ; returns (RX=ptr 362.4): VA Cost of an Rx - Per Unit Cost ^ bill IFN
    66         ; w/ Per Unit Cost = RX (Unit Price of Drug - 52,17) or Drug (Price Per Dispense Unit 50,16) cost
    67         ;
    68         N IBRXP,IBDGP,IBLN,IBX,IBIFN S (IBRXP,IBX)=0
    69         I +$G(RX) S IBLN=$G(^IBA(362.4,+RX,0)),IBRXP=$P(IBLN,U,5),IBDGP=$P(IBLN,U,4),IBIFN=$P(IBLN,U,2)
    70         I +IBRXP S IBX=$$FILE^IBRXUTL(IBRXP,17)_U_IBIFN
    71         I 'IBRXP,+IBDGP D DATA^IBRXUTL(+IBDGP) S IBLN=$G(^TMP($J,"IBDRUG",0)) I IBLN'="" S IBX=$G(^TMP($J,"IBDRUG",+IBDGP,16))_U_IBIFN
    72         K ^TMP($J,"IBDRUG")
    73         Q IBX
    74         ;
    75 PRVCHG(CS,CHG,PRV,EVDT,ITEM)    ; return discounted amount, based on total charge for a the care, the provider and Charge Set (BR)
    76         ; if no discount record found for the Charge Set or the provider then returns original amount
    77         ; no provider discount for Lab charges (80000-89999)
    78         ;   discounted amount ^ comment (if discounted) ^ percent discount
    79         ;
    80         N IBPC,IBSGFN,IBSG,IBPDFN,IBPD0,IBPDTY,IBI,IBX,IBY S IBX=+$G(CHG),(IBSGFN,IBPDTY)="" I '$G(EVDT) S EVDT=DT
    81         I +$G(ITEM),ITEM>79999,ITEM<90000 S (CS,PRV)=""
    82         I +$G(CS) S IBSGFN=+$$CSSG^IBCRU6(+CS,"",2,.IBSG)
    83         I +$G(PRV),+IBSGFN S IBPC=$$GET^XUA4A72(PRV,EVDT)
    84         ;
    85         S IBI=0 F  S IBI=$O(IBSG(IBI)) Q:'IBI  S IBSGFN=+IBSG(IBI) I +IBSGFN D
    86         . S IBPDFN=0 F  S IBPDFN=$O(^IBE(363.34,"C",+IBSGFN,IBPDFN)) Q:'IBPDFN  D  Q:IBPDTY'=""
    87         .. I '$O(^IBE(363.34,+IBPDFN,11,"B",+IBPC,0)) Q
    88         .. S IBPD0=$G(^IBE(363.34,+IBPDFN,0)),IBY=$P(IBPD0,U,3) Q:IBY=""
    89         .. S IBY=+IBY/100,IBX=IBY*IBX
    90         .. S IBPDTY=U_$P($G(^VA(200,+PRV,0)),U,1)_" - "_$P(IBPD0,U,1)_" "_$P(IBPD0,U,3)_"% of "_$J(CHG,0,2)_U_+IBY
    91         Q IBX_IBPDTY
    92         ;
    93 MODCHG(CS,CHG,MODS)     ; return adjusted amount due to RC modifier adjustment
    94         ; straight adjustment for RC Physician charges by modifier, if no modifier adjustment returns original amount
    95         ; Input:  Charge Set, Procedure Charge, Modifiers - list with modifier IEN's separated by ','
    96         ; Output: discounted amount ^ comment (if discounted) ^ percent discount
    97         ;
    98         N IBCS0,IBBR0,IBMOD,IBMODS,IBMODE,IBDSCNT,IBPDTY,IBI,IBX,IBY
    99         S CHG=+$G(CHG),MODS=$G(MODS),(IBBR0,IBPDTY,IBMODS)="",IBDSCNT=1,IBX=+CHG
    100         I +$G(CS) S IBCS0=$G(^IBE(363.1,+CS,0)),IBBR0=$G(^IBE(363.3,+$P(IBCS0,U,2),0))
    101         I $P(IBBR0,U,1)'["RC PHYSICIAN" S MODS="" ; professional charge only
    102         I $P(IBBR0,U,4)'=2 S MODS="" ; CPT item only
    103         I 'CHG S MODS=""
    104         ;
    105         I +MODS F IBI=1:1 S IBMOD=$P(MODS,",",IBI) Q:'IBMOD  S IBY=0 D
    106         . I IBMOD=3 S IBMODE=22,IBY=1.2,IBX=IBX*IBY ; modifier 22 at 120% adjustment
    107         . I IBMOD=10 S IBMODE=50,IBY=1.54,IBX=IBX*IBY ; modifier 50 at 154% adjustment
    108         . I +IBY S IBMODS=IBMODS_$S(IBMODS="":"",1:",")_IBMODE,IBDSCNT=IBDSCNT*IBY ; allow for multiple discounts
    109         I IBMODS'="" S IBPDTY=U_"Modifier "_IBMODS_" Adjustment "_(IBDSCNT*100)_"% of "_$J(CHG,0,2)_U_+IBDSCNT
    110         Q IBX_IBPDTY
    111         ;
    112 HRUNIT(HRS)     ; returns Hour Units based on the Hours passed in
    113         ; Hour Units are the hours rounded to the nearest whole hour (less than 30 minutes is 0 units)
    114         N IBX S IBX=0 I +$G(HRS) S IBX=$J(HRS,0,0)
    115         Q IBX
    116         ;
    117 MLUNIT(MLS)     ; returns Miles Units based on the Miles passed in
    118         ; Mile Units are the miles rounded to the nearest whole mile
    119         N IBX S IBX=0 I +$G(MLS) S IBX=$J(MLS,0,0) I 'IBX S IBX=1
    120         Q IBX
    121         ;
    122 MNUNIT(MNS)     ; return Minute Units based on the Minutes passed in
    123         ; Minute Units are 15 minute intervals, rounded up after any minutes
    124         N IBX S IBX=0 I +$G(MNS) S IBX=(MNS\15) S:+(MNS#15) IBX=IBX+1 I 'IBX S IBX=1
    125         Q IBX
     1IBCRCC ;ALB/ARH - RATES: CALCULATION OF ITEM CHARGE ;22-MAY-1996
     2 ;;2.0;INTEGRATED BILLING;**52,80,106,138,245,223,309,347**;21-MAR-94;Build 24
     3 ;;Per VHA Directive 2004-038, this routine should not be modified.
     4 ;
     5 ; ITMCHG and RATECHG are basic item/set/rate charge functions, IBCRCI contains more standard callable functions
     6 ;
     7ITMCHG(CS,ITEM,EVDT,MOD,ARR) ; get the base unit charges for a specific item, given a charge set, item and date
     8 ; this is the primary function to get an item charge and works for all Charge Methods, given an Item
     9 ; returns ARR = count of items in array ^ total charge for item ^ total base charge
     10 ;         ARR(x) = charge item IFN (if any) ^ rev code (if any) ^ $ charge ^ $ base charge
     11 ; checks Item effective and inactive dates, modifier match, and only sets array if the charge is non-zero
     12 ; each item will be passed back separately in the array, no combination of charges
     13 ;
     14 N IBCSBR,IBEVDT,IBEFDT,IBXREF,IBITEM,IBDA,IBLN,IBCHRG,IBITMFND K ARR S ARR=0
     15 S CS=+$G(CS),IBEVDT=$S(+$G(EVDT):+EVDT,1:DT),IBITEM=+$G(ITEM),MOD=$G(MOD) I 'CS!'IBITEM Q
     16 S IBCSBR=$$CSBR^IBCRU3(CS)
     17 ;
     18 ; va cost
     19 I $P(IBCSBR,U,5)=2 D  Q  ; va cost
     20 . I $P(IBCSBR,U,1)["PROSTHETICS" S IBCHRG=$$PICOST(IBITEM)  I +IBCHRG D SETARR(0,0,+IBCHRG,.ARR) Q
     21 . I $P(IBCSBR,U,1)["PRESCRIPTION" S IBCHRG=$$RXCOST(IBITEM) I +IBCHRG D SETARR(0,0,+IBCHRG,.ARR) Q
     22 ;
     23 ; all others - have Charge Item entries
     24 ;
     25 ; find most recent Charge Item for the item, search until modifiers match (only BI=CPT should have mods defined)
     26 S IBXREF="AIVDTS"_CS,IBITMFND=0
     27 S IBEFDT=-(IBEVDT+.01) F  S IBEFDT=$O(^IBA(363.2,IBXREF,IBITEM,IBEFDT)) Q:'IBEFDT  D  Q:IBITMFND
     28 . S IBDA=0 F  S IBDA=$O(^IBA(363.2,IBXREF,IBITEM,IBEFDT,IBDA)) Q:'IBDA  D
     29 .. S IBLN=$G(^IBA(363.2,IBDA,0))
     30 .. I +$P(IBLN,U,7)'=+MOD Q  ; charge item modifier does not match modifier passed in
     31 .. S IBITMFND=1 ; item found
     32 .. I +$P(IBLN,U,4),+$P(IBLN,U,4)<IBEVDT Q  ; charge is inactive on event date
     33 .. I +$P(IBLN,U,5) D SETARR(IBDA,+$P(IBLN,U,6),+$P(IBLN,U,5),.ARR,$P(IBLN,U,8))
     34 Q
     35 ;
     36SETARR(CI,RVCD,CHRG,ARR,CHRGB) ; set charges into an array, does not allow zero charge, a new entry is created each time,
     37 ; no attempt to combine like items, the new item charge is added to any that may already be in the array
     38 ; returns ARR = count of items in array ^ total charge for item
     39 ;         ARR(x) = charge item IFN (if any) ^ item rev code (if any) ^ $ charge
     40 ;
     41 N CNT,TCHRG,TCHRGB
     42 S CNT=+$G(ARR)+1,TCHRG=$P($G(ARR),U,2)+$G(CHRG) I +$G(CHRGB) S TCHRGB=+$P($G(ARR),U,3)+CHRGB
     43 I +$G(CHRG) S ARR=CNT_U_+TCHRG_U_$G(TCHRGB),ARR(CNT)=$G(CI)_U_+$G(RVCD)_U_+CHRG_U_$G(TCHRGB)
     44 Q
     45 ;
     46PICOST(PI) ; returns (PI=ptr 362.5): total VA cost of an item (660,14) ^ quantity (660,5) from prosthetics ^ bill IFN
     47 ;
     48 N IBPIP,IBLN,IBX,IBIFN S (IBPIP,IBX)=0
     49 I +$G(PI) S IBLN=$G(^IBA(362.5,+PI,0)),IBPIP=$P(IBLN,U,4),IBIFN=$P(IBLN,U,2)
     50 I +IBPIP S IBLN=$G(^RMPR(660,+IBPIP,0)) I IBLN'="" S IBX=$P(IBLN,U,16)_U_$P(IBLN,U,7)_U_IBIFN
     51 Q IBX
     52 ;
     53RATECHG(RS,CHG,EVDT,FEE) ; returns modifed item charge based on rate schedule:  check effective dates, apply adjustment
     54 ; adjusted amount ^ comment (if there is an adjustment)
     55 ; if FEE passed by reference, returns disp fee^admin fee
     56 ;
     57 N IBX,IBRS0,IBRS10,IBEFDT,IBINADT,IBRTY,X S IBRTY=""
     58 S IBX=+$G(CHG),IBRS0=$G(^IBE(363,+$G(RS),0)),IBRS10=$G(^IBE(363,+$G(RS),10))
     59 S EVDT=$S(+$G(EVDT):EVDT,1:DT),IBEFDT=$P(IBRS0,U,5),IBINADT=$P(IBRS0,U,6)
     60 I +IBEFDT>EVDT!(+IBINADT&(IBINADT<EVDT)) S IBX=0
     61 I +IBX,IBRS10'="" S X=IBX X IBRS10 S IBX=X,IBRTY="^Rate Schedule Adjustment ("_$J(CHG,"",2)_")"
     62 S FEE=$P($G(^IBE(363,+$G(RS),1)),"^",1,2)
     63 Q IBX_IBRTY
     64 ;
     65RXCOST(RX) ; returns (RX=ptr 362.4): VA Cost of an Rx - Per Unit Cost ^ bill IFN
     66 ; w/ Per Unit Cost = RX (Unit Price of Drug - 52,17) or Drug (Price Per Dispense Unit 50,16) cost
     67 ;
     68 N IBRXP,IBDGP,IBLN,IBX,IBIFN S (IBRXP,IBX)=0
     69 I +$G(RX) S IBLN=$G(^IBA(362.4,+RX,0)),IBRXP=$P(IBLN,U,5),IBDGP=$P(IBLN,U,4),IBIFN=$P(IBLN,U,2)
     70 I +IBRXP S IBX=$$FILE^IBRXUTL(IBRXP,17)_U_IBIFN
     71 I 'IBRXP,+IBDGP D DATA^IBRXUTL(+IBDGP) S IBLN=$G(^TMP($J,"IBDRUG",0)) I IBLN'="" S IBX=$G(^TMP($J,"IBDRUG",+IBDGP,16))_U_IBIFN
     72 K ^TMP($J,"IBDRUG")
     73 Q IBX
     74 ;
     75PRVCHG(CS,CHG,PRV,EVDT,ITEM) ; return discounted amount, based on total charge for a the care, the provider and Charge Set (BR)
     76 ; if no discount record found for the Charge Set or the provider then returns original amount
     77 ; no provider discount for Lab charges (80000-89999)
     78 ;   discounted amount ^ comment (if discounted) ^ percent discount
     79 ;
     80 N IBPC,IBSGFN,IBSG,IBPDFN,IBPD0,IBPDTY,IBI,IBX,IBY S IBX=+$G(CHG),(IBSGFN,IBPDTY)="" I '$G(EVDT) S EVDT=DT
     81 I +$G(ITEM),ITEM>79999,ITEM<90000 S (CS,PRV)=""
     82 I +$G(CS) S IBSGFN=+$$CSSG^IBCRU6(+CS,"",2,.IBSG)
     83 I +$G(PRV),+IBSGFN S IBPC=$$GET^XUA4A72(PRV,EVDT)
     84 ;
     85 S IBI=0 F  S IBI=$O(IBSG(IBI)) Q:'IBI  S IBSGFN=+IBSG(IBI) I +IBSGFN D
     86 . S IBPDFN=0 F  S IBPDFN=$O(^IBE(363.34,"C",+IBSGFN,IBPDFN)) Q:'IBPDFN  D  Q:IBPDTY'=""
     87 .. I '$O(^IBE(363.34,+IBPDFN,11,"B",+IBPC,0)) Q
     88 .. S IBPD0=$G(^IBE(363.34,+IBPDFN,0)),IBY=$P(IBPD0,U,3) Q:IBY=""
     89 .. S IBY=+IBY/100,IBX=IBY*IBX
     90 .. S IBPDTY=U_$P($G(^VA(200,+PRV,0)),U,1)_" - "_$P(IBPD0,U,1)_" "_$P(IBPD0,U,3)_"% of "_$J(CHG,0,2)_U_+IBY
     91 Q IBX_IBPDTY
     92 ;
     93HRUNIT(HRS) ; returns Hour Units based on the Hours passed in
     94 ; Hour Units are the hours rounded to the nearest whole hour (less than 30 minutes is 0 units)
     95 N IBX S IBX=0 I +$G(HRS) S IBX=$J(HRS,0,0)
     96 Q IBX
     97 ;
     98MLUNIT(MLS) ; returns Miles Units based on the Miles passed in
     99 ; Mile Units are the miles rounded to the nearest whole mile
     100 N IBX S IBX=0 I +$G(MLS) S IBX=$J(MLS,0,0) I 'IBX S IBX=1
     101 Q IBX
     102 ;
     103MNUNIT(MNS) ; return Minute Units based on the Minutes passed in
     104 ; Minute Units are 15 minute intervals, rounded down for less than 5 minutes
     105 N IBX S IBX=0 I +$G(MNS) S IBX=(MNS\15) S:(MNS#15)>4 IBX=IBX+1 I 'IBX S IBX=1
     106 Q IBX

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRHBRV.m

    r613 r623  
    1 IBCRHBRV        ;ALB/ARH - RATES: UPLOAD (RC) VERSION FUNCTIONS ; 14-FEB-01
    2         ;;2.0;INTEGRATED BILLING;**148,169,245,270,285,298,325,334,355,360,365,382,390**;21-MAR-94;Build 2
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5         ; RC functions related to Version.  Update VLIST with new versions.  Update FTYPE if new types of files.
    6         ;
    7 SELVERS()       ; get version to upload from user
    8         N DIR,DIRUT,DTOUT,DUOUT,IBVLIST,IBQUIT,IBVERS,IBI,IBJ,IBX,X,Y
    9         ;
    10         S IBVLIST=$$VERSTR(),IBQUIT=0,IBVERS=0
    11         ;
    12         W !!,"Select the version of Reasonable Charges to upload."
    13         S DIR("?",1)="Enter the code from the list corresponding to the version of Reasonable Charges"
    14         S DIR("?",2)="to upload.  There are no version 1.3, 2.2, or 2.10 (ten) RC charges." S DIR("?",3)=" "
    15         S DIR("?",4)="Versions: "_IBVLIST S DIR("?",5)=" " S DIR("?")="Enter version number to upload."
    16         ;
    17         F IBI=1:1 D  I +IBQUIT Q
    18         . W !!,?5,"Select one of the following:",!
    19         . F IBJ=1:1 S IBX=$P(IBVLIST,",",IBJ) Q:'IBX  W !,?10,IBX,?20,"Reasonable Charges version ",IBX
    20         . ;
    21         . W ! S DIR("A")="Enter Version" S DIR(0)="FO^1:5" D ^DIR I $D(DIRUT) S IBQUIT=1
    22         . I Y>0,(","_IBVLIST_",")[(","_Y_",") S IBVERS=Y,IBQUIT=1 W "  Reasonable Charges version ",IBVERS
    23         ;
    24         Q IBVERS
    25         ;
    26 VERSION()       ; return currently loaded version of RC files (1, 1.1, ...)
    27         N IBX S IBX=$G(^XTMP("IBCR RC SITE","VERSION"))
    28         Q IBX
    29         ;
    30 VERSDT(VERS)    ; return Effective Date of a version of RC files, either version passed in or currently loaded version
    31         N IBI,LINE,IBX S IBX="" S VERS=+$G(VERS) I 'VERS S VERS=$$VERSION
    32         I +VERS F IBI=1:1 S LINE=$P($T(VLIST+IBI),";;",2,99) Q:'LINE  I VERS=+LINE S IBX=$P(LINE,U,3)
    33         Q IBX
    34         ;
    35 VERSEDT(VERS)   ; return Inactive Date of a version of RC files, either version passed in or currently loaded version
    36         N IBI,LINE,IBX S IBX="" S VERS=+$G(VERS) I 'VERS S VERS=$$VERSION
    37         I +VERS F IBI=1:1 S LINE=$P($T(VLIST+IBI),";;",2,99) Q:'LINE  I VERS=+LINE S IBX=$P(LINE,U,4)
    38         Q IBX
    39         ;
    40 VERSALL()       ; return all RC versions and corresponding effective date 'VERS;EFFDT^VERS;EFFDT^...'
    41         N IBI,LINE,IBX,IBC S IBX="",IBC=""
    42         F IBI=1:1 S LINE=$P($T(VLIST+IBI),";;",2,99) Q:'LINE  S IBX=IBX_IBC_+LINE_";"_$P(LINE,U,3),IBC=U
    43         Q IBX
    44         ;
    45 VERSEND()       ; return all RC versions and corresponding inactive date 'VERS;INACTIVE DT^VERS;INACTIVE DT^...'
    46         N IBI,LINE,IBX,IBC S IBX="",IBC=""
    47         F IBI=1:1 S LINE=$P($T(VLIST+IBI),";;",2,99) Q:'LINE  I $P(LINE,U,4) S IBX=IBX_IBC_+LINE_";"_$P(LINE,U,4),IBC=U
    48         Q IBX
    49         ;
    50 VERSITE(SITE)   ; returns the list of versions loaded for a particular site
    51         ; *** uses 99201 in the RC PHYSICIAN set to check which versions/dates are loaded
    52         ; *** so 99201 must have a pro charge in all versions, if not it must be replaced with an item that does
    53         N IBCS,IBXRF,IBITM,IBVERS,IBCSFN,IBI,IBV,IBX,IBY,IBC
    54         S IBVERS=$$VERSALL,IBITM=99201
    55         ;
    56         I $G(SITE)'="" S IBCS="RC-PHYSICIAN" F  S IBCS=$O(^IBE(363.1,"B",IBCS)) Q:IBCS'["RC-PHYSICIAN"  D
    57         . S IBV=$L(IBCS," ") I $P(IBCS," ",IBV)'=SITE Q
    58         . S IBCSFN=$O(^IBE(363.1,"B",IBCS,0)) Q:'IBCSFN  S IBXRF="AIVDTS"_IBCSFN
    59         . F IBI=1:1 S IBV=$P(IBVERS,U,IBI) Q:'IBV  I $O(^IBA(363.2,IBXRF,IBITM,-$P(IBV,";",2),0)) S IBY(+IBV)=""
    60         ;
    61         S (IBX,IBC)="" F IBI=1:1 S IBV=+$P(IBVERS,U,IBI) Q:'IBV  I $D(IBY(IBV)) S IBX=IBX_IBC_IBV S IBC=","
    62         ;
    63         Q IBX
    64         ;
    65 MSGSITE(SITE)   ; display a message indicating which versions are loaded for a site
    66         N IBVERS Q:'$G(SITE)
    67         S IBVERS=$$VERSITE(SITE)
    68         I 'IBVERS W !!,?12,"There appear to be no RC charges already loaded for "_SITE_"."
    69         I +IBVERS W !!,?12,"RC versions "_IBVERS_" appear to be already loaded for "_SITE_"."
    70         Q
    71         ;
    72 MSGVERS(SITE)   ; check if versions are being loaded in the correct order, should be loaded in date order
    73         ;   - if loading a version that has already been loaded for the site
    74         ;   - if loading a version when any future versions have already been loaded for the site
    75         ;   - if loading a version when the last version has not yet been loaded for the site
    76         ; *** uses 99201 in the RC PHYSICIAN set to check which versions/dates are loaded
    77         ; *** so 99201 must have a pro charge in all versions, if not it must be replaced with an item that does
    78         N IBVERS,IBVDTC,IBVERSIN,IBVERSC,IBVERSO,IBI,VERSTR Q:'$G(SITE)
    79         ;
    80         S IBVERS=$$VERSION Q:'IBVERS  S IBVDTC=$$VERSDT,IBVERSIN=","_$$VERSITE(SITE)_",",IBVERSC=","_IBVERS_","
    81         ;
    82         ; check if loading a version that has already been loaded
    83         I IBVERSIN[IBVERSC D
    84         . W !!,?5,"*** It appears version RC v",IBVERS," has already been loaded for this site ***"
    85         ;
    86         ; check if loading a version when any future versions have already been loaded
    87         S VERSTR=","_$$VERSTR()_",",VERSTR=$P(VERSTR,IBVERSC,2) ; all versions after current version
    88         F IBI=1:1 S IBVERSO=$P(VERSTR,",",IBI) Q:'IBVERSO  I IBVERSIN[(","_IBVERSO_",")  D
    89         . W !!,?5,">>> Currently trying to load RC v"_IBVERS_" but RC v"_IBVERSO_" appears to be already",!,?9,"loaded for this site.  The versions should be loaded in date order."
    90         ;
    91         ; check if loading a version when the last version has not yet been loaded
    92         S VERSTR=","_$$VERSTR(1)_",",VERSTR=$P(VERSTR,IBVERSC,2) ; all versions before current version, reverse order
    93         S IBVERSO=$P(VERSTR,",",1) I +IBVERSO,IBVERSIN'[(","_IBVERSO_",") D
    94         . W !!,?5,"*** Currently trying to load RC v"_IBVERS_" but RC v"_IBVERSO_" does not appear to be",!,?9,"loaded for this site.  The versions should be loaded in date order."
    95         . W !!,?5,">>> Continue only if there will never be a need to bill events before ",!,?9,$$FMTE^XLFDT(IBVDTC,2)," for this site.  If RC v"_IBVERSO_" will be needed for this site then",!,?9,"load it first."
    96         ;
    97         Q
    98         ;
    99 VERSTR(RVRS)    ; returns string containing list of all Reasonable Charges versions with charges, separated by ","
    100         ; RVRS - if set, returns the list of versions in reverse order
    101         N IBI,LINE,IBS,IBR,IBC,IBX  S (IBS,IBR,IBC,IBX)=""
    102         F IBI=1:1 S LINE=$P($T(VLIST+IBI),";;",2,99) Q:'LINE  S IBS=IBS_IBC_+LINE,IBR=+LINE_IBC_IBR S IBC=","
    103         S IBX=IBS I +$G(RVRS) S IBX=IBR
    104         Q IBX
    105         ;
    106         ;
    107         ;
    108         ;
    109         ;
    110         ;
    111         ;
    112         ; File Names:  'IBRCyymmx.TXT'   w/ yymm - year month of version release (except v1)
    113         ;              'IBRCyymm', file version identifier prefix, from VLIST text version description
    114         ;              x=A-I/F, single character file identifier, from FTYPE text file description
    115         ;
    116 FILES(IBFILES,VERS)     ; returns array of source Host Files and data for version requested, pass IBFILES by reference
    117         N IBI,LINE,IBTYPE,IBFILE,IBNAME,IBDESC S VERS=+$G(VERS) I 'VERS S VERS=1
    118         ;
    119         ; get requested versions data
    120         F IBI=1:1 S LINE=$P($T(VLIST+IBI),";;",2,99) Q:'LINE  I VERS=+LINE S IBTYPE=$P(LINE,U,2),IBFILE=$P(LINE,U,5) Q
    121         ;
    122         ; get requested versions files
    123         I +$G(IBTYPE) F IBI=1:1 S LINE=$P($T(@("FT"_IBTYPE)+IBI),";;",2,99) Q:LINE=""  D
    124         . S IBNAME=IBFILE_$P(LINE,":",1)_".TXT",IBDESC="RC v"_+VERS_" "_$P(LINE,":",2,99)
    125         . S IBFILES(IBNAME)=IBDESC
    126         Q
    127         ;
    128         ;
    129         ; versions and their critical data, add new versions here
    130 VLIST   ; version ^ file type/version ^ effective date ^ inactive date ^ file prefix
    131         ;;1.0^1^2990901^3001101^IBRCV
    132         ;;1.1^1^3001102^3010507^IBRC0011
    133         ;;1.2^1^3010508^3030428^IBRC0105
    134         ;;1.4^1^3030429^3031218^IBRC0304
    135         ;;2.0^2^3031219^3040414^IBRC0312
    136         ;;2.1^2^3040415^3041231^IBRC0404
    137         ;;2.3^2^3050101^3050410^IBRC0501
    138         ;;2.4^2^3050411^3050930^IBRC0504
    139         ;;2.5^2^3051001^3051231^IBRC0510
    140         ;;2.6^2^3060101^3060824^IBRC0601
    141         ;;2.7^2^3060825^3060930^IBRC0608
    142         ;;2.8^2^3061001^3061231^IBRC0610
    143         ;;2.9^2^3070101^3070930^IBRC0701
    144         ;;2.11^2^3071001^3071231^IBRC0710
    145         ;;3.1^2^3080101^^IBRC0801
    146         ;;
    147         ;
    148         ;
    149         ;
    150         ;
    151         ;
    152         ;
    153         ;
    154 FTYPE   ; file type/versions and relevant data
    155         ; file identifer is used with XTMP subscript 'IBCR RC ' and routine label to parse file
    156         ; file identifier : file name/description ^ file identifier ^ number of columns (for v2+)
    157         ;
    158 FT1     ; Reasonable Charge File Type 1 files
    159         ;;A:Inpatient Facility Charges^A
    160         ;;B:Inpatient Facility Area Factors^B
    161         ;;C:Outpatient Facility Charges^C
    162         ;;D:Outpatient Facility Area Factors^D
    163         ;;E:Physician Charges E^E
    164         ;;F:Physician Charges F^F
    165         ;;G:Physician Charges G^G
    166         ;;H:Physician Area Factors^H
    167         ;;I:Physician Unit Area Factors^I
    168         ;;
    169         ;
    170 FT2     ; Reasonable Charges File Type 2 files
    171         ;;A:Inpatient Facility Charges^A^10
    172         ;;B:Outpatient Facility Charges^B^14
    173         ;;C:Professional Charges^C^23
    174         ;;D:Service Category Codes^D^4
    175         ;;E:Area Factors^E^41
    176         ;;F:VA Sites and Zip Codes^F^4
    177         ;;
     1IBCRHBRV ;ALB/ARH - RATES: UPLOAD (RC) VERSION FUNCTIONS ; 14-FEB-01
     2 ;;2.0;INTEGRATED BILLING;**148,169,245,270,285,298,325,334,355,360,365**;21-MAR-94;Build 2
     3 ;;Per VHA Directive 2004-038, this routine should not be modified.
     4 ;
     5 ; RC functions related to Version, most have to be updated when a new version is to be exported
     6 ;
     7SELVERS() ; get version to upload from user
     8 N DIR,DIRUT,DTOUT,DUOUT,X,Y,IB,IBV,IBVP,IBX
     9 S IBV="1.0^1.1^1.2^1.4^2.0^2.1^2.3^2.4^2.5^2.6^2.7^2.8^2.9" ; List of valid version numbers
     10 S IBX=0
     11 W !!,"Select the version of Reasonable Charges to upload.",!
     12 S DIR("?")="Enter a code from the list corresponding to the version of Reasonable Charges to upload.  There was no version 1.3 nor 2.2 of Reasonable Charges."
     13 S DIR(0)="SO^"
     14 F IB=1:1:$L(IBV,U) S IBVP=$P(IBV,U,IB),DIR(0)=DIR(0)_+IBVP_":Reasonable Charges version "_IBVP_";"
     15 D ^DIR K DIR S:$L(Y)=1 Y=Y_".0" S IBX=+$S(IBV[Y:Y,1:0)
     16 Q IBX
     17 ;
     18VERSION() ; return currently loaded version of RC files (1, 1.1, ...)
     19 N IBX S IBX=$G(^XTMP("IBCR RC SITE","VERSION"))
     20 Q IBX
     21 ;
     22VERSDT(VERS) ; return Effective Date of a version of RC files, either version passed in or currently loaded version
     23 N IBX S:'$G(VERS) VERS=$$VERSION
     24 S IBX=$S(VERS=1:2990901,VERS=1.1:3001102,VERS=1.2:3010508,VERS=1.4:3030429,VERS=2:3031219,VERS=2.1:3040415,VERS=2.3:3050101,VERS=2.4:3050411,VERS=2.5:3051001,VERS=2.6:3060101,VERS=2.7:3060825,VERS=2.8:3061001,VERS=2.9:3070101,1:"")
     25 Q IBX
     26 ;
     27VERSEDT(VERS) ; return Inactive Date of a version of RC files, either version passed in or currently loaded version
     28 N IBX S:'$G(VERS) VERS=$$VERSION
     29 S IBX=$S(VERS=1:3001101,VERS=1.1:3010507,VERS=1.2:3030428,VERS=1.4:3031218,VERS=2:3040414,VERS=2.1:3041231,VERS=2.3:3050410,VERS=2.4:3050930,VERS=2.5:3051231,VERS=2.6:3060824,VERS=2.7:3060930,VERS=2.8:3061231,1:"")
     30 Q IBX
     31 ;
     32VERSALL() ; returns all RC versions and corresponding effective date
     33 N IBX S IBX="1;2990901^1.1;3001102^1.2;3010508^1.4;3030429^2;3031219^2.1;3040415^2.3;3050101^2.4;3050411^2.5;3051001^2.6;3060101^2.7;3060825^2.8;3061001^2.9;3070101"
     34 Q IBX
     35 ;
     36VERSEND() ; returns all RC versions and corresponding inactive dates
     37 N IBX S IBX="1;3001101^1.1;3010507^1.2;3030428^1.4;3031218^2;3040414^2.1;3041231^2.3;3050410^2.4;3050930^2.5;3051231^2.6;3060824^2.7;3060930^2.8;3061231"
     38 Q IBX
     39 ;
     40 ;
     41VERSITE(SITE) ; returns the list of versions loaded for a particular site
     42 ; *** uses 99201 in the RC PHYSICIAN set to check which versions/dates are loaded
     43 ; *** so 99201 must have a pro charge in all versions, if not it must be replaced with an item that does
     44 N IBCS,IBXRF,IBITM,IBVERS,IBCSFN,IBI,IBV,IBX,IBY S IBX=""
     45 S IBVERS=$$VERSALL,IBITM=99201
     46 ;
     47 I $G(SITE)'="" S IBCS="RC-PHYSICIAN" F  S IBCS=$O(^IBE(363.1,"B",IBCS)) Q:IBCS'["RC-PHYSICIAN"  D
     48 . S IBV=$L(IBCS," ") I $P(IBCS," ",IBV)'=SITE Q
     49 . S IBCSFN=$O(^IBE(363.1,"B",IBCS,0)) Q:'IBCSFN  S IBXRF="AIVDTS"_IBCSFN
     50 . F IBI=1:1 S IBV=$P(IBVERS,U,IBI) Q:'IBV  I $O(^IBA(363.2,IBXRF,IBITM,-$P(IBV,";",2),0)) S IBY(+IBV)=""
     51 S IBV="" F  S IBV=$O(IBY(IBV)) Q:'IBV  S IBX=IBX_IBV_","
     52 ;
     53 I $E(IBX,$L(IBX))="," S IBX=$E(IBX,1,$L(IBX)-1)
     54 Q IBX
     55 ;
     56MSGSITE(SITE) ; display a message indicating which versions are loaded for a site
     57 N IBVERS Q:'$G(SITE)
     58 S IBVERS=$$VERSITE(SITE)
     59 I 'IBVERS W !!,?12,"There appear to be no RC charges already loaded for "_SITE_"."
     60 I +IBVERS W !!,?12,"RC versions "_IBVERS_" appear to be already loaded for "_SITE_"."
     61 Q
     62 ;
     63MSGVERS(SITE) ; check if versions are being loaded in the correct order, should be loaded in date order
     64 ; displays messages to the user:
     65 ;   - if loading a version that has already been loaded for the site
     66 ;   - if loading a version when any future versions have already been loaded for the site
     67 ;   - if loading a version when the last version has not yet been loaded for the site
     68 ; *** uses 99201 in the RC PHYSICIAN set to check which versions/dates are loaded
     69 ; *** so 99201 must have a pro charge in all versions, if not it must be replaced with an item that does
     70 N IBVERS,IBVDTC,IBVERSIN,IBVERSO Q:'$G(SITE)
     71 ;
     72 S IBVERS=$$VERSION Q:'IBVERS  S IBVDTC=$$VERSDT,IBVERSIN=","_$$VERSITE(SITE)_","
     73 ;
     74 ; check if loading a version that has already been loaded
     75 I IBVERSIN[(","_IBVERS_",") D
     76 . W !!,?5,"*** It appears version RC v",IBVERS," has already been loaded for this site ***"
     77 ;
     78 ; check if loading a version when any future versions have already been loaded
     79 F IBVERSO=1,1.1,1.2,1.4,2,2.1,2.3,2.4,2.5,2.6,2.7,2.8,2.9 I IBVERSO>IBVERS D
     80 . I IBVERSIN[(","_IBVERSO_",") D
     81 .. W !!,?5,">>> Currently trying to load RC v"_IBVERS_" but RC v"_IBVERSO_" appears to be already",!,?9,"loaded for this site.  The versions should be loaded in date order."
     82 ;
     83 ; check if loading a version when the last version has not yet been loaded
     84 F IBVERSO=2.9,2.8,2.7,2.6,2.5,2.4,2.3,2.1,2,1.4,1.2,1.1,1 I IBVERS>IBVERSO D  Q
     85 . I IBVERSIN'[(","_IBVERSO_",") D
     86 .. W !!,?5,"*** Currently trying to load RC v"_IBVERS_" but RC v"_IBVERSO_" does not appear to be",!,?9,"loaded for this site.  The versions should be loaded in date order."
     87 .. W !!,?5,">>> Continue only if there will never be a need to bill events before ",!,?9,$$FMTE^XLFDT(IBVDTC,2)," for this site.  If RC v"_IBVERSO_" will be needed for this site then",!,?9,"load it first."
     88 ;
     89 Q
     90 ;
     91FILES(IBFILES,VERS) ; source Host file name, description, and routine label that parses the file
     92 ; the subscript used for the file in XTMP is 'IBCR RC '_X w/ X=the routine label that parses the file
     93 ;
     94 I $G(VERS)=1.1 G FBREAL
     95 I $G(VERS)=1.2 G FCREAL
     96 I $G(VERS)=1.4 G FDREAL
     97 I $G(VERS)=2 G FEREAL
     98 I $G(VERS)=2.1 G FFREAL
     99 I $G(VERS)=2.3 G FGREAL
     100 I $G(VERS)=2.4 G FHREAL
     101 I $G(VERS)=2.5 G FIREAL^IBCRHBV1
     102 I $G(VERS)=2.6 G FJREAL^IBCRHBV1
     103 I $G(VERS)=2.7 G FKREAL^IBCRHBV1
     104 I $G(VERS)=2.8 G FLREAL^IBCRHBV1
     105 I $G(VERS)=2.9 G FMREAL^IBCRHBV1
     106 ;
     107FREAL S IBFILES("IBRCVA.TXT")="RC v1 Inpatient Facility Charges^A"
     108 S IBFILES("IBRCVB.TXT")="RC v1 Inpatient Facility Area Factors^B"
     109 S IBFILES("IBRCVC.TXT")="RC v1 Outpatient Facility Charges^C"
     110 S IBFILES("IBRCVD.TXT")="RC v1 Outpatient Facility Area Factors^D"
     111 S IBFILES("IBRCVE.TXT")="RC v1 Physician Charges E^E"
     112 S IBFILES("IBRCVF.TXT")="RC v1 Physician Charges F^F"
     113 S IBFILES("IBRCVG.TXT")="RC v1 Physician Charges G^G"
     114 S IBFILES("IBRCVH.TXT")="RC v1 Physician Area Factors^H"
     115 S IBFILES("IBRCVI.TXT")="RC v1 Physician Unit Area Factors^I"
     116 Q
     117 ;
     118FBREAL S IBFILES("IBRC0011A.TXT")="RC v1.1 Inpatient Facility Charges^A"
     119 S IBFILES("IBRC0011B.TXT")="RC v1.1 Inpatient Facility Area Factors^B"
     120 S IBFILES("IBRC0011C.TXT")="RC v1.1 Outpatient Facility Charges^C"
     121 S IBFILES("IBRC0011D.TXT")="RC v1.1 Outpatient Facility Area Factors^D"
     122 S IBFILES("IBRC0011E.TXT")="RC v1.1 Physician Charges E^E"
     123 S IBFILES("IBRC0011F.TXT")="RC v1.1 Physician Charges F^F"
     124 S IBFILES("IBRC0011G.TXT")="RC v1.1 Physician Charges G^G"
     125 S IBFILES("IBRC0011H.TXT")="RC v1.1 Physician Area Factors^H"
     126 S IBFILES("IBRC0011I.TXT")="RC v1.1 Physician Unit Area Factors^I"
     127 Q
     128 ;
     129FCREAL S IBFILES("IBRC0105A.TXT")="RC v1.2 Inpatient Facility Charges^A"
     130 S IBFILES("IBRC0105B.TXT")="RC v1.2 Inpatient Facility Area Factors^B"
     131 S IBFILES("IBRC0105C.TXT")="RC v1.2 Outpatient Facility Charges^C"
     132 S IBFILES("IBRC0105D.TXT")="RC v1.2 Outpatient Facility Area Factors^D"
     133 S IBFILES("IBRC0105E.TXT")="RC v1.2 Physician Charges E^E"
     134 S IBFILES("IBRC0105F.TXT")="RC v1.2 Physician Charges F^F"
     135 S IBFILES("IBRC0105G.TXT")="RC v1.2 Physician Charges G^G"
     136 S IBFILES("IBRC0105H.TXT")="RC v1.2 Physician Area Factors^H"
     137 S IBFILES("IBRC0105I.TXT")="RC v1.2 Physician Unit Area Factors^I"
     138 Q
     139 ;
     140FDREAL S IBFILES("IBRC0304A.TXT")="RC v1.4 Inpatient Facility Charges^A"
     141 S IBFILES("IBRC0304B.TXT")="RC v1.4 Inpatient Facility Area Factors^B"
     142 S IBFILES("IBRC0304C.TXT")="RC v1.4 Outpatient Facility Charges^C"
     143 S IBFILES("IBRC0304D.TXT")="RC v1.4 Outpatient Facility Area Factors^D"
     144 S IBFILES("IBRC0304E.TXT")="RC v1.4 Physician Charges E^E"
     145 S IBFILES("IBRC0304F.TXT")="RC v1.4 Physician Charges F^F"
     146 S IBFILES("IBRC0304G.TXT")="RC v1.4 Physician Charges G^G"
     147 S IBFILES("IBRC0304H.TXT")="RC v1.4 Physician Area Factors^H"
     148 S IBFILES("IBRC0304I.TXT")="RC v1.4 Physician Unit Area Factors^I"
     149 Q
     150 ;
     151FEREAL S IBFILES("IBRC0312A.TXT")="RC v2.0 Inpatient Facility Charges^A^10"
     152 S IBFILES("IBRC0312B.TXT")="RC v2.0 Outpatient Facility Charges^B^14"
     153 S IBFILES("IBRC0312C.TXT")="RC v2.0 Professional Charges^C^23"
     154 S IBFILES("IBRC0312D.TXT")="RC v2.0 Service Category Codes^D^4"
     155 S IBFILES("IBRC0312E.TXT")="RC v2.0 Area Factors^E^41"
     156 S IBFILES("IBRC0312F.TXT")="RC v2.0 VA Sites and Zip Codes^F^4"
     157 Q
     158 ;
     159FFREAL S IBFILES("IBRC0404A.TXT")="RC v2.1 Inpatient Facility Charges^A^10"
     160 S IBFILES("IBRC0404B.TXT")="RC v2.1 Outpatient Facility Charges^B^14"
     161 S IBFILES("IBRC0404C.TXT")="RC v2.1 Professional Charges^C^23"
     162 S IBFILES("IBRC0404D.TXT")="RC v2.1 Service Category Codes^D^4"
     163 S IBFILES("IBRC0404E.TXT")="RC v2.1 Area Factors^E^41"
     164 S IBFILES("IBRC0404F.TXT")="RC v2.1 VA Sites and Zip Codes^F^4"
     165 Q
     166 ;
     167FGREAL S IBFILES("IBRC0501A.TXT")="RC v2.3 Inpatient Facility Charges^A^10"
     168 S IBFILES("IBRC0501B.TXT")="RC v2.3 Outpatient Facility Charges^B^14"
     169 S IBFILES("IBRC0501C.TXT")="RC v2.3 Professional Charges^C^23"
     170 S IBFILES("IBRC0501D.TXT")="RC v2.3 Service Category Codes^D^4"
     171 S IBFILES("IBRC0501E.TXT")="RC v2.3 Area Factors^E^41"
     172 S IBFILES("IBRC0501F.TXT")="RC v2.3 VA Sites and Zip Codes^F^4"
     173 Q
     174 ;
     175FHREAL S IBFILES("IBRC0504A.TXT")="RC v2.4 Inpatient Facility Charges^A^10"
     176 S IBFILES("IBRC0504B.TXT")="RC v2.4 Outpatient Facility Charges^B^14"
     177 S IBFILES("IBRC0504C.TXT")="RC v2.4 Professional Charges^C^23"
     178 S IBFILES("IBRC0504D.TXT")="RC v2.4 Service Category Codes^D^4"
     179 S IBFILES("IBRC0504E.TXT")="RC v2.4 Area Factors^E^41"
     180 S IBFILES("IBRC0504F.TXT")="RC v2.4 VA Sites and Zip Codes^F^4"
     181 Q

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRHBS8.m

    r613 r623  
    1 IBCRHBS8        ;ALB/ARH - RATES: UPLOAD (RC 2+) CALCULATIONS CHARGE ; 10-OCT-03
    2         ;;2.0;INTEGRATED BILLING;**245,382**;21-MAR-94;Build 2
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5         ;
    6 ISA(SITE,ITLINE)        ; Return Inpatient DRG Standard Ancillary Charge
    7         N IBCHG,IBZIP,IBAA,IBCTI,IBCTIAAP S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4)
    8         I $P(ITLINE,U,2)'="DRG" G ISAQ
    9         ;
    10         S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G ISAQ
    11         S IBCTI=$P($G(ITLINE),U,4),IBCTIAAP=$S(IBCTI="S":3,IBCTI="N":5,1:0) I 'IBCTIAAP G ISAQ
    12         ;
    13         S IBCHG=$P(ITLINE,U,6)*$P(IBAA,U,IBCTIAAP) S IBCHG=$J(IBCHG,0,2)
    14         ;
    15 ISAQ    Q IBCHG
    16         ;
    17 ISR(SITE,ITLINE)        ; Return Inpatient DRG Standard Room & Board Charge
    18         N IBCHG,IBZIP,IBAA,IBCTI,IBCTIAAP S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4)
    19         I $P(ITLINE,U,2)'="DRG" G ISRQ
    20         ;
    21         S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G ISRQ
    22         S IBCTI=$P($G(ITLINE),U,4),IBCTIAAP=$S(IBCTI="S":2,IBCTI="N":4,1:0) I 'IBCTIAAP G ISRQ
    23         ;
    24         S IBCHG=$P(ITLINE,U,5)*$P(IBAA,U,IBCTIAAP) S IBCHG=$J(IBCHG,0,2)
    25         ;
    26 ISRQ    Q IBCHG
    27         ;
    28 IIA(SITE,ITLINE)        ; Return Inpatient DRG ICU Ancillary Charge
    29         N IBCHG,IBZIP,IBAA,IBCTI,IBCTIAAP S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4)
    30         I $P(ITLINE,U,2)'="DRG" G IIAQ
    31         ;
    32         S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G IIAQ
    33         S IBCTI=$P($G(ITLINE),U,4),IBCTIAAP=$S(IBCTI="S":3,IBCTI="N":5,1:0) I 'IBCTIAAP G IIAQ
    34         ;
    35         S IBCHG=$P(ITLINE,U,8)*$P(IBAA,U,IBCTIAAP) S IBCHG=$J(IBCHG,0,2)
    36         ;
    37 IIAQ    Q IBCHG
    38         ;
    39 IIR(SITE,ITLINE)        ; Return Inpatient DRG ICU Room & Board Charge
    40         N IBCHG,IBZIP,IBAA,IBCTI,IBCTIAAP S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4)
    41         I $P(ITLINE,U,2)'="DRG" G IIRQ
    42         ;
    43         S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G IIRQ
    44         S IBCTI=$P($G(ITLINE),U,4),IBCTIAAP=$S(IBCTI="S":2,IBCTI="N":4,1:0) I 'IBCTIAAP G IIRQ
    45         ;
    46         S IBCHG=$P(ITLINE,U,7)*$P(IBAA,U,IBCTIAAP) S IBCHG=$J(IBCHG,0,2)
    47         ;
    48 IIRQ    Q IBCHG
    49         ;
    50 ISNF(SITE,ITLINE)       ; Return Inpatient Skilled Nursing Facility Per Diem
    51         N IBCHG,IBZIP,IBAA S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4)
    52         I $P(ITLINE,U,2)'="SNF" G ISNFQ
    53         I $P(ITLINE,U,1)'="999",$P(ITLINE,U,1)'="000" G ISNFQ
    54         ;
    55         S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G ISNFQ
    56         ;
    57         S IBCHG=$P(ITLINE,U,5)*$P(IBAA,U,6) S IBCHG=$J(IBCHG,0,2)
    58         ;
    59 ISNFQ   Q IBCHG
    60         ;
    61         ;
    62 FAC(SITE,ITLINE)        ; Return Facility Charge (Table B) for All Charge and Unit Types
    63         ; each line record contains 1 charge that may be calculated in multiple ways
    64         N IBCHG,IBUT S IBCHG=0,SITE=$G(SITE),ITLINE=$G(ITLINE)
    65         ;
    66         S IBUT=$P(ITLINE,U,10)
    67         ;
    68         I IBUT=1 S IBCHG=$$FSTD(SITE,ITLINE) G FACQ
    69         I IBUT=4 S IBCHG=$$FSTD(SITE,ITLINE) G FACQ
    70         I IBUT=2 S IBCHG=$$FHRS(SITE,ITLINE) G FACQ
    71         ;
    72 FACQ    Q IBCHG
    73         ;
    74 FSTD(SITE,ITLINE)       ; Return Facility Charge of Unit Type = 1 or 4 (Standard and Miles)
    75         N IBCHG,IBZIP,IBUT,IBAA,IBSCC,IBSCCAAP S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4)
    76         S IBUT=$P(ITLINE,U,10) I IBUT'=1,IBUT'=4 G FSTDQ
    77         ;
    78         S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G FSTDQ
    79         S IBSCC=$$GETSCC($P(ITLINE,U,5)),IBSCCAAP=$P(IBSCC,U,4) I 'IBSCCAAP G FSTDQ
    80         ;
    81         S IBCHG=$P(ITLINE,U,8)*$P(IBAA,U,IBSCCAAP) S IBCHG=$J(IBCHG,0,2)
    82         ;
    83 FSTDQ   Q IBCHG
    84         ;
    85 FHRS(SITE,ITLINE)       ; Return Facility Charge of Unit Type = 2 (Hours)
    86         N IBCHG,IBCHGB,IBZIP,IBUT,IBAA,IBSCC,IBSCCAAP S (IBCHG,IBCHGB)=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4)
    87         S IBUT=$P(ITLINE,U,10) I IBUT'=2 G FHRSQ
    88         ;
    89         S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G FHRSQ
    90         S IBSCC=$$GETSCC($P(ITLINE,U,5)),IBSCCAAP=$P(IBSCC,U,4) I 'IBSCCAAP G FHRSQ
    91         ;
    92         S IBCHG=$P(ITLINE,U,8)*$P(IBAA,U,IBSCCAAP) S IBCHG=$J(IBCHG,0,2)
    93         S IBCHGB=$P(ITLINE,U,9)*$P(IBAA,U,IBSCCAAP) S IBCHGB=$J(IBCHGB,0,2)
    94         ;
    95 FHRSQ   Q IBCHG_U_IBCHGB
    96         ;
    97         ;
    98 PROF(SITE,ITLINE)       ; Return Professional Charge (Table C) for All Charge and Unit Types
    99         ; each line record contains 1 charge that may be calculated in multiple ways
    100         N IBCHG,IBCT,IBUT S IBCHG=0,SITE=$G(SITE),ITLINE=$G(ITLINE)
    101         ;
    102         S IBCT=$P(ITLINE,U,8)
    103         S IBUT=$P(ITLINE,U,16)
    104         ;
    105         I IBUT=1,IBCT="RBRVS" S IBCHG=$$PRBRVS(SITE,ITLINE) G PROFQ
    106         I IBUT=1,IBCT="TotalUnits" S IBCHG=$$PTRVU(SITE,ITLINE) G PROFQ
    107         I IBUT=1,IBCT="NW" S IBCHG=$$PNW(SITE,ITLINE) G PROFQ
    108         I IBUT=3,IBCT="Anesth" S IBCHG=$$PANES(SITE,ITLINE) G PROFQ
    109         ;
    110 PROFQ   Q IBCHG
    111         ;
    112 PRBRVS(SITE,ITLINE)     ; Return Professional RBRVS Based Charge
    113         N IBCHG,IBZIP,IBCTI,IBUT,IBAA,IBSCC,IBSCCAAP,IBPEP,IBWE,IBPE,IBCF S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4)
    114         S IBCTI=$P(ITLINE,U,8) I IBCTI'="RBRVS" G PRBRVSQ
    115         S IBUT=$P(ITLINE,U,16) I IBUT'=1 G PRBRVSQ
    116         ;
    117         S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G PRBRVSQ
    118         S IBSCC=$$GETSCC($P(ITLINE,U,6)) S IBSCCAAP=$P(IBSCC,U,4) I 'IBSCCAAP G PRBRVSQ
    119         ;
    120         S IBPEP=$S($P(SITE,U,5)=3:11,1:10) ; provider/non-provider site
    121         ;
    122         S IBWE=$P(ITLINE,U,9)*$P(IBAA,U,7)
    123         S IBPE=$P(ITLINE,U,IBPEP)*$P(IBAA,U,8)
    124         S IBCF=$P(IBSCC,U,3)*$P(IBAA,U,IBSCCAAP)
    125         ;
    126         S IBCHG=(IBWE+IBPE)*IBCF S IBCHG=$J(IBCHG,0,2)
    127         ;
    128 PRBRVSQ Q IBCHG
    129         ;
    130         ;
    131 PTRVU(SITE,ITLINE)      ; Return Professional Total RVU Charge
    132         N IBCHG,IBZIP,IBCTI,IBUT,IBAA,IBSCC,IBSCCAAP,IBUN,IBCF S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4)
    133         S IBCTI=$P(ITLINE,U,8) I IBCTI'="TotalUnits" G PTRVUQ
    134         S IBUT=$P(ITLINE,U,16) I IBUT'=1 G PTRVUQ
    135         ;
    136         S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G PTRVUQ
    137         S IBSCC=$$GETSCC($P(ITLINE,U,6)) S IBSCCAAP=$P(IBSCC,U,4) I 'IBSCCAAP G PTRVUQ
    138         ;
    139         S IBUN=$P(ITLINE,U,12)*$P(IBAA,U,9)
    140         S IBCF=$P(IBSCC,U,3)*$P(IBAA,U,IBSCCAAP)
    141         ;
    142         S IBCHG=IBUN*IBCF S IBCHG=$J(IBCHG,0,2)
    143         ;
    144 PTRVUQ  Q IBCHG
    145         ;
    146 PNW(SITE,ITLINE)        ; Return Professional Nationwide Charge
    147         N IBCHG,IBZIP,IBCTI,IBUT,IBAA,IBSCC,IBSCCAAP S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4)
    148         S IBCTI=$P(ITLINE,U,8) I IBCTI'="NW" G PNWQ
    149         S IBUT=$P(ITLINE,U,16) I IBUT'=1 G PNWQ
    150         ;
    151         S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G PNWQ
    152         S IBSCC=$$GETSCC($P(ITLINE,U,6)) S IBSCCAAP=$P(IBSCC,U,4) I 'IBSCCAAP G PNWQ
    153         ;
    154         S IBCHG=$P(ITLINE,U,14)*$P(IBAA,U,IBSCCAAP) S IBCHG=$J(IBCHG,0,2)
    155         ;
    156 PNWQ    Q IBCHG
    157         ;
    158 PANES(SITE,ITLINE)      ; Return Professional Anesthesia Charge
    159         N IBCHG,IBCHGB,IBZIP,IBCTI,IBUT,IBAA,IBSCC,IBSCCAAP,IBCF S (IBCHG,IBCHGB)=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4)
    160         S IBCTI=$P(ITLINE,U,8) I IBCTI'="Anesth" G PANESQ
    161         S IBUT=$P(ITLINE,U,16) I IBUT'=3 G PANESQ
    162         ;
    163         S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G PANESQ
    164         S IBSCC=$$GETSCC($P(ITLINE,U,6)) S IBSCCAAP=$P(IBSCC,U,4) I 'IBSCCAAP G PANESQ
    165         ;
    166         S IBCF=$P(IBSCC,U,3)*$P(IBAA,U,IBSCCAAP)
    167         ;
    168         S IBCHG=$P(ITLINE,U,14)*IBCF S IBCHG=$J(IBCHG,0,2)
    169         S IBCHGB=$P(ITLINE,U,13)*IBCF S IBCHGB=$J(IBCHGB,0,2)
    170         ;
    171 PANESQ  Q IBCHG_U_IBCHGB
    172         ;
    173         ;
    174         ;
    175         ;
    176 GETAA(ZIP)      ; return Area Factor entry for Zip from Table E
    177         N IBTMPAA,IBAALN,IBDIV,IBDIVLN S IBAALN="",IBTMPAA="IBCR RC E",IBDIV=""
    178         ;
    179         I $G(ZIP)?3N S IBDIV=$O(^XTMP(IBTMPAA,"A",ZIP,0))
    180         I +IBDIV S IBDIVLN=$G(^XTMP(IBTMPAA,IBDIV)) I $P(IBDIVLN,U,1)=ZIP S IBAALN=IBDIVLN
    181         ;
    182         Q IBAALN
    183         ;
    184 GETSCC(SCC)     ; return Service Category Code entry from Table D
    185         N IBTMPSCC,IBSCC,IBSCCLN,IBLN S IBSCCLN="",IBTMPSCC="IBCR RC D",IBSCC=""
    186         ;
    187         I +$G(SCC) S IBSCC=$O(^XTMP(IBTMPSCC,"A",SCC,0))
    188         I +IBSCC S IBLN=$G(^XTMP(IBTMPSCC,IBSCC)) I $P(IBLN,U,1)=SCC S IBSCCLN=IBLN
    189         ;
    190         Q IBSCCLN
     1IBCRHBS8 ;ALB/ARH - RATES: UPLOAD (RC 2+) CALCULATIONS CHARGE ; 10-OCT-03
     2 ;;2.0;INTEGRATED BILLING;**245**;21-MAR-94
     3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
     4 ;
     5 ;
     6ISA(SITE,ITLINE) ; Return Inpatient DRG Standard Ancillary Charge
     7 N IBCHG,IBZIP,IBAA,IBCTI,IBCTIAAP S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4)
     8 I $P(ITLINE,U,2)'="DRG" G ISAQ
     9 ;
     10 S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G ISAQ
     11 S IBCTI=$P($G(ITLINE),U,4),IBCTIAAP=$S(IBCTI="S":3,IBCTI="N":5,1:0) I 'IBCTIAAP G ISAQ
     12 ;
     13 S IBCHG=$P(ITLINE,U,6)*$P(IBAA,U,IBCTIAAP) S IBCHG=$J(IBCHG,0,2)
     14 ;
     15ISAQ Q IBCHG
     16 ;
     17ISR(SITE,ITLINE) ; Return Inpatient DRG Standard Room & Board Charge
     18 N IBCHG,IBZIP,IBAA,IBCTI,IBCTIAAP S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4)
     19 I $P(ITLINE,U,2)'="DRG" G ISRQ
     20 ;
     21 S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G ISRQ
     22 S IBCTI=$P($G(ITLINE),U,4),IBCTIAAP=$S(IBCTI="S":2,IBCTI="N":4,1:0) I 'IBCTIAAP G ISRQ
     23 ;
     24 S IBCHG=$P(ITLINE,U,5)*$P(IBAA,U,IBCTIAAP) S IBCHG=$J(IBCHG,0,2)
     25 ;
     26ISRQ Q IBCHG
     27 ;
     28IIA(SITE,ITLINE) ; Return Inpatient DRG ICU Ancillary Charge
     29 N IBCHG,IBZIP,IBAA,IBCTI,IBCTIAAP S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4)
     30 I $P(ITLINE,U,2)'="DRG" G IIAQ
     31 ;
     32 S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G IIAQ
     33 S IBCTI=$P($G(ITLINE),U,4),IBCTIAAP=$S(IBCTI="S":3,IBCTI="N":5,1:0) I 'IBCTIAAP G IIAQ
     34 ;
     35 S IBCHG=$P(ITLINE,U,8)*$P(IBAA,U,IBCTIAAP) S IBCHG=$J(IBCHG,0,2)
     36 ;
     37IIAQ Q IBCHG
     38 ;
     39IIR(SITE,ITLINE) ; Return Inpatient DRG ICU Room & Board Charge
     40 N IBCHG,IBZIP,IBAA,IBCTI,IBCTIAAP S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4)
     41 I $P(ITLINE,U,2)'="DRG" G IIRQ
     42 ;
     43 S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G IIRQ
     44 S IBCTI=$P($G(ITLINE),U,4),IBCTIAAP=$S(IBCTI="S":2,IBCTI="N":4,1:0) I 'IBCTIAAP G IIRQ
     45 ;
     46 S IBCHG=$P(ITLINE,U,7)*$P(IBAA,U,IBCTIAAP) S IBCHG=$J(IBCHG,0,2)
     47 ;
     48IIRQ Q IBCHG
     49 ;
     50ISNF(SITE,ITLINE) ; Return Inpatient Skilled Nursing Facility Per Diem
     51 N IBCHG,IBZIP,IBAA S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4) I $P(ITLINE,U,2)'="SNF" G ISNFQ
     52 I $P(ITLINE,U,1)'="999" G ISNFQ
     53 ;
     54 S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G ISNFQ
     55 ;
     56 S IBCHG=$P(ITLINE,U,5)*$P(IBAA,U,6) S IBCHG=$J(IBCHG,0,2)
     57 ;
     58ISNFQ Q IBCHG
     59 ;
     60 ;
     61FAC(SITE,ITLINE) ; Return Facility Charge (Table B) for All Charge and Unit Types
     62 ; each line record contains 1 charge that may be calculated in multiple ways
     63 N IBCHG,IBUT S IBCHG=0,SITE=$G(SITE),ITLINE=$G(ITLINE)
     64 ;
     65 S IBUT=$P(ITLINE,U,10)
     66 ;
     67 I IBUT=1 S IBCHG=$$FSTD(SITE,ITLINE) G FACQ
     68 I IBUT=4 S IBCHG=$$FSTD(SITE,ITLINE) G FACQ
     69 I IBUT=2 S IBCHG=$$FHRS(SITE,ITLINE) G FACQ
     70 ;
     71FACQ Q IBCHG
     72 ;
     73FSTD(SITE,ITLINE) ; Return Facility Charge of Unit Type = 1 or 4 (Standard and Miles)
     74 N IBCHG,IBZIP,IBUT,IBAA,IBSCC,IBSCCAAP S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4)
     75 S IBUT=$P(ITLINE,U,10) I IBUT'=1,IBUT'=4 G FSTDQ
     76 ;
     77 S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G FSTDQ
     78 S IBSCC=$$GETSCC($P(ITLINE,U,5)),IBSCCAAP=$P(IBSCC,U,4) I 'IBSCCAAP G FSTDQ
     79 ;
     80 S IBCHG=$P(ITLINE,U,8)*$P(IBAA,U,IBSCCAAP) S IBCHG=$J(IBCHG,0,2)
     81 ;
     82FSTDQ Q IBCHG
     83 ;
     84FHRS(SITE,ITLINE) ; Return Facility Charge of Unit Type = 2 (Hours)
     85 N IBCHG,IBCHGB,IBZIP,IBUT,IBAA,IBSCC,IBSCCAAP S (IBCHG,IBCHGB)=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4)
     86 S IBUT=$P(ITLINE,U,10) I IBUT'=2 G FHRSQ
     87 ;
     88 S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G FHRSQ
     89 S IBSCC=$$GETSCC($P(ITLINE,U,5)),IBSCCAAP=$P(IBSCC,U,4) I 'IBSCCAAP G FHRSQ
     90 ;
     91 S IBCHG=$P(ITLINE,U,8)*$P(IBAA,U,IBSCCAAP) S IBCHG=$J(IBCHG,0,2)
     92 S IBCHGB=$P(ITLINE,U,9)*$P(IBAA,U,IBSCCAAP) S IBCHGB=$J(IBCHGB,0,2)
     93 ;
     94FHRSQ Q IBCHG_U_IBCHGB
     95 ;
     96 ;
     97PROF(SITE,ITLINE) ; Return Professional Charge (Table C) for All Charge and Unit Types
     98 ; each line record contains 1 charge that may be calculated in multiple ways
     99 N IBCHG,IBCT,IBUT S IBCHG=0,SITE=$G(SITE),ITLINE=$G(ITLINE)
     100 ;
     101 S IBCT=$P(ITLINE,U,8)
     102 S IBUT=$P(ITLINE,U,16)
     103 ;
     104 I IBUT=1,IBCT="RBRVS" S IBCHG=$$PRBRVS(SITE,ITLINE) G PROFQ
     105 I IBUT=1,IBCT="TotalUnits" S IBCHG=$$PTRVU(SITE,ITLINE) G PROFQ
     106 I IBUT=1,IBCT="NW" S IBCHG=$$PNW(SITE,ITLINE) G PROFQ
     107 I IBUT=3,IBCT="Anesth" S IBCHG=$$PANES(SITE,ITLINE) G PROFQ
     108 ;
     109PROFQ Q IBCHG
     110 ;
     111PRBRVS(SITE,ITLINE) ; Return Professional RBRVS Based Charge
     112 N IBCHG,IBZIP,IBCTI,IBUT,IBAA,IBSCC,IBSCCAAP,IBPEP,IBWE,IBPE,IBCF S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4)
     113 S IBCTI=$P(ITLINE,U,8) I IBCTI'="RBRVS" G PRBRVSQ
     114 S IBUT=$P(ITLINE,U,16) I IBUT'=1 G PRBRVSQ
     115 ;
     116 S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G PRBRVSQ
     117 S IBSCC=$$GETSCC($P(ITLINE,U,6)) S IBSCCAAP=$P(IBSCC,U,4) I 'IBSCCAAP G PRBRVSQ
     118 ;
     119 S IBPEP=$S($P(SITE,U,5)=3:11,1:10) ; provider/non-provider site
     120 ;
     121 S IBWE=$P(ITLINE,U,9)*$P(IBAA,U,7)
     122 S IBPE=$P(ITLINE,U,IBPEP)*$P(IBAA,U,8)
     123 S IBCF=$P(IBSCC,U,3)*$P(IBAA,U,IBSCCAAP)
     124 ;
     125 S IBCHG=(IBWE+IBPE)*IBCF S IBCHG=$J(IBCHG,0,2)
     126 ;
     127PRBRVSQ Q IBCHG
     128 ;
     129 ;
     130PTRVU(SITE,ITLINE) ; Return Professional Total RVU Charge
     131 N IBCHG,IBZIP,IBCTI,IBUT,IBAA,IBSCC,IBSCCAAP,IBUN,IBCF S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4)
     132 S IBCTI=$P(ITLINE,U,8) I IBCTI'="TotalUnits" G PTRVUQ
     133 S IBUT=$P(ITLINE,U,16) I IBUT'=1 G PTRVUQ
     134 ;
     135 S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G PTRVUQ
     136 S IBSCC=$$GETSCC($P(ITLINE,U,6)) S IBSCCAAP=$P(IBSCC,U,4) I 'IBSCCAAP G PTRVUQ
     137 ;
     138 S IBUN=$P(ITLINE,U,12)*$P(IBAA,U,9)
     139 S IBCF=$P(IBSCC,U,3)*$P(IBAA,U,IBSCCAAP)
     140 ;
     141 S IBCHG=IBUN*IBCF S IBCHG=$J(IBCHG,0,2)
     142 ;
     143PTRVUQ Q IBCHG
     144 ;
     145PNW(SITE,ITLINE) ; Return Professional Nationwide Charge
     146 N IBCHG,IBZIP,IBCTI,IBUT,IBAA,IBSCC,IBSCCAAP S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4)
     147 S IBCTI=$P(ITLINE,U,8) I IBCTI'="NW" G PNWQ
     148 S IBUT=$P(ITLINE,U,16) I IBUT'=1 G PNWQ
     149 ;
     150 S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G PNWQ
     151 S IBSCC=$$GETSCC($P(ITLINE,U,6)) S IBSCCAAP=$P(IBSCC,U,4) I 'IBSCCAAP G PNWQ
     152 ;
     153 S IBCHG=$P(ITLINE,U,14)*$P(IBAA,U,IBSCCAAP) S IBCHG=$J(IBCHG,0,2)
     154 ;
     155PNWQ Q IBCHG
     156 ;
     157PANES(SITE,ITLINE) ; Return Professional Anesthesia Charge
     158 N IBCHG,IBCHGB,IBZIP,IBCTI,IBUT,IBAA,IBSCC,IBSCCAAP,IBCF S (IBCHG,IBCHGB)=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4)
     159 S IBCTI=$P(ITLINE,U,8) I IBCTI'="Anesth" G PANESQ
     160 S IBUT=$P(ITLINE,U,16) I IBUT'=3 G PANESQ
     161 ;
     162 S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G PANESQ
     163 S IBSCC=$$GETSCC($P(ITLINE,U,6)) S IBSCCAAP=$P(IBSCC,U,4) I 'IBSCCAAP G PANESQ
     164 ;
     165 S IBCF=$P(IBSCC,U,3)*$P(IBAA,U,IBSCCAAP)
     166 ;
     167 S IBCHG=$P(ITLINE,U,14)*IBCF S IBCHG=$J(IBCHG,0,2)
     168 S IBCHGB=$P(ITLINE,U,13)*IBCF S IBCHGB=$J(IBCHGB,0,2)
     169 ;
     170PANESQ Q IBCHG_U_IBCHGB
     171 ;
     172 ;
     173 ;
     174 ;
     175GETAA(ZIP) ; return Area Factor entry for Zip from Table E
     176 N IBTMPAA,IBAALN,IBDIV,IBDIVLN S IBAALN="",IBTMPAA="IBCR RC E",IBDIV=""
     177 ;
     178 I $G(ZIP)?3N S IBDIV=$O(^XTMP(IBTMPAA,"A",ZIP,0))
     179 I +IBDIV S IBDIVLN=$G(^XTMP(IBTMPAA,IBDIV)) I $P(IBDIVLN,U,1)=ZIP S IBAALN=IBDIVLN
     180 ;
     181 Q IBAALN
     182 ;
     183GETSCC(SCC) ; return Service Category Code entry from Table D
     184 N IBTMPSCC,IBSCC,IBSCCLN,IBLN S IBSCCLN="",IBTMPSCC="IBCR RC D",IBSCC=""
     185 ;
     186 I +$G(SCC) S IBSCC=$O(^XTMP(IBTMPSCC,"A",SCC,0))
     187 I +IBSCC S IBLN=$G(^XTMP(IBTMPSCC,IBSCC)) I $P(IBLN,U,1)=SCC S IBSCCLN=IBLN
     188 ;
     189 Q IBSCCLN

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSC3.m

    r613 r623  
    1 IBCSC3  ;ALB/MJB - MCCR SCREEN 3 (PAYER/MAILING ADDRESS) ;27 MAY 88 10:15
    2         ;;2.0;INTEGRATED BILLING;**8,43,52,80,82,51,137,232,320,377**;21-MAR-94;Build 23
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5         ;MAP TO DGCRSC3
    6         ;
    7 EN      N IB,IBX,IBINS,Y,Z
    8         I $D(DGRVRCAL) D ^IBCU6 K DGRVRCAL
    9         D ^IBCSCU S IBSR=3,IBSR1="",IBV1="000" I IBV S IBV1="111"
    10         D H^IBCSCU
    11         D:$D(^DGCR(399,IBIFN,"AIC")) 3^IBCVA0
    12         D:'$D(^DGCR(399,IBIFN,"AIC")) 123^IBCVA
    13         D POL^IBCNSU41(DFN)
    14         F I=0,"M","M1","U","U2" S IB(I)=$S($D(^DGCR(399,IBIFN,I)):(^(I)),1:"")
    15         S IBOUTP=2,IBINDT=$S(+$G(IB("U")):+IB("U"),1:DT)
    16         ;
    17         S X=" Rate Type  : "_$S($P(IB(0),U,7)']"":IBU,$D(^DGCR(399.3,$P(IB(0),U,7),0)):$P(^(0),U),1:IBUN)
    18         S Z=1,IBW=1 X IBWW W X
    19         I +$P($G(^IBE(350.9,1,1)),U,22) W $J("",(42-$L(X))),"Form Type: ",$P($G(^IBE(353,+$P(IB(0),U,19),0)),U,1)
    20         W !?4,"Responsible: ",$S($P(IB(0),U,11)']"":IBU,$P(IB(0),U,11)="p":"PATIENT",$P(IB(0),U,11)="i":"INSURER",1:"OTHER")
    21         W ?45,"Payer Sequence: " S IBX=$P(IB(0),U,21) W $S(IBX="P":"Primary",IBX="S":"Secondary",IBX="T":"Tertiary",IBX="A":"Patient",1:"")
    22         I $P(IB(0),U,11)="i" D
    23         . W !?4,"Bill Payer : " S X=$G(^DGCR(399,IBIFN,"MP"))
    24         . W $S(+X:$P($G(^DIC(36,+X,0)),U,1),$$MCRWNR^IBEFUNC($$CURR^IBCEF2(IBIFN)):"MRA NEEDED FROM MEDICARE",1:IBU)
    25         . W ?45,"Transmit: " S Z=0,X=$$TXMT^IBCEF4(IBIFN,.Z)
    26         . W $S(X:"Yes",1:"No-"_$S(Z=1:"Forced to print local",Z=2&($$WNRBILL^IBEFUNC(IBIFN)):"MRA not active",Z=2:"EDI not active",Z=3:"Rate typ transmit off",Z=4:"Ins. co transmit off",Z=5:"Failed RULE #"_$G(Z(0)),Z=6:"Invalid NDC code type",1:"??"))
    27         I $P(IB(0),U,11)']"" G MAIL
    28         I $P(IB(0),U,11)="p" G MAIL
    29         I $P(IB(0),U,11)="o" W !?4,"Inst. Name : ",$S($P(IB("M"),U,11)']"":IBU,$D(^DIC(4,$P(IB("M"),U,11),0)):$P(^(0),U,1),1:"UNKNOWN INSTITUTION") G MAIL
    30         I $P(IB(0),U,11)="i" I $D(IBDD)>1,$D(^DGCR(399,IBIFN,"AIC")) G SHW
    31         D UP G LST:$D(IBDD)>1 W !?4,"Insurance : NO REIMBURSABLE INSURANCE INFORMATION ON FILE",!?17,"[Add Insurance Information by entering '1' at the prompt below]" G MAIL
    32         ;
    33 LST     N IBDTIN,IBICT
    34         S IBDTIN=+$G(IB("U")),IBICT=0
    35         W ! D HDR^IBCNS
    36         S I=0 F  S I=$O(IBDD("S",I)) Q:'I  D  Q:IBICT'<5
    37         .S IBX=0 F  S IBX=$O(IBDD("S",I,IBX)) Q:'IBX  S IBINS=$G(IBDD(IBX,0)) I IBINS'="" S IBICT=IBICT+1 D:IBICT<5 D1^IBCNS I IBICT'<5 W !,?1,"**Patient has additional insurance - use ?INS to see the entire list" Q
    38         G MAIL
    39 LST1    W !?4,$S($D(^DIC(36,+IBDD(IBX,0),0)):$E($P(^(0),"^",1),1,20),1:"UNKNOWN") S X=$P(IBDD(IBX,0),"^",6) W ?26,$S(X="v":"VETERAN",X="s":"SPOUSE",1:"OTHER") S X=$P(IBDD(IBX,0),"^",16)
    40         S X=$S(+X=1:"PATIENT",+X=2:"SPOUSE",+X=3:"CHILD",+X=8:"EMPLOYEE",+X=11:"ORGAN DONOR",+X=18:"PARENT",+X=15:"PLANTIFF",1:"UNKNOWN")
    41         I X="UNKNOWN" S X1=$S($D(IBDD(IBX,0)):$P(IBDD(IBX,0),"^",6),1:""),X=$S(X1="v":"PATIENT",X1="s":"SPOUSE",1:X)
    42         W ?37,X,?49 S Y=$P(IBDD(IBX,0),"^",8) X ^DD("DD") W Y,?64 S Y=$P(IBDD(IBX,0),"^",4) X ^DD("DD") W Y
    43         Q
    44 SHW     I $D(IBDD) S I="" F  S I=$O(IBDD(I)) Q:'I  D SHW1
    45 MAIL    I $$BUFFER^IBCNBU1(DFN) W !!,?17,"***  Patient has Insurance Buffer entries  ***"
    46         ;
    47         S IB("M")=$S($D(^DGCR(399,IBIFN,"M")):^("M"),1:""),IB("M1")=$S($D(^DGCR(399,IBIFN,"M1")):^("M1"),1:""),IB(0)=^DGCR(399,IBIFN,0)
    48         S Z=2,IBW=1 W ! X IBWW
    49         N IBRAMS S IBRAMS=4.06
    50         I $$FT^IBCEF(IBIFN)=3 S IBRAMS=4.08
    51         S IB("RAFLAG",1)=$S($P(IB("M"),U,1)="":0,1:$$GET1^DIQ(36,$P(IB("M"),U,1),IBRAMS,"I"))
    52         S IB("RAFLAG",2)=$S($P(IB("M"),U,2)="":0,1:$$GET1^DIQ(36,$P(IB("M"),U,2),IBRAMS,"I"))
    53         S IB("RAFLAG",3)=$S($P(IB("M"),U,3)="":0,1:$$GET1^DIQ(36,$P(IB("M"),U,3),IBRAMS,"I"))
    54         S X=0
    55         I $P(IB("M1"),U,2)="",'IB("RAFLAG",1),$P(IB("M1"),U,3)="",'IB("RAFLAG",2),$P(IB("M1"),U,4)="",'IB("RAFLAG",3) S X=1
    56         W " Billing Provider Secondary IDs: "
    57         I X W IBUN          ; no data found, unspecified not required
    58         I 'X D              ; data found, display below
    59         . W !?5,"Primary Payer: ",$S($P(IB("M1"),U,2)]"":$P(IB("M1"),U,2),IB("RAFLAG",1):"ATT/REND ID",1:"")
    60         . W !?5,"Secondary Payer: ",$S($P(IB("M1"),U,3)]"":$P(IB("M1"),U,3),IB("RAFLAG",2):"ATT/REND ID",1:"")
    61         . W ?46,"Tertiary Payer: ",$S($P(IB("M1"),U,4)]"":$P(IB("M1"),U,4),IB("RAFLAG",3):"ATT/REND ID",1:"")
    62         . Q
    63         ;
    64         S Z=3,IBW=1 W ! X IBWW
    65         W " Mailing Address : "
    66         S X=+$G(^DGCR(399,IBIFN,"MP"))
    67         I 'X,$$MCRWNR^IBEFUNC(+$$CURR^IBCEF2(IBIFN)) S X=+$$CURR^IBCEF2(IBIFN)
    68         I X,+$G(^DIC(36,X,3)) S I=$P(^(3),U,$S($$FT^IBCEF(IBIFN)=2:2,1:4)) W ?56,"Electronic ID: ",$S(I'="":I,1:"<NONE>")
    69         S X="" I IB("M")]"" F I=4:1:9 Q:X]""  S X=$P(IB("M"),"^",I)
    70         I X']"" W !?4,"NO MAILING ADDRESS HAS BEEN SPECIFIED!",?45,$$UP1,!?4,"Send Bill to PAYER listed above." G ENDSCR
    71         S X=IB("M") W !,?4,$S($P(X,"^",4)]"":$P(X,"^",4),1:"'MAIL TO' PERSON/PLACE UNSPECIFIED"),?45,$$UP1
    72         W !?4,$S($P(X,"^",5)]"":$P(X,"^",5),1:"STREET ADDRESS UNSPECIFIED") W:$P(X,"^",6)]"" ", ",$P(X,"^",6)
    73         W ! W:$P(IB("M1"),"^",1)]"" ?4,$P(IB("M1"),"^",1),", "
    74         W ?4,$S($P(X,"^",7)]"":$P(X,"^",7),1:"CITY UNSPECIFIED"),", ",$S($D(^DIC(5,+$P(X,"^",8),0)):$P(^(0),"^",2),1:"STATE UNSPECIFIED"),"  ",$S($P(X,"^",9)]"":$P(X,"^",9),1:"ZIP UNSPECIFIED")
    75         ;
    76 ENDSCR  K IBADI,IBDD,IBOUTP,IBINDT,I,X,X1
    77         G ^IBCSCP
    78         ;
    79 SHW1    S X=IBDD(I,0),Z=$G(^DIC(36,+X,0))
    80         W !!?4,"Ins ",I,": " W $E($S($P(Z,U,1)'="":$P(Z,U,1),1:IBU),1,16)
    81         I $P(Z,U,2)="N" W ?30,"WILL NOT REIMBURSE"
    82         W ?51,"Policy #: ",$E($S($P(X,"^",2)]"":$P(X,"^",2),1:IBU),1,18)
    83         W !?4,"Grp #: ",$E($S($P(X,"^",3)]"":$P(X,"^",3),1:IBU),1,16)
    84         W ?30,"Whose: ",$S($P(X,"^",6)="v":"VETERAN",$P(X,"^",6)="s":"SPOUSE",1:"OTHER")
    85         W ?51,"Rel to Insd: ",IBIR(I)
    86         W !?4,"Grp Nm: ",$E($S($P(X,"^",15)]"":$P(X,"^",15),1:IBU),1,16)
    87         W ?30,"Insd Sex: ",$S($D(IBISEX(I)):IBISEX(I),1:IBU)
    88         W ?51,"Insured: ",$E($P(X,"^",17),1,19)
    89         Q
    90         ;
    91 UP      K IBDD D ALL^IBCNS1(DFN,"IBDD",2,IBINDT,1)
    92         I $D(IBDD("S",.5)) D  ; At least 1 MCR WNR insurance policy exists
    93         . ;try to put correct part (A for institution and B for facility)
    94         . N Z,IBAB
    95         . S IBAB=$S($$FT^IBCEF(IBIFN)=3:"A",1:"B")
    96         . S Z=0 F  S Z=$O(IBDD("S",.5,Z)) Q:'Z  D
    97         .. I $P($G(IBDD(Z,355.3)),U,14)=IBAB S IBDD("S",.1,Z,0)="" K IBDD("S",.5,Z)
    98         Q
    99         ;
    100 UP1()   ;check if patient has medicare so can print a flag for the user
    101         N IBDD,IBX,IBY S IBY="" D ALL^IBCNS1(DFN,"IBDD",2,IBINDT)
    102         S IBX=0 F  S IBX=$O(IBDD(IBX)) Q:'IBX  I $P($G(IBDD(IBX,355.3)),U,9)=33 S IBY="(Patient has Medicare)"
    103         Q IBY
    104         ;IBCSC3
     1IBCSC3 ;ALB/MJB - MCCR SCREEN 3 (PAYER/MAILING ADDRESS) ;27 MAY 88 10:15
     2 ;;2.0;INTEGRATED BILLING;**8,43,52,80,82,51,137,232,320**;21-MAR-94
     3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
     4 ;
     5 ;MAP TO DGCRSC3
     6 ;
     7EN N IB,IBX,IBINS,Y,Z
     8 I $D(DGRVRCAL) D ^IBCU6 K DGRVRCAL
     9 D ^IBCSCU S IBSR=3,IBSR1="",IBV1="000" I IBV S IBV1="111"
     10 D H^IBCSCU
     11 D:$D(^DGCR(399,IBIFN,"AIC")) 3^IBCVA0
     12 D:'$D(^DGCR(399,IBIFN,"AIC")) 123^IBCVA
     13 D POL^IBCNSU41(DFN)
     14 F I=0,"M","M1","U","U2" S IB(I)=$S($D(^DGCR(399,IBIFN,I)):(^(I)),1:"")
     15 S IBOUTP=2,IBINDT=$S(+$G(IB("U")):+IB("U"),1:DT)
     16 ;S Z=1,IBW=1 X IBWW W " Rate Type  : ",$S($P(IB(0),U,7)']"":IBU,$D(^DGCR(399.3,$P(IB(0),U,7),0)):$P(^(0),U),1:IBUN)
     17 ;
     18 S X=" Rate Type  : "_$S($P(IB(0),U,7)']"":IBU,$D(^DGCR(399.3,$P(IB(0),U,7),0)):$P(^(0),U),1:IBUN)
     19 S Z=1,IBW=1 X IBWW W X
     20 I +$P($G(^IBE(350.9,1,1)),U,22) W $J("",(42-$L(X))),"Form Type: ",$P($G(^IBE(353,+$P(IB(0),U,19),0)),U,1)
     21 W !?4,"Responsible: ",$S($P(IB(0),U,11)']"":IBU,$P(IB(0),U,11)="p":"PATIENT",$P(IB(0),U,11)="i":"INSURER",1:"OTHER")
     22 W ?45,"Payer Sequence: " S IBX=$P(IB(0),U,21) W $S(IBX="P":"Primary",IBX="S":"Secondary",IBX="T":"Tertiary",IBX="A":"Patient",1:"")
     23 I $P(IB(0),U,11)="i" D
     24 . W !?4,"Bill Payer : " S X=$G(^DGCR(399,IBIFN,"MP"))
     25 . W $S(+X:$P($G(^DIC(36,+X,0)),U,1),$$MCRWNR^IBEFUNC($$CURR^IBCEF2(IBIFN)):"MRA NEEDED FROM MEDICARE",1:IBU)
     26 . W ?45,"Transmit: " S Z=0,X=$$TXMT^IBCEF4(IBIFN,.Z)
     27 . W $S(X:"Yes",1:"No-"_$S(Z=1:"Forced to print local",Z=2&($$WNRBILL^IBEFUNC(IBIFN)):"MRA not active",Z=2:"EDI not active",Z=3:"Rate typ transmit off",Z=4:"Ins. co transmit off",Z=5:"Failed RULE #"_$G(Z(0)),Z=6:"Invalid NDC code type",1:"??"))
     28 I $P(IB(0),U,11)']"" G MAIL
     29 I $P(IB(0),U,11)="p" G MAIL
     30 I $P(IB(0),U,11)="o" W !?4,"Inst. Name : ",$S($P(IB("M"),U,11)']"":IBU,$D(^DIC(4,$P(IB("M"),U,11),0)):$P(^(0),U,1),1:"UNKNOWN INSTITUTION") G MAIL
     31 I $P(IB(0),U,11)="i" I $D(IBDD)>1,$D(^DGCR(399,IBIFN,"AIC")) G SHW
     32 D UP G LST:$D(IBDD)>1 W !?4,"Insurance : NO REIMBURSABLE INSURANCE INFORMATION ON FILE",!?17,"[Add Insurance Information by entering '1' at the prompt below]" G MAIL
     33 ;W !?4,"Insurance Carrier",?40,"Whose",?66,"Relationship" S X="",$P(X,"=",81)="" W !,X
     34LST N IBDTIN,IBICT
     35 S IBDTIN=+$G(IB("U")),IBICT=0
     36 W ! D HDR^IBCNS
     37 S I=0 F  S I=$O(IBDD("S",I)) Q:'I  D  Q:IBICT'<5
     38 .S IBX=0 F  S IBX=$O(IBDD("S",I,IBX)) Q:'IBX  S IBINS=$G(IBDD(IBX,0)) I IBINS'="" S IBICT=IBICT+1 D:IBICT<5 D1^IBCNS I IBICT'<5 W !,?1,"**Patient has additional insurance - use ?INS to see the entire list" Q
     39 G MAIL
     40LST1 W !?4,$S($D(^DIC(36,+IBDD(IBX,0),0)):$E($P(^(0),"^",1),1,20),1:"UNKNOWN") S X=$P(IBDD(IBX,0),"^",6) W ?26,$S(X="v":"VETERAN",X="s":"SPOUSE",1:"OTHER") S X=$P(IBDD(IBX,0),"^",16)
     41 S X=$S(+X=1:"PATIENT",+X=2:"SPOUSE",+X=3:"CHILD",+X=8:"EMPLOYEE",+X=11:"ORGAN DONOR",+X=18:"PARENT",+X=15:"PLANTIFF",1:"UNKNOWN")
     42 I X="UNKNOWN" S X1=$S($D(IBDD(IBX,0)):$P(IBDD(IBX,0),"^",6),1:""),X=$S(X1="v":"PATIENT",X1="s":"SPOUSE",1:X)
     43 W ?37,X,?49 S Y=$P(IBDD(IBX,0),"^",8) X ^DD("DD") W Y,?64 S Y=$P(IBDD(IBX,0),"^",4) X ^DD("DD") W Y
     44 Q
     45SHW I $D(IBDD) S I="" F  S I=$O(IBDD(I)) Q:'I  D SHW1
     46MAIL I $$BUFFER^IBCNBU1(DFN) W !!,?17,"***  Patient has Insurance Buffer entries  ***"
     47 S IB("M")=$S($D(^DGCR(399,IBIFN,"M")):^("M"),1:""),IB("M1")=$S($D(^DGCR(399,IBIFN,"M1")):^("M1"),1:""),IB(0)=^DGCR(399,IBIFN,0)
     48 S Z=2,IBW=1 W ! X IBWW
     49 N IBRAMS S IBRAMS=4.06
     50 I $$FT^IBCEF(IBIFN)=3 S IBRAMS=4.08
     51 S IB("RAFLAG",1)=$S($P(IB("M"),U,1)="":0,1:$$GET1^DIQ(36,$P(IB("M"),U,1),IBRAMS,"I"))
     52 S IB("RAFLAG",2)=$S($P(IB("M"),U,2)="":0,1:$$GET1^DIQ(36,$P(IB("M"),U,2),IBRAMS,"I"))
     53 S IB("RAFLAG",3)=$S($P(IB("M"),U,3)="":0,1:$$GET1^DIQ(36,$P(IB("M"),U,3),IBRAMS,"I"))
     54 S X=0 I $P(IB("M1"),U,2)="",'IB("RAFLAG",1),$P(IB("M1"),U,3)="",'IB("RAFLAG",2),$P(IB("M1"),U,4)="",'IB("RAFLAG",3) S X=1 W " Facility ID #s: ",IBUN
     55 I 'X D
     56 . W " Primary Payer: ",$S($P(IB("M1"),U,2)]"":$P(IB("M1"),U,2),IB("RAFLAG",1):"ATT/REND ID",1:"")
     57 . W !?4,"Secondary Payer: ",$S($P(IB("M1"),U,3)]"":$P(IB("M1"),U,3),IB("RAFLAG",2):"ATT/REND ID",1:"")
     58 . W ?45,"Tertiary Payer: ",$S($P(IB("M1"),U,4)]"":$P(IB("M1"),U,4),IB("RAFLAG",3):"ATT/REND ID",1:"")
     59 S Z=3,IBW=1 W ! X IBWW
     60 W " Mailing Address : "
     61 S X=+$G(^DGCR(399,IBIFN,"MP"))
     62 I 'X,$$MCRWNR^IBEFUNC(+$$CURR^IBCEF2(IBIFN)) S X=+$$CURR^IBCEF2(IBIFN)
     63 I X,+$G(^DIC(36,X,3)) S I=$P(^(3),U,$S($$FT^IBCEF(IBIFN)=2:2,1:4)) W ?56,"Electronic ID: ",$S(I'="":I,1:"<NONE>")
     64 S X="" I IB("M")]"" F I=4:1:9 Q:X]""  S X=$P(IB("M"),"^",I)
     65 I X']"" W !?4,"NO MAILING ADDRESS HAS BEEN SPECIFIED!",?45,$$UP1,!?4,"Send Bill to PAYER listed above." G ENDSCR
     66 S X=IB("M") W !,?4,$S($P(X,"^",4)]"":$P(X,"^",4),1:"'MAIL TO' PERSON/PLACE UNSPECIFIED"),?45,$$UP1
     67 W !?4,$S($P(X,"^",5)]"":$P(X,"^",5),1:"STREET ADDRESS UNSPECIFIED") W:$P(X,"^",6)]"" ", ",$P(X,"^",6)
     68 W ! W:$P(IB("M1"),"^",1)]"" ?4,$P(IB("M1"),"^",1),", "
     69 W ?4,$S($P(X,"^",7)]"":$P(X,"^",7),1:"CITY UNSPECIFIED"),", ",$S($D(^DIC(5,+$P(X,"^",8),0)):$P(^(0),"^",2),1:"STATE UNSPECIFIED"),"  ",$S($P(X,"^",9)]"":$P(X,"^",9),1:"ZIP UNSPECIFIED")
     70 ;
     71ENDSCR K IBADI,IBDD,IBOUTP,IBINDT,I,X,X1
     72 G ^IBCSCP
     73 ;
     74SHW1 S X=IBDD(I,0),Z=$G(^DIC(36,+X,0))
     75 W !!?4,"Ins ",I,": " W $E($S($P(Z,U,1)'="":$P(Z,U,1),1:IBU),1,16)
     76 I $P(Z,U,2)="N" W ?30,"WILL NOT REIMBURSE"
     77 W ?51,"Policy #: ",$E($S($P(X,"^",2)]"":$P(X,"^",2),1:IBU),1,18)
     78 W !?4,"Grp #: ",$E($S($P(X,"^",3)]"":$P(X,"^",3),1:IBU),1,16)
     79 W ?30,"Whose: ",$S($P(X,"^",6)="v":"VETERAN",$P(X,"^",6)="s":"SPOUSE",1:"OTHER")
     80 W ?51,"Rel to Insd: ",IBIR(I)
     81 W !?4,"Grp Nm: ",$E($S($P(X,"^",15)]"":$P(X,"^",15),1:IBU),1,16)
     82 W ?30,"Insd Sex: ",$S($D(IBISEX(I)):IBISEX(I),1:IBU)
     83 W ?51,"Insured: ",$E($P(X,"^",17),1,19)
     84 Q
     85 ;
     86UP K IBDD D ALL^IBCNS1(DFN,"IBDD",2,IBINDT,1)
     87 I $D(IBDD("S",.5)) D  ; At least 1 MCR WNR insurance policy exists
     88 . ;try to put correct part (A for institution and B for facility)
     89 . N Z,IBAB
     90 . S IBAB=$S($$FT^IBCEF(IBIFN)=3:"A",1:"B")
     91 . S Z=0 F  S Z=$O(IBDD("S",.5,Z)) Q:'Z  D
     92 .. I $P($G(IBDD(Z,355.3)),U,14)=IBAB S IBDD("S",.1,Z,0)="" K IBDD("S",.5,Z)
     93 Q
     94 ;
     95UP1() ;check if patient has medicare so can print a flag for the user
     96 N IBDD,IBX,IBY S IBY="" D ALL^IBCNS1(DFN,"IBDD",2,IBINDT)
     97 S IBX=0 F  S IBX=$O(IBDD(IBX)) Q:'IBX  I $P($G(IBDD(IBX,355.3)),U,9)=33 S IBY="(Patient has Medicare)"
     98 Q IBY
     99 ;IBCSC3

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSC5.m

    r613 r623  
    1 IBCSC5  ;ALB/MJB - MCCR SCREEN 5 (OPT. EOC) ;27 MAY 88 10:15
    2         ;;2.0;INTEGRATED BILLING;**52,125,51,210,266,288,287,309,389**;21-MAR-94;Build 6
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5         ;MAP TO DGCRSC5
    6         ;
    7 EN      I $$INPAT^IBCEF(IBIFN) G ^IBCSC4
    8         I $D(IBASKCOD) K IBASKCOD D CODMUL^IBCU7 I $$BILLCPT^IBCRU4(IBIFN) D ASK^IBCU7A(IBIFN) S DGRVRCAL=1
    9         I $D(DGRVRCAL) D ^IBCU6 K DGRVRCAL
    10         L ^DGCR(399,IBIFN):1
    11         D ^IBCSCU S IBSR=5,IBSR1="",IBV1="10000000"_$S($$FT^IBCEF(IBIFN)'=2:0,1:1) F I="U",0 S IB(I)=$S($D(^DGCR(399,IBIFN,I)):^(I),1:"") S:IBV IBV1="111111111"
    12         D H^IBCSCU
    13         S IBPTF=$P(IB(0),U,8),IBBT=$P(IB(0),"^",4)_$P(IB(0),"^",5)_$P(IB(0),"^",6)
    14         D EN4^IBCVA1
    15         S Z=1,IBW=1 X IBWW W " Event Date : " S Y=$P(IB(0),U,3) D DT^DIQ
    16         N IBPOARR,IBDATE
    17         D SET^IBCSC4D(IBIFN,"",.IBPOARR)
    18         S IBDATE=$$BDATE^IBACSV(IBIFN) ; Event date
    19         S Z=2,IBW=1 X IBWW W " Prin. Diag.: " S Y=$$DX^IBCSC4(0,IBDATE) W $S(Y'="":$P(Y,U,4)_" - "_$P(Y,U,2),$$DXREQ^IBCSC4(IBIFN):IBU,1:IBUN)
    20         F I=1:1:4 S Y=$$DX^IBCSC4(+Y,IBDATE) Q:Y=""  W !?4,"Other Diag.: ",$P(Y,U,4)_" - "_$P(Y,U,2)
    21         I +Y S Y=$$DX^IBCSC4(+Y,IBDATE) I +Y W !?4,"***There are more diagnoses associated with this bill.***"
    22 OP      S Z=3,IBW=1 X IBWW W " OP Visits  : " F I=0:0 S I=$O(^DGCR(399,IBIFN,"OP",I)) Q:'I  S Y=I X ^DD("DD") W:$X>67 !?17 W Y_", "
    23         S:$D(^DGCR(399,"OP")) DGOPV=1 I '$O(^DGCR(399,IBIFN,"OP",0)) W IBU
    24         S Z=4,IBW=1 X IBWW W " Cod. Method: ",$S($P(IB(0),U,9)="":IBUN,$P(IB(0),U,9)=9:"ICD-9-CM",$P(IB(0),U,9)=4:"CPT-4",1:"HCPCS")
    25         D WRT:$D(IBPROC)
    26         S Z=5,IBW=1 X IBWW W " Rx. Refills: " S Y=$$RX I 'Y W IBUN
    27 OCC     G OCC^IBCSC4
    28         W !?4,"Opt. Code  : ",IBUN
    29         G OCC^IBCSC4
    30         Q
    31 MORE    W !?4,*7,"***There are more procedures associated with this bill.***" S I=0
    32         Q
    33 WRT     ;  -write out procedures codes on screen
    34         N IBDATE
    35         S J=0 F I=1:1 S J=$O(IBPROC(J)) Q:'J  D  I I>6 D MORE Q
    36         .S IBDATE=$P(IBPROC(J),U,2) I 'IBDATE S IBDATE=$$BDATE^IBACSV($G(IBIFN))
    37         .S X=$$PRCD^IBCEF1($P(IBPROC(J),U),1,IBDATE)
    38         .I IBPROC(J)["ICD" W !?4,"ICD Code   : ",$E($P(X,U,3),1,28)_" - "_$P(X,U,2)
    39         .I IBPROC(J)["CPT" W !?4,"CPT Code   : " D
    40         .. N Z
    41         .. S Z=$P(X,"^",3)_" "_$P(X,"^",2)_$S($P(IBPROC(J),U,15):"-"_$$MODLST^IBEFUNC2($P(IBPROC(J),U,15)),1:"")
    42         .. I $L(Z)>40 S Z=" "_$P(X,"^",2)_$S($P(IBPROC(J),U,15):"-"_$$MODLST^IBEFUNC2($P(IBPROC(J),U,15)),1:""),Z=$E($P(X,U,3),1,40-$L(Z))_Z
    43         .. W Z
    44         .I $P(IB(0),U,19)=2 S Y=+$P(IBPROC(J),U,11) S:+Y Y=+$G(^IBA(362.3,+Y,0)) W ?58,$P($$ICD9^IBACSV(Y,IBDATE),U) S Y=$P(IBPROC(J),U,2) D D^DIQ W ?67,Y Q
    45         .S Y=$P(IBPROC(J),"^",2) D D^DIQ W ?67,Y
    46         Q
    47         ;
    48 MOD(IBM,PUNC)   ; Returns modifier list from comma delimited ien's in string IBM
    49         ; PUNC = Punctuation to use as first character of output
    50         N IBMOD,Q
    51         S IBMOD=""
    52         F Q=1:1:$L(IBM,",") I $P(IBM,",",Q)'="" S IBMOD=IBMOD_$S(IBMOD'="":",",1:"")_$P($$MOD^ICPTMOD($P(IBM,",",Q),"I"),U,2)
    53         I IBMOD'="" S IBMOD=$G(PUNC)_IBMOD
    54         Q IBMOD
    55         ;
    56 PD()    ;prints prosthetic device in external form, returns 0 if there are none
    57         N IBX,IBY,IBZ,IBN,X S X=0 S IBX=0 F  S IBX=$O(^IBA(362.5,"AIFN"_IBIFN,IBX)) Q:'IBX  D  Q:X>5
    58         . S IBY=0 F  S IBY=$O(^IBA(362.5,"AIFN"_IBIFN,IBX,IBY)) Q:'IBY  S IBZ=$G(^IBA(362.5,IBY,0)) I IBZ'="" D  Q:X>5
    59         .. S X=X+1 I X>5 W !,?17,"*** There are more Pros. Items associated with this bill.***" Q
    60         .. W:X'=1 ! W ?17,$E($P(IBZ,U,5),1,40),?67,$$FMTE^XLFDT(+IBZ)
    61         Q X
    62         ;
    63 RX()    ;prints RX REFILLS in external form, returns 0 if there are none
    64         N IBX,IBY,IBZ,IBN,X S X=0 S IBX="" F  S IBX=$O(^IBA(362.4,"AIFN"_IBIFN,IBX)) Q:IBX=""  D  Q:X>5
    65         . S IBY=0 F  S IBY=$O(^IBA(362.4,"AIFN"_IBIFN,IBX,IBY)) Q:'IBY  S IBZ=$G(^IBA(362.4,IBY,0)) I IBZ'="" D  Q:X>5
    66         .. S X=X+1 I X>5 W !,?17,"*** There are more Rx. Refills associated with this bill.***" Q
    67         ..D ZERO^IBRXUTL(+$P(IBZ,U,4))
    68         .. S IBN=$G(^TMP($J,"IBDRUG",+$P(IBZ,U,4),.01)) W:X'=1 ! W ?17,IBN,?65,$$FMTE^XLFDT(+$P(IBZ,U,3))
    69         K ^TMP($J,"IBDRUG")
    70         Q X
    71         ;
    72         ;IBCSC5
     1IBCSC5 ;ALB/MJB - MCCR SCREEN 5 (OPT. EOC) ;27 MAY 88 10:15
     2 ;;2.0;INTEGRATED BILLING;**52,125,51,210,266,288,287,309**;21-MAR-94
     3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
     4 ;
     5 ;MAP TO DGCRSC5
     6 ;
     7EN I $$INPAT^IBCEF(IBIFN) G ^IBCSC4
     8 I $D(IBASKCOD) K IBASKCOD D CODMUL^IBCU7 I $$BILLCPT^IBCRU4(IBIFN) D ASK^IBCU7A(IBIFN) S DGRVRCAL=1
     9 I $D(DGRVRCAL) D ^IBCU6 K DGRVRCAL
     10 L ^DGCR(399,IBIFN):1
     11 D ^IBCSCU S IBSR=5,IBSR1="",IBV1="10000000"_$S($$FT^IBCEF(IBIFN)'=2:0,1:1) F I="U",0 S IB(I)=$S($D(^DGCR(399,IBIFN,I)):^(I),1:"") S:IBV IBV1="111111111"
     12 D H^IBCSCU
     13 S IBPTF=$P(IB(0),U,8),IBBT=$P(IB(0),"^",4)_$P(IB(0),"^",5)_$P(IB(0),"^",6)
     14 D EN4^IBCVA1
     15 S Z=1,IBW=1 X IBWW W " Event Date : " S Y=$P(IB(0),U,3) D DT^DIQ
     16 N IBPOARR,IBDATE
     17 D SET^IBCSC4D(IBIFN,"",.IBPOARR)
     18 S IBDATE=$$BDATE^IBACSV(IBIFN) ; Event date
     19 S Z=2,IBW=1 X IBWW W " Prin. Diag.: " S Y=$$DX^IBCSC4(0,IBDATE) W $S(Y'="":$P(Y,U,4)_" - "_$P(Y,U,2),$$DXREQ^IBCSC4(IBIFN):IBU,1:IBUN)
     20 F I=1:1:4 S Y=$$DX^IBCSC4(+Y,IBDATE) Q:Y=""  W !?4,"Other Diag.: ",$P(Y,U,4)_" - "_$P(Y,U,2)
     21 I +Y S Y=$$DX^IBCSC4(+Y,IBDATE) I +Y W !?4,"***There are more diagnoses associated with this bill.***"
     22OP S Z=3,IBW=1 X IBWW W " OP Visits  : " F I=0:0 S I=$O(^DGCR(399,IBIFN,"OP",I)) Q:'I  S Y=I X ^DD("DD") W:$X>67 !?17 W Y_", "
     23 S:$D(^DGCR(399,"OP")) DGOPV=1 I '$O(^DGCR(399,IBIFN,"OP",0)) W IBU
     24 S Z=4,IBW=1 X IBWW W " Cod. Method: ",$S($P(IB(0),U,9)="":IBUN,$P(IB(0),U,9)=9:"ICD-9-CM",$P(IB(0),U,9)=4:"CPT-4",1:"HCPCS")
     25 D WRT:$D(IBPROC)
     26 S Z=5,IBW=1 X IBWW W " Rx. Refills: " S Y=$$RX I 'Y W IBUN
     27OCC G OCC^IBCSC4
     28 W !?4,"Opt. Code  : ",IBUN
     29 G OCC^IBCSC4
     30 Q
     31MORE W !?4,*7,"***There are more procedures associated with this bill.***" S I=0
     32 Q
     33WRT ;  -write out procedures codes on screen
     34 N IBDATE
     35 S J=0 F I=1:1 S J=$O(IBPROC(J)) Q:'J  D  I I>6 D MORE Q
     36 .S IBDATE=$P(IBPROC(J),U,2) I 'IBDATE S IBDATE=$$BDATE^IBACSV($G(IBIFN))
     37 .S X=$$PRCD^IBCEF1($P(IBPROC(J),U),1,IBDATE)
     38 .I IBPROC(J)["ICD" W !?4,"ICD Code   : ",$E($P(X,U,3),1,28)_" - "_$P(X,U,2)
     39 .I IBPROC(J)["CPT" W !?4,"CPT Code   : " D
     40 .. N Z
     41 .. S Z=$P(X,"^",3)_" "_$P(X,"^",2)_$S($P(IBPROC(J),U,15):"-"_$$MODLST^IBEFUNC2($P(IBPROC(J),U,15)),1:"")
     42 .. I $L(Z)>40 S Z=" "_$P(X,"^",2)_$S($P(IBPROC(J),U,15):"-"_$$MODLST^IBEFUNC2($P(IBPROC(J),U,15)),1:""),Z=$E($P(X,U,3),1,40-$L(Z))_Z
     43 .. W Z
     44 .I $P(IB(0),U,19)=2 S Y=+$P(IBPROC(J),U,11) S:+Y Y=+$G(^IBA(362.3,+Y,0)) W ?58,$P($$ICD9^IBACSV(Y,IBDATE),U) S Y=$P(IBPROC(J),U,2) D D^DIQ W ?67,Y Q
     45 .S Y=$P(IBPROC(J),"^",2) D D^DIQ W ?67,Y
     46 Q
     47 ;
     48MOD(IBM,PUNC) ; Returns modifier list from comma delimited ien's in string IBM
     49 ; PUNC = Punctuation to use as first character of output
     50 N IBMOD,Q
     51 S IBMOD=""
     52 F Q=1:1:$L(IBM,",") I $P(IBM,",",Q)'="" S IBMOD=IBMOD_$S(IBMOD'="":",",1:"")_$P($$MOD^ICPTMOD($P(IBM,",",Q),"I"),U,2)
     53 I IBMOD'="" S IBMOD=$G(PUNC)_IBMOD
     54 Q IBMOD
     55 ;
     56PD() ;prints prosthetic device in external form, returns 0 if there are none
     57 N IBX,IBY,IBZ,IBN,X S X=0 S IBX=0 F  S IBX=$O(^IBA(362.5,"AIFN"_IBIFN,IBX)) Q:'IBX  D  Q:X>5
     58 . S IBY=0 F  S IBY=$O(^IBA(362.5,"AIFN"_IBIFN,IBX,IBY)) Q:'IBY  S IBZ=$G(^IBA(362.5,IBY,0)) I IBZ'="" D  Q:X>5
     59 .. S X=X+1 I X>5 W !,?17,"*** There are more Pros. Items associated with this bill.***" Q
     60 .. ;S IBN=$G(^RMPR(661,+$P(IBZ,U,3),0)) W:X'=1 ! W ?17,$E($$PIN^IBCSC5B(+IBN),1,35)," - ",$P(IBN,U,1),?65,$$FMTE^XLFDT(+IBZ)
     61 .. S IBN=$$PIN^IBCSC5B(+$P(IBZ,U,3)) W:X'=1 ! W ?17,$E($P(IBN,U,2),1,35)," - ",$P(IBN,U,1),?65,$$FMTE^XLFDT(+IBZ)
     62 Q X
     63 ;
     64RX() ;prints RX REFILLS in external form, returns 0 if there are none
     65 N IBX,IBY,IBZ,IBN,X S X=0 S IBX="" F  S IBX=$O(^IBA(362.4,"AIFN"_IBIFN,IBX)) Q:IBX=""  D  Q:X>5
     66 . S IBY=0 F  S IBY=$O(^IBA(362.4,"AIFN"_IBIFN,IBX,IBY)) Q:'IBY  S IBZ=$G(^IBA(362.4,IBY,0)) I IBZ'="" D  Q:X>5
     67 .. S X=X+1 I X>5 W !,?17,"*** There are more Rx. Refills associated with this bill.***" Q
     68 ..D ZERO^IBRXUTL(+$P(IBZ,U,4))
     69 .. S IBN=$G(^TMP($J,"IBDRUG",+$P(IBZ,U,4),.01)) W:X'=1 ! W ?17,IBN,?65,$$FMTE^XLFDT(+$P(IBZ,U,3))
     70 K ^TMP($J,"IBDRUG")
     71 Q X
     72 ;
     73 ;IBCSC5

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSC5B.m

    r613 r623  
    1 IBCSC5B ;ALB/ARH - ADD/ENTER PROSTHETIC ITEMS ;12/28/93
    2         ;;2.0;INTEGRATED BILLING;**4,52,260,339,389**;21-MAR-94;Build 6
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5         ;
    6 EN      ; add/edit prosthetic items for a bill, IBIFN required
    7         N IBX,DFN,IBDT1,IBDT2,IBACTION,BIFN,APROS,ALPROS,ABILL,ALBILL
    8         S IBX=$$BILL(IBIFN) Q:'IBIFN  S DFN=+IBX,IBDT1=$P(IBX,U,2),IBDT2=$P(IBX,U,3)
    9         ;
    10 EN1     D PISET(DFN,IBDT1,IBDT2,.APROS,.ALPROS) D SET(IBIFN,.ABILL,.ALBILL,+$G(APROS))
    11         D PIDISP(.APROS,.ALPROS,.ABILL) D DISP(.ABILL,.ALBILL) S BIFN=""
    12         ;
    13         S IBACTION=$$SELECT(.ALPROS,.ALBILL) Q:'IBACTION
    14         I +IBACTION=1 S BIFN=$$ADD(IBIFN,$P(IBACTION,U,2),$P(IBACTION,U,3)) G EN1
    15         I +IBACTION=2 S BIFN=+$G(ABILL(+$P(IBACTION,U,2),$P(IBACTION,U,3)))
    16         I +IBACTION=3 S IBX=$$ASKITM(IBDT1,IBDT2) I +IBX S BIFN=$$ADD(IBIFN,+IBX,,$P(IBX,U,2))
    17         I +BIFN D EDIT(BIFN)
    18         ;
    19         G EN1
    20         Q
    21         ;
    22 SELECT(ALPROS,ALBILL)   ; get which item to add/edit, select from Patient Prosthetics, Bill Items, or add a new one
    23         ; returns 1 ^ PD DEL DATE ^ PI IFN - ALPROS(selected item) if item from Prosthetics selected
    24         ;         2 ^ PD DEL DATE ^ X      - ALBILL(selected item) if item existing on bill selected
    25         ;         3 if add new item, "" if exit, -1 if redo
    26         N IBX,IBY,IBZ,DIR,DTOUT,DUOUT,DIRUT,X,Y S IBY=""
    27         S DIR("?")="Select the Prosthetics Item to Add or Edit."
    28         S DIR("?",1)="Enter the number preceding the Item to Add or Edit."
    29         S DIR("?",2)="Or enter the Item name to add an item not in the list and not in Prosthetics.",DIR("?",3)=" "
    30         ;
    31         S DIR("A")="Select Prosthetics Item",DIR(0)="FO^1:20^K:X?1N1P.NP X" D ^DIR S IBX=Y I $D(DIRUT) G SELECTQ
    32         ;
    33         S IBZ=$G(ALPROS(IBX)) I +IBZ W "  adding ",IBX S IBY="1^"_IBZ G SELECTQ
    34         S IBZ=$G(ALBILL(IBX)) I +IBZ W "  editing ",IBX S IBY="2^"_IBZ G SELECTQ
    35         ;
    36         S DIR(0)="YO",DIR("A")="Add a New Item",DIR("B")="YES" D ^DIR K DIR S IBY=-1 I Y=1,'$D(DIRUT) S IBY=3
    37         ;
    38 SELECTQ Q IBY
    39         ;
    40 ASKITM(IBDT1,IBDT2)     ; Ask for new item data when adding an item not in Prosthetics
    41         ; returns:  delivery date ^ prosthetic item name (from 661.1, .02)
    42         N DIR,DIC,DIE,DTOUT,DUOUT,DIRUT,X,Y,IBX,IBY S (IBX,IBY)="" I '$G(IBDT1)!'$G(IBDT2) G ASKITMQ
    43         ;
    44         W !!,"Enter a Prosthetics Item that does not have a Prosthetics Patient record.",!
    45         S DIR("A")="Select ITEM DELIVERY DATE",DIR(0)="DO^"_IBDT1_":"_IBDT2_":EX" D ^DIR S IBX=Y I Y'?7N G ASKITMQ
    46         ;
    47         S DIC="^RMPR(661.1,",DIC(0)="AENOQMZ",DIC("S")="I +$P(^(0),U,5)",DIC("A")="Select PROSTHETICS ITEM: " D ^DIC
    48         ;
    49         I +Y>0,+IBX S IBY=IBX_U_$P($G(Y(0)),U,2)
    50         ;
    51 ASKITMQ Q IBY
    52         ;
    53 ADD(IBIFN,IBDT,PIFN,IBPNAME)    ; Add new Item to Bill (#362.5)
    54         N IBX,IBY,IBDX,IBHCPCS,DIC,DIE,DA,DR,DLAYGO,X,Y S IBY=0,PIFN=+$G(PIFN) I ($G(IBDT)'?7N)!('$G(IBIFN)) G ADDQ
    55         ;
    56         I $G(PIFN),$$ONBILLPI(IBIFN,PIFN) G ADDQ ; don't add duplicates
    57         I $G(IBPNAME)="" S IBPNAME=$P($$PIN(PIFN),U,2) I IBPNAME="" G ADDQ
    58         ;
    59         S DIC="^IBA(362.5,",DIC(0)="AQL",DLAYGO=362.5,X=IBDT K DA,DO D FILE^DICN K DA,DO,X
    60         I Y>0 S (IBY,DA)=+Y,DIE=DIC,DR=".02////"_IBIFN_";.04////"_+PIFN_";.05///^S X=IBPNAME" D ^DIE K DIE,DA,DR W "... ADDED"
    61         ;
    62         ;add dx if known
    63         I +IBY,+PIFN F IBX=1:1:4 S IBDX=+$G(^RMPR(660,PIFN,"BA"_IBX)) I IBDX,'$O(^IBA(362.3,"AIFN"_IBIFN,IBDX)) D
    64         . S DIC="^IBA(362.3,",DIC(0)="L",DLAYGO=362.3,X=IBDX,DIC("DR")=".02////"_IBIFN K DD,DO D FILE^DICN S IBDX(+Y)=""
    65         ;add hcpcs if known ;S IBHCPCS=$P($G(^RMPR(660,PIEN,0)),"^",22) I IBHCPCS
    66         ;
    67 ADDQ    Q IBY
    68         ;
    69 EDIT(BIFN)      ;
    70         N DIDEL,DIE,DIC,DR,DA,X,Y Q:'$G(BIFN)  W ! S DIDEL=362.5,DIE="^IBA(362.5,",DR=".01;.05",DA=BIFN D ^DIE
    71         Q
    72         ;
    73 SET(IBIFN,ARRB,ARRBL,PICNT)     ; setup array of all prosthetic devices on bill (#362.5), array names should be passed by reference
    74         ; input:   PICNT - the number of items found in prosthetics (PISET)
    75         ; output:  ARRB(PD DELIV DATE, X) = PD IFN (362.5 ptr) ^ Cost,  ARRB = BILL IFN ^ count of items on bill
    76         ;          ARRBL(PICNT + count of item on bill) = PD DELIV DATE ^ X
    77         ;          where X is the IFN of the Patient Item (660 ptr) or if not defined then a number_"Z"
    78         N CNT,IBX,IBY,BIFN,RIFN,IBC,IBRC K ARRB,ARRBL S IBC="AIFN"_$G(IBIFN),ARRB="^0" Q:'$G(IBIFN)
    79         D RCITEM^IBCSC5A(IBIFN,"IBRC",5) S CNT=0
    80         ;
    81         S IBX=0 F  S IBX=$O(^IBA(362.5,IBC,IBX)) Q:'IBX  S BIFN=0 F  S BIFN=$O(^IBA(362.5,IBC,IBX,BIFN)) Q:'BIFN  D
    82         . S IBY=$G(^IBA(362.5,BIFN,0)) Q:IBY=""  S CNT=CNT+1,RIFN=+$P(IBY,U,4),RIFN=$S(+RIFN:+RIFN,1:CNT_"Z")
    83         . S ARRB(+IBY,RIFN)=BIFN_U_$$CHG^IBCF4(BIFN,5,.IBRC),ARRB=$G(ARRB)+1
    84         S ARRB=IBIFN_U_+$G(ARRB)
    85         ;
    86         S CNT=+$G(PICNT),IBX=0 F  S IBX=$O(ARRB(IBX)) Q:'IBX  S IBY=0 F  S IBY=$O(ARRB(IBX,IBY)) Q:'IBY  S CNT=CNT+1,ARRBL(CNT)=IBX_U_IBY
    87         Q
    88         ;
    89 DISP(ABILL,ALBILL)      ;screen display of existing prosthetic devices for a bill, arrays should be passed by reference
    90         ; input:  ABILL (from SET) list of bill items
    91         ;         ALBILL (from SET) list of bill items, in count order
    92         N IBC,IBI,BIFN,BIFN0,DDT
    93         ;
    94         W !!,?5,"-----------------  Existing Prosthetic Items for Bill  -----------------",!
    95         S IBC=0 F  S IBC=$O(ALBILL(IBC)) Q:'IBC  D
    96         . S DDT=+ALBILL(IBC),IBI=$P(ALBILL(IBC),U,2),BIFN=+$G(ABILL(DDT,IBI)),BIFN0=$G(^IBA(362.5,BIFN,0))
    97         . W !,?1,$J(IBC,2),")",?6,$$DATE(DDT),?16,$E($P(BIFN0,U,5),1,60)
    98         W !
    99         Q
    100         ;
    101 PISET(DFN,DT1,DT2,ARRP,ARRPL)   ; get all prosthetic items (660) for a patient and date range, arrays should pass by ref.
    102         ; input:   DFN = patient, DT1-DT2 range of dates to search for items
    103         ; output:  ARRP(PD DEL DATE (660,10), PI IFN (660 ptr)) = PI IFN (660 ptr),  ARRP = count of items
    104         ;          ARRPL(count) = PD DEL DATE (660,10) ^ PI IFN (660 ptr)
    105         ;
    106         N PIFN,DDT,IBX,IBY,CNT K ARRP,ARRPL Q:'$G(DFN)  S DT1=$G(DT1)-.0001,DT2=$G(DT2) S:'DT2 DT2=9999999
    107         S PIFN=0 F  S PIFN=$O(^RMPR(660,"C",DFN,PIFN)) Q:'PIFN  D
    108         . S IBX=$G(^RMPR(660,PIFN,0)) Q:IBX=""  S DDT=+$P(IBX,U,12)\1 I (DDT<DT1)!(DDT>DT2) Q
    109         . S ARRP(DDT,PIFN)=PIFN,ARRP=+$G(ARRP)+1
    110         ;
    111         S (CNT,IBX)=0 F  S IBX=$O(ARRP(IBX)) Q:'IBX  S IBY=0 F  S IBY=$O(ARRP(IBX,IBY)) Q:'IBY  S CNT=CNT+1,ARRPL(CNT)=IBX_U_IBY
    112         Q
    113         ;
    114 PIDISP(APROS,ALPROS,ABILL)      ; display all prosthetic items (#660) for a patient and date range, arrays passed by reference, not changed
    115         ; input:  APROS (from PISET) patient's prosthetic items
    116         ;         ALPROS (from PISET) patient's prosthetics items, in count order
    117         ;         ABILL (from SET) list of bill's prosthetics items, only to check if item on bill
    118         N IBC,DDT,PIFN,PNAME,IBY,IBX,IBICD,IBP,IBEX
    119         ;
    120         W @IOF,?33,"PROSTHETICS SCREEN"
    121         W !,"================================================================================",!
    122         S IBC=0 F  S IBC=$O(ALPROS(IBC)) Q:'IBC  D
    123         . S DDT=+ALPROS(IBC),PIFN=$P(ALPROS(IBC),U,2)
    124         . S PNAME=$$PIN(PIFN),IBY=$G(^RMPR(660,PIFN,"AM")),IBX=$G(^RMPR(660,PIFN,0)) K IBEX
    125         . ;
    126         . F IBICD=1:1:4 Q:$D(IBEX)  I $D(^RMPR(660,PIFN,"BA"_IBICD)) F IBP=2:1:8 I $P(^RMPR(660,PIFN,"BA"_IBICD),"^",IBP) S IBEX="("_$P($T(EXEMPT+(IBP-1)),";",3)_")" Q  ; look for exemption info
    127         . ;
    128         . W !,$S($D(ABILL(+DDT,PIFN)):"*",1:"")
    129         . W ?1,$J(IBC,2),")",?6,$$DATE(DDT),?16,$E($P(PNAME,U,2),1,27),?45,"("_$P(PNAME,U,3),")",?53,$G(IBEX),?59,$E($$EXSET^IBEFUNC($P(IBX,U,14),660,12),1,4),?64,$$EXSET^IBEFUNC($P(IBY,U,3),660,62),?71,$J(+$P(IBX,U,16),8,2)
    130         Q
    131         ;
    132 PIN(P660,P6611) ; given Prosthetic record (#660) or PSAS HCPCS (#661.1) return Item Name
    133         ; returns PSAS HCPSC ptr (661.1) ^ SHORT DESCRIPTION (661.1, .02) ^ HCPCS (661.1, .01)
    134         N IBX,IBY S IBY=""
    135         I +$G(P660) S P6611=+$P($G(^RMPR(660,+P660,1)),U,4)
    136         I +$G(P6611) S IBX=$G(^RMPR(661.1,+P6611,0)) I IBX'="" S IBY=P6611_U_$P(IBX,U,2)_U_$P(IBX,U,1)
    137         Q IBY
    138         ;
    139 PINB(P3625)     ; given the bill prosthetics item (#362.5) return Item Name (.05)
    140         N IBY S IBY=$P($G(^IBA(362.5,+$G(P3625),0)),U,5)
    141         Q IBY
    142         ;
    143 BILL(IBIFN)     ; get bill data: returns DFN ^ Statement Covers From ^ Statement Covers To
    144         N IBX,IBY S IBIFN=+$G(IBIFN) S IBX=$G(^DGCR(399,IBIFN,0)),IBY=$P(IBX,U,2)
    145         S IBX=$G(^DGCR(399,IBIFN,"U")),$P(IBY,U,2)=+IBX,$P(IBY,U,3)=+$P(IBX,U,2)
    146         Q IBY
    147         ;
    148 ONBILLPI(IBIFN,PIFN)    ; return Bill Item ptr (#362.5) if the Prosthetics Item (#660) is already assigned to the bill
    149         ; input:  PIFN = Patient Prosthetics Item (ptr to 660)
    150         ; output: BIFN = Bill Prosthetics Item (ptr to 362.5) or null if not found
    151         N IBC,IBX,IBY,BIFN S IBY="" S IBC="AIFN"_$G(IBIFN)
    152         S IBX=0 F  S IBX=$O(^IBA(362.5,IBC,IBX)) Q:'IBX  S BIFN=0 F  S BIFN=$O(^IBA(362.5,IBC,IBX,BIFN)) Q:'BIFN  D
    153         . I +$G(PIFN),$P($G(^IBA(362.5,BIFN,0)),U,4)=PIFN S IBY=BIFN
    154         Q IBY
    155         ;
    156 DATE(X) ;
    157         Q $E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3)
    158         ;
    159 EXEMPT  ; exemption reasons
    160         ;;AO
    161         ;;IR
    162         ;;SC
    163         ;;SWA
    164         ;;MST
    165         ;;HNC
    166         ;;CV
    167         ;
     1IBCSC5B ;ALB/ARH - ADD/ENTER PROSTHETIC ITEMS ;12/28/93
     2 ;;2.0;INTEGRATED BILLING;**4,52,260,339**;21-MAR-94;Build 2
     3 ;;Per VHA Directive 2004-038, this routine should not be modified.
     4 ;
     5 ;
     6EN ;add/edit prosthetic items for a bill, IBIFN required
     7 S IBX=$$BILL(IBIFN) Q:'IBIFN  S DFN=+IBX,IBDT1=$P(IBX,U,2),IBDT2=$P(IBX,U,3)
     8 D SET(IBIFN,.IBPDA),PIDISP(DFN,IBDT1,IBDT2,.IBPDE,.IBPDA),DISP(.IBPDA)
     9E1 S IBPIFN=0,IBDT=$$ASKDT(IBDT1,IBDT2) G:'IBDT EXIT
     10 S IBPD=$O(IBPDA(IBDT,0)) S:'IBPD IBPD=$O(IBPDE(IBDT,0)) S IBPD=$$ASKPD(IBPD) G:'IBPD E1
     11 S IBPIFN=$G(IBPDA(IBDT,+IBPD)) I 'IBPIFN S IBPIFN=$$ADD(IBDT,IBIFN,+IBPD,+$G(IBPDE(IBDT,+IBPD))) I 'IBPIFN W " ??" G E1
     12 I '$D(IBPDE(IBDT,+IBPD)) W !,"This prosthetic item does not exist in this patients prosthetics record.",!
     13 D EDIT(+IBPIFN) D SET(IBIFN,.IBPDA) W ! G E1
     14 ;
     15EXIT K IBPIFN,IBX,IBDT1,IBDT2,IBPDA,IBPDE,IBPD,IBDT
     16 Q
     17 ;
     18ASKDT(IBDT1,IBDT2,IBDT) ;
     19 I +$G(IBIFN) S DIR("?")="Enter the date the item was delivered to the patient",DIR("??")="^D HELP^IBCSC5B("_IBIFN_")"
     20 S DIR("A")="Select ITEM DELIVERY DATE",DIR(0)="DO^"_IBDT1_":"_IBDT2_":EX" D ^DIR K DIR,DTOUT,DIRUT
     21 Q $S(Y?7N:Y,1:0)
     22 ;
     23ASKPD(PD) ;
     24 N X,Y
     25 S DIR("A")="Select PROSTHETIC ITEM",DIR(0)="660,4O" S:+$G(PD) DIR("B")=+$G(^RMPR(661,+$G(PD),0)) D ^DIR S:$D(DIRUT)!(Y'>0) Y="" K DIR,DIRUT
     26 Q Y
     27 ;
     28ADD(IBDT,IFN,IBPD,PIFN) ;
     29 N IBX,IBY,IBDX,IBHCPCS S IBX=0,DIC="^IBA(362.5,",DIC(0)="AQL",X=IBDT K DA,DO D FILE^DICN K DA,DO,X
     30 I Y>0 S DIE=DIC,(IBX,DA)=+Y,DR=".02////"_IFN_";.03////"_IBPD_";.04////"_PIFN D ^DIE K DIE,DIC,DA,DR W "... ADDED"
     31 ;add dx if known
     32 F IBY=1:1:4 S IBDX=+$G(^RMPR(660,PIFN,"BA"_IBY)) I IBDX,'$O(^IBA(362.3,"AIFN"_IFN,IBDX)) D
     33 . S DIC="^IBA(362.3,",DIC(0)="L",DLAYGO=362.3,X=IBDX,DIC("DR")=".02////"_IFN K DD,DO D FILE^DICN S IBDX(+Y)=""
     34 ;add hcpcs if known
     35 ;S IBHCPCS=$P($G(^RMPR(660,PIEN,0)),"^",22) I IBHCPCS
     36 ;
     37 Q IBX
     38 ;
     39EDIT(PIFN) ;
     40 S DIDEL=362.5,DIE="^IBA(362.5,",DR=".01;.03",DA=PIFN D ^DIE K DIE,DR,DA,DIC,DIDEL
     41 Q
     42 ;
     43SET(IFN,PDARR) ;setup array of all prosthetic devices for bill, array name should be passed by reference
     44 ;returns: PDARR(PD DELIV DATE, PD ITEM (661 ptr))=PD IFN (362.5 ptr),  PDARR=BILL IFN ^ PD count
     45 N CNT,IBX,IBY,PIFN,IBC,IBRC K PDARR S IBC="AIFN"_$G(IFN)
     46 D RCITEM^IBCSC5A(IBIFN,"IBRC",5)
     47 S (CNT,IBX)=0 F  S IBX=$O(^IBA(362.5,IBC,IBX)) Q:'IBX  S PIFN=0 F  S PIFN=$O(^IBA(362.5,IBC,IBX,PIFN)) Q:'PIFN  D
     48 . S IBY=$G(^IBA(362.5,PIFN,0)) Q:IBY=""  S CNT=CNT+1,PDARR(+IBY,$P(IBY,U,3))=PIFN_U_$$CHG^IBCF4(PIFN,5,.IBRC)
     49 S PDARR=$G(IFN)_"^"_CNT
     50 Q
     51 ;
     52DISP(PDARR) ;screen display of existing prosthetic devices for a bill,
     53 ;input should be array returned by SET^IBCSC5B: PDARR(PD DT, PD ITEM)=PD IFN (362.5), pass by reference
     54 N IBX,IBY,IBZ
     55 W !!,?5,"-----------------  Existing Prosthetic Items for Bill  -----------------",!
     56 S IBX=0 F  S IBX=$O(PDARR(IBX)) Q:IBX=""  S IBY=0 F  S IBY=$O(PDARR(IBX,IBY)) Q:'IBY  D
     57 . S IBZ=$$PIN(IBY) W !,$$DATE(IBX),?12,$P(IBZ,U,1),?20,$P(IBZ,U,2)
     58 W !
     59 Q
     60 ;
     61HELP(IFN) ;called for help from prosthetics enter to display existing devices, displays devices from 660 and 399
     62 I +$G(IFN) N IBX,IBPDA S IBX=$$BILL(IFN) I +IBX D SET(IFN,.IBPDA),PIDISP($P(IBX,U,1),$P(IBX,U,2),$P(IBX,U,3),"",.IBPDA),DISP(.IBPDA)
     63 Q
     64 ;
     65PIDISP(DFN,DT1,DT2,ARRAY,PDARR) ; display all prosthetic items (660) for a patient and date range
     66 ;PDARR (as defined by SET^IBCSC5B) passed by ref. only to check if pros. item is on the bill, not necessary, not changed
     67 ;returns ARRAY(PD DEL DATE (660,10), PD ITEM (660,4=661 ptr))=RECORD (660 ptr), should pass by ref. if desired
     68 N PIFN,IBX,IBY,PNAME,DDT,PI,IBICD,IBEX,IBP
     69 K ARRAY S DT1=$G(DT1)-.0001,DT2=$G(DT2) S:'DT2 DT2=9999999 Q:'$G(DFN)
     70 S PIFN=0 F  S PIFN=$O(^RMPR(660,"C",DFN,PIFN)) Q:'PIFN  D
     71 . S IBX=$G(^RMPR(660,PIFN,0)),DDT=+$P(IBX,U,12)\1 I (DDT<DT1)!(DDT>DT2) Q
     72 . S ARRAY(DDT,+$P(IBX,U,6))=PIFN
     73 ;
     74 W @IOF,?33,"PROSTHETICS SCREEN",!,"================================================================================",!
     75 S DDT=0 F  S DDT=$O(ARRAY(DDT)) Q:'DDT  S PI=0 F  S PI=$O(ARRAY(DDT,PI)) Q:'PI  D
     76 . S PIFN=ARRAY(DDT,PI),PNAME=$$PIN(PI),IBY=$G(^RMPR(660,PIFN,"AM")),IBX=$G(^RMPR(660,PIFN,0)) K IBEX
     77 . ; look for exemption info
     78 . F IBICD=1:1:4 Q:$D(IBEX)  I $D(^RMPR(660,PIFN,"BA"_IBICD)) F IBP=2:1:8 I $P(^RMPR(660,PIFN,"BA"_IBICD),"^",IBP) S IBEX="("_$P($T(EXEMPT+(IBP-1)),";",3)_")" Q
     79 . W !,$S($D(PDARR(+DDT,PI)):"*",1:"")
     80 . W ?2,$$DATE(DDT),?12,$P(PNAME,U,1),$G(IBEX),?20,$E($P(PNAME,U,2),1,30),?55,$E($$EXSET^IBEFUNC($P(IBX,U,14),660,12),1,4),?62,$$EXSET^IBEFUNC($P(IBY,U,3),660,62),?70,$J(+$P(IBX,U,16),9,2)
     81 Q
     82 ;
     83PIN(PITEM) ;given the pros item IFN (661 ptr) returns name for printing (661,.01^441,.05)
     84 N IBX,IBY S IBY="" I +$G(PITEM) S IBX=+$G(^RMPR(661,+PITEM,0)) I +IBX S IBY=IBX_U_$$DESCR^PRCPUX1(0,+IBX)
     85 Q IBY
     86 ;
     87BILL(IBIFN) ; display all existing prescription refills (52) for a patient and date range
     88 ; (call is a short cut to calling rxdisp if have bill number)
     89 N IBX,IBY S IBX=$G(^DGCR(399,+$G(IBIFN),0)),IBY=$P(IBX,U,2)
     90 S IBX=$G(^DGCR(399,+IBIFN,"U")),$P(IBY,U,2)=+IBX,$P(IBY,U,3)=+$P(IBX,U,2)
     91 Q IBY
     92 ;
     93DATE(X) ;
     94 Q $E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3)
     95 ;
     96EXEMPT ; exemption reasons
     97 ;;AO
     98 ;;IR
     99 ;;SC
     100 ;;SWA
     101 ;;MST
     102 ;;HNC
     103 ;;CV
     104 ;

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSC61.m

    r613 r623  
    1 IBCSC61 ;ALB/MJB - MCCR SCREEN UTILITY ;20 JUN 88 10:58
    2         ;;2.0;INTEGRATED BILLING;**52,80,106,51,210,230,309,389**;21-MAR-94;Build 6
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5         ;MAP TO IBCSC61
    6         ;
    7 REV     I I>1 W !?4,"Rev. Code",?16,": "
    8         N IBNAME S IBNAME=$E($$NAME($P(IBREVC(I),U,10),$P(IBREVC(I),U,11)),1,17)
    9         S DGRCD=$S($D(^DGCR(399.2,+IBREVC(I),0)):^(0),1:""),DGRCD=$P(DGRCD,"^",1)_"-"_$S(IBNAME'="":IBNAME,1:$E($P(DGRCD,"^",2),1,17))
    10         I $P(IBREVC(I),"^",6) S DGRCD=DGRCD_$J("",21-$L(DGRCD))_"  "_$P($$CPT^ICPTCOD(+$P(IBREVC(I),"^",6)),U,2)
    11         I '$P(IBREVC(I),U,6),$P(IBREVC,U,11) S DGRCD=DGRCD_$J("",21-$L(DGRCD))_" *"_$P($$CPT^ICPTCOD(+$P(IBREVC(I),"^",11)),U,2)
    12         S DGRCD=DGRCD_$J("",28-$L(DGRCD))
    13         I (+$P(IBREVC(I),"^",3)>1)!($P(IBREVC(I),U,10)'=4) S DGRCD=DGRCD_$J($P(IBREVC(I),"^",3),3)
    14         S X=$S($P(IBREVC(I),"^",4)]"":$P(IBREVC(I),"^",4),1:IBU) I X'=IBU S X2="2$" D COMMA^%DTC
    15         W DGRCD,$J("",32-$L(DGRCD)),X
    16         I $P(IBREVC(I),"^",5)]"",$D(^DGCR(399.1,$P(IBREVC(I),"^",5),0)) W ?60," ",$E($P(^DGCR(399.1,$P(IBREVC(I),"^",5),0),"^"),1,16)
    17         I IBREVC<10,$P(IBREVC(I),U,9)'="",$$FT^IBCEF(IBIFN)=3 S X=$P(IBREVC(I),U,9),X2="2$" D COMMA^%DTC W !,?50,X S IBREVC=IBREVC+1 W ?64,"(Non-Covered)"
    18         Q
    19         ;
    20 CHARGE  S (IBCH,IBUCH)=0 F I=1:1 Q:'$D(IBREVC(I))  S IBCH=IBCH+($P(IBREVC(I),U,4)),IBUCH=IBUCH+$P(IBREVC(I),U,9)
    21         I IB("U1")]"" S X=$P(IB("U1"),"^",1),X1=$P(IB("U1"),"^",2),IBCH=X
    22         Q
    23         ;
    24 OFFSET  S IBOFFC="" W !?4,"OFFSET",?16,": " S X=$S(IB("U1")']"":0,1:+$P(IB("U1"),U,2)),X2="2$" S:X IBOFFC=$P(IB("U1"),U,3) D COMMA^%DTC
    25         W X,"  [",$S($L(IBOFFC):IBOFFC,'$P(X,"$",2):"NO OFFSET RECORDED",1:"OFFSET DESCRIPTION UNSPECIFIED"),"]"
    26         D CHARGE W !?4,"BILL TOTAL",?16,": " S X=$S('$D(IBCH):0,1:+IBCH),X2="2$" D COMMA^%DTC W X
    27         K IBOFFC
    28         Q
    29         ;
    30 NAME(TYPE,ITEM) ; if rx or pros or DRG or unassociated return name of the item
    31         N IBNAME S IBNAME=""
    32         I $G(TYPE)=3,+$G(ITEM) D
    33         .D ZERO^IBRXUTL($P($G(^IBA(362.4,+ITEM,0)),U,4))
    34         .S IBNAME=$G(^TMP($J,"IBDRUG",+$P($G(^IBA(362.4,+ITEM,0)),U,4),.01))
    35         .K ^TMP($J,"IBDRUG")
    36         .Q
    37         I $G(TYPE)=5,+$G(ITEM) S IBNAME=$P($G(^IBA(362.5,+ITEM,0)),U,5)
    38         I $G(TYPE)=6,+$G(ITEM) S IBNAME=$P($$DRG^IBACSV(+ITEM),U,1)
    39         I $G(TYPE)=9,+$G(ITEM) S IBNAME=$P($G(^IBA(363.21,+ITEM,0)),U,1)
    40         Q IBNAME
    41         ;IBCSC61
     1IBCSC61 ;ALB/MJB - MCCR SCREEN UTILITY ;20 JUN 88 10:58
     2 ;;2.0;INTEGRATED BILLING;**52,80,106,51,210,230,309**;21-MAR-94
     3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
     4 ;
     5 ;MAP TO IBCSC61
     6 ;
     7REV I I>1 W !?4,"Rev. Code",?16,": "
     8 N IBNAME S IBNAME=$E($$NAME($P(IBREVC(I),U,10),$P(IBREVC(I),U,11)),1,17)
     9 S DGRCD=$S($D(^DGCR(399.2,+IBREVC(I),0)):^(0),1:""),DGRCD=$P(DGRCD,"^",1)_"-"_$S(IBNAME'="":IBNAME,1:$E($P(DGRCD,"^",2),1,17))
     10 I $P(IBREVC(I),"^",6) S DGRCD=DGRCD_$J("",21-$L(DGRCD))_"  "_$P($$CPT^ICPTCOD(+$P(IBREVC(I),"^",6)),U,2)
     11 I '$P(IBREVC(I),U,6),$P(IBREVC,U,11) S DGRCD=DGRCD_$J("",21-$L(DGRCD))_" *"_$P($$CPT^ICPTCOD(+$P(IBREVC(I),"^",11)),U,2)
     12 S DGRCD=DGRCD_$J("",28-$L(DGRCD))
     13 I (+$P(IBREVC(I),"^",3)>1)!($P(IBREVC(I),U,10)'=4) S DGRCD=DGRCD_$J($P(IBREVC(I),"^",3),3)
     14 S X=$S($P(IBREVC(I),"^",4)]"":$P(IBREVC(I),"^",4),1:IBU) I X'=IBU S X2="2$" D COMMA^%DTC
     15 W DGRCD,$J("",32-$L(DGRCD)),X
     16 I $P(IBREVC(I),"^",5)]"",$D(^DGCR(399.1,$P(IBREVC(I),"^",5),0)) W ?60," ",$E($P(^DGCR(399.1,$P(IBREVC(I),"^",5),0),"^"),1,16)
     17 I IBREVC<10,$P(IBREVC(I),U,9)'="",$$FT^IBCEF(IBIFN)=3 S X=$P(IBREVC(I),U,9),X2="2$" D COMMA^%DTC W !,?50,X S IBREVC=IBREVC+1 W ?64,"(Non-Covered)"
     18 Q
     19 ;
     20CHARGE S (IBCH,IBUCH)=0 F I=1:1 Q:'$D(IBREVC(I))  S IBCH=IBCH+($P(IBREVC(I),U,4)),IBUCH=IBUCH+$P(IBREVC(I),U,9)
     21 I IB("U1")]"" S X=$P(IB("U1"),"^",1),X1=$P(IB("U1"),"^",2),IBCH=X
     22 Q
     23 ;
     24OFFSET S IBOFFC="" W !?4,"OFFSET",?16,": " S X=$S(IB("U1")']"":0,1:+$P(IB("U1"),U,2)),X2="2$" S:X IBOFFC=$P(IB("U1"),U,3) D COMMA^%DTC
     25 W X,"  [",$S($L(IBOFFC):IBOFFC,'$P(X,"$",2):"NO OFFSET RECORDED",1:"OFFSET DESCRIPTION UNSPECIFIED"),"]"
     26 D CHARGE W !?4,"BILL TOTAL",?16,": " S X=$S('$D(IBCH):0,1:+IBCH),X2="2$" D COMMA^%DTC W X
     27 K IBOFFC
     28 Q
     29 ;
     30NAME(TYPE,ITEM) ; if rx or pros or DRG or unassociated return name of the item
     31 N IBNAME S IBNAME=""
     32 I $G(TYPE)=3,+$G(ITEM) D
     33 .D ZERO^IBRXUTL($P($G(^IBA(362.4,+ITEM,0)),U,4))
     34 .S IBNAME=$G(^TMP($J,"IBDRUG",+$P($G(^IBA(362.4,+ITEM,0)),U,4),.01))
     35 .K ^TMP($J,"IBDRUG")
     36 .Q
     37 I $G(TYPE)=5,+$G(ITEM) S IBNAME=$P($$PIN^IBCSC5B(+$P($G(^IBA(362.5,+ITEM,0)),U,3)),U,2)
     38 I $G(TYPE)=6,+$G(ITEM) S IBNAME=$P($$DRG^IBACSV(+ITEM),U,1)
     39 I $G(TYPE)=9,+$G(ITEM) S IBNAME=$P($G(^IBA(363.21,+ITEM,0)),U,1)
     40 Q IBNAME
     41 ;IBCSC61

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSC8H.m

    r613 r623  
    1 IBCSC8H ;ALB/ARH - MCCR SCREEN 8 (BILL SPECIFIC INFO) CMS-1500 ;4/21/92
    2         ;;2.0;INTEGRATED BILLING;**51,137,207,210,232,155,320,343,349,371**;21-MAR-94;Build 57
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ; CMS-1500 screen 8
    5         ;
    6         ; MAP TO DGCRSC8H
    7         ;
    8 EN      N I,IB,Y,Z
    9         D ^IBCSCU S IBSR=8,IBSR1="H",IBV1="00000000" S:IBV IBV1="11111111" F I="U","U1","UF2","UF3","U2","M","TX",0,"U3" S IB(I)=$G(^DGCR(399,IBIFN,I))
    10         N IBZ,IBPRV,IBDATE,IBREQ,IBMRASEC,IBZ1
    11         ;
    12         S IBDATE=$$BDATE^IBACSV(IBIFN) ; Date of service for the bill
    13         S IBPRV=""
    14         D GETPRV^IBCEU(IBIFN,"ALL",.IBPRV)
    15         K IB("PRV")
    16         S IBZ=0 F  S IBZ=$O(IBPRV(IBZ)) Q:'IBZ  I $O(IBPRV(IBZ,0))!$D(IBPRV(IBZ,"NOTOPT")) M IB("PRV",IBZ)=IBPRV(IBZ)
    17         ;
    18         D H^IBCSCU
    19         S Z=1,IBW=1 X IBWW W " Unable To Work From: " S Y=$P(IB("U"),U,16) X ^DD("DD") W $S(Y'="":Y,1:IBUN)
    20         W !?4,"Unable To Work To  : " S Y=$P(IB("U"),U,17) X ^DD("DD") W $S(Y'="":Y,1:IBUN)
    21         S Z=2,IBW=1 X IBWW W " Admitting Dx       : " S IBZ=$$ICD9^IBACSV(+IB("U2"),IBDATE) W $S(IBZ'="":$P(IBZ,U)_" - "_$P(IBZ,U,3),1:IBUN)
    22         S IBZ="",IBZ=$S($P(IB("UF3"),U,4)]"":"Pri: "_$P(IB("UF3"),U,4),1:"")_$S($P(IB("UF3"),U,5)'="":"  Sec: "_$P(IB("UF3"),U,5),1:"")_$S($P(IB("UF3"),U,6)'="":" Ter: "_$P(IB("UF3"),U,6),1:"")
    23         S:IBZ="" IBZ=IBUN
    24         W !,?4,"ICN/DCN(s)         : ",IBZ
    25         S IBZ=$$CKPROV^IBCEU(IBIFN,3)
    26         S IBZ="",IBZ=$S($P(IB("U"),U,13)]"":"Pri: "_$P(IB("U"),U,13),1:"")_$S($P(IB("U2"),U,8)'="":"  Sec: "_$P(IB("U2"),U,8),1:"")_$S($P(IB("U2"),U,9)'="":"  Ter: "_$P(IB("U2"),U,9),1:"")
    27         S:IBZ="" IBZ=IBUN
    28         W !?4,"Tx Auth. Code(s)   : ",IBZ
    29         S Z=3,IBW=1 X IBWW
    30         W " Providers          : ",$S('$O(IB("PRV",0)):IBU,1:"")
    31         I $D(IB("PRV")) D  ; at least 1 provider found
    32         . N IBQ,A,A1,IBARR,IBTAX,IBNOTAX,IBSPEC,IBNOSPEC
    33         . S IBZ=0
    34         . D DEFSEC^IBCEF74(IBIFN,.IBARR)
    35         . ; PRXM/KJH - Add Taxonomy code to display for patch 343. Moved secondary IDs slightly (below).
    36         . S IBTAX=$$PROVTAX^IBCEF73A(IBIFN,.IBNOTAX)
    37         . S IBSPEC=$$SPECTAX^IBCEF73A(IBIFN,.IBNOSPEC)
    38         . F  S IBZ=$O(IB("PRV",IBZ)) Q:'IBZ  D
    39         .. S IBQ=""
    40         .. W !,?5,"- "
    41         .. S A=$$EXPAND^IBTRE(399.0222,.01,IBZ)
    42         .. I $P($G(IB("PRV",IBZ,1)),U,4)'="" S A1=" ("_$E($P(IB("PRV",IBZ,1),U,4),1,3)_")",A=$E(A,1,16-$L(A1))_A1
    43         .. W $E(A_$J("",16),1,16),": "
    44         .. I '$P($G(IB("PRV",IBZ,1)),U,3),$P($G(IB("PRV",IBZ,1)),U)="" W IBU Q
    45         .. I $P($G(IB("PRV",IBZ,1)),U)'="" W:'$G(IB("PRV",IBZ)) $E($P(IB("PRV",IBZ,1),U)_$J("",16),1,16) W:$G(IB("PRV",IBZ)) "(OLD BOX 31 DATA) "_$P(IB("PRV",IBZ,1),U)
    46         .. I $P($G(IB("PRV",IBZ,1)),U)="",$P($G(IB("PRV",IBZ)),U)'="" W $E($P(IB("PRV",IBZ),U)_$J("",16),1,16)
    47         .. W "    Taxonomy: ",$S($P(IBTAX,U,IBZ)'="":$P(IBTAX,U,IBZ),1:IBU),$S($P(IBSPEC,U,IBZ)'="":" ("_$P(IBSPEC,U,IBZ)_")",1:"")
    48         .. F A=1:1:3 I $G(IBARR(IBZ,A))'="" S IBQ=IBQ_"["_$E("PST",A)_"]"_IBARR(IBZ,A)_" "
    49         .. I $L(IBQ) W !,?30,$E(IBQ,1,49)
    50         ;
    51         K IB("PRV")
    52         ;
    53         S Z=4,IBW=1 X IBWW
    54         W " Other Facility (VA/non): " S IBZ=$$EXPAND^IBTRE(399,232,+$P(IB("U2"),U,10))
    55         W $S(IBZ'="":$E(IBZ,1,23),$$PSRV^IBCEU(IBIFN):IBU,1:IBUN)
    56         I IBZ'="" D
    57         . ; PRXM/KJH - Add Taxonomy code to display for patch 343.
    58         . W ?53,"Taxonomy: "
    59         . S IBZ=$$GET1^DIQ(8932.1,+$P(IB("U3"),U,3),"X12 CODE") W $S(IBZ'="":IBZ,1:IBU)
    60         . S IBZ=$$GET1^DIQ(8932.1,+$P(IB("U3"),U,3),"SPECIALTY CODE") W $S(IBZ'="":" ("_IBZ_")",1:"")
    61         . Q
    62         ;
    63         ; clia# display - IB patch 320
    64         S (IBZ,IBZ1)=$P(IB("U2"),U,13)     ; retrieve CLIA# from database
    65         ;
    66         I IBZ="" D
    67         . NEW CLIAREQ,DEFCLIA,DIE,DA,DR
    68         . S CLIAREQ=$$CLIAREQ^IBCEP8A(IBIFN)
    69         . I 'CLIAREQ S IBZ1=IBUN Q          ; clia# not needed
    70         . S DEFCLIA=$$CLIA^IBCEP8A(IBIFN)   ; default clia# for claim
    71         . I DEFCLIA="" S IBZ1=IBU Q         ; no default found
    72         . I $G(IBMDOTCN) K IBMDOTCN S IBZ1=IBU Q     ; user @-deleted clia#
    73         . S IBZ1=DEFCLIA                    ; display and stuff default clia#
    74         . S DIE=399,DA=IBIFN,DR="235///"_DEFCLIA D ^DIE    ; stuff in default
    75         . Q
    76         ;
    77         W !,?4,"Lab CLIA #         : ",IBZ1
    78         ;
    79         ; Mammo# display IB patch 320
    80         S (IBZ,IBZ1)=$P(IB("U3"),U,1)    ; retrieve mammo# from database
    81         ;
    82         ; If mammo# is there, but should not be, then blank it out
    83         I IBZ'="",'$$XRAY^IBCEP8A(IBIFN) D
    84         . NEW DIE,DA,DR
    85         . S IBZ1=IBUN        ; mammo# not needed
    86         . S DIE=399,DA=IBIFN,DR="242////@" D ^DIE
    87         . Q
    88         ;
    89         I IBZ="" S IBZ1=IBUN
    90         W !?4,"Mammography Cert # : ",IBZ1
    91         ;
    92         S Z=5,IBW=1 X IBWW
    93         W " Chiropractic Data  : " S Y=$P(IB("U3"),U,5) X ^DD("DD") W $S(Y'="":"INITIAL TREATMENT ON "_Y,1:IBUN)
    94         ;
    95         S Z=6,IBW=1 X IBWW
    96         W " Form Locator 19    : " S IBZ=$P($G(^DGCR(399,IBIFN,"UF31")),U,3) W $S(IBZ'="":IBZ,1:IBUN)
    97         I $P(IB("U2"),U,14)'="" W !,?4,"Homebound          : ",$$EXPAND^IBTRE(399,236,$P(IB("U2"),U,14))
    98         I $P(IB("U2"),U,15)'="" W !,?4,"Date Last Seen     : ",$$EXPAND^IBTRE(399,237,$P(IB("U2"),U,15))
    99         I $P(IB("U2"),U,16)'="" W !,?4,"Spec Prog Indicator: " S IBZ=$$EXPAND^IBTRE(399,238,$P(IB("U2"),U,16)) W $S(IBZ'="":IBZ,$$WNRBILL^IBEFUNC(IBIFN):"31",1:"")
    100         ;
    101         S Z=7,IBW=1 X IBWW
    102         S IBREQ=+$$REQMRA^IBEFUNC(IBIFN) S:IBREQ IBREQ=1
    103         S IBMRASEC=$$MRASEC^IBCEF4(IBIFN)
    104         W " ",$S('IBREQ:"Force To Print?    : ",1:"Force MRA Sec Prt? : ")
    105         S IBZ=$$EXTERNAL^DILFD(399,27+IBREQ,,+$P(IB("TX"),U,8+IBREQ))
    106         I IBMRASEC,'$P(IB("TX"),U,8),$P(IB("TX"),U,9) S IBZ="FORCED TO PRINT BY MRA PRIMARY",$P(IB("TX"),U,8)=0
    107         W $S(IBZ'=""&($P(IB("TX"),U,8+IBREQ)'=""):IBZ,'$$TXMT^IBCEF4(IBIFN):"[NOT APPLICABLE - NOT TRANSMITTABLE]",IBREQ:"NO FORCED PRINT",1:IBZ)
    108         ;
    109         S Z=8,IBW=1 X IBWW
    110         W " Provider ID Maint  : (Edit Provider ID information)",!
    111         G ^IBCSCP
    112 Q       Q
    113         ;
    114 WRT1(IBCRED)    ; Write credentials mismatch
    115         W !,*7,"  **Warning** Credentials differ from those found in NEW PERSON or IB NON VA",!,$J("",14),"BILLING PROVIDER file (",$S(IBCRED="":"none",1:IBCRED),")"
    116         W !,$J("",14),"Changes will print local, but only credentials on file transmit"
    117         Q
    118         ;
    119 NSAME(DA)       ; Returns 1 if div on bill is not the default billing facility
    120         Q ($P($G(^IBE(350.9,1,0)),U,2)'=$P($G(^DG(40.8,+$P(^DGCR(399,DA,0),U,22),0)),U,7))
    121         ;
    122         ;IBCSC8H
     1IBCSC8H ;ALB/ARH - MCCR SCREEN 8 (BILL SPECIFIC INFO) CMS-1500 ;4/21/92
     2 ;;2.0;INTEGRATED BILLING;**51,137,207,210,232,155,320,343,349**;21-MAR-94;Build 46
     3 ;;Per VHA Directive 2004-038, this routine should not be modified.
     4 ; CMS-1500 screen 8
     5 ;
     6 ; MAP TO DGCRSC8H
     7 ;
     8EN N I,IB,Y,Z
     9 D ^IBCSCU S IBSR=8,IBSR1="H",IBV1="0000000" S:IBV IBV1="1111111" F I="U","U1","UF2","UF3","U2","M","TX",0,"U3" S IB(I)=$G(^DGCR(399,IBIFN,I))
     10 N IBZ,IBPRV,IBDATE,IBREQ,IBMRASEC,IBZ1
     11 ;
     12 S IBDATE=$$BDATE^IBACSV(IBIFN) ; Date of service for the bill
     13 S IBPRV=""
     14 D GETPRV^IBCEU(IBIFN,"ALL",.IBPRV)
     15 K IB("PRV")
     16 S IBZ=0 F  S IBZ=$O(IBPRV(IBZ)) Q:'IBZ  I $O(IBPRV(IBZ,0))!$D(IBPRV(IBZ,"NOTOPT")) M IB("PRV",IBZ)=IBPRV(IBZ)
     17 ;
     18 D H^IBCSCU
     19 S Z=1,IBW=1 X IBWW W " Unable To Work From: " S Y=$P(IB("U"),U,16) X ^DD("DD") W $S(Y'="":Y,1:IBUN)
     20 W !?4,"Unable To Work To  : " S Y=$P(IB("U"),U,17) X ^DD("DD") W $S(Y'="":Y,1:IBUN)
     21 S Z=2,IBW=1 X IBWW W " Admitting Dx       : " S IBZ=$$ICD9^IBACSV(+IB("U2"),IBDATE) W $S(IBZ'="":$P(IBZ,U)_" - "_$P(IBZ,U,3),1:IBUN)
     22 S IBZ="",IBZ=$S($P(IB("UF3"),U,4)]"":"Pri: "_$P(IB("UF3"),U,4),1:"")_$S($P(IB("UF3"),U,5)'="":"  Sec: "_$P(IB("UF3"),U,5),1:"")_$S($P(IB("UF3"),U,6)'="":" Ter: "_$P(IB("UF3"),U,6),1:"")
     23 S:IBZ="" IBZ=IBUN
     24 W !,?4,"ICN/DCN(s)         : ",IBZ
     25 S IBZ=$$CKPROV^IBCEU(IBIFN,3)
     26 S IBZ="",IBZ=$S($P(IB("U"),U,13)]"":"Pri: "_$P(IB("U"),U,13),1:"")_$S($P(IB("U2"),U,8)'="":"  Sec: "_$P(IB("U2"),U,8),1:"")_$S($P(IB("U2"),U,9)'="":"  Ter: "_$P(IB("U2"),U,9),1:"")
     27 S:IBZ="" IBZ=IBUN
     28 W !?4,"Tx Auth. Code(s)   : ",IBZ
     29 S Z=3,IBW=1 X IBWW
     30 W " Providers          : ",$S('$O(IB("PRV",0)):IBU,1:"")
     31 I $D(IB("PRV")) D  ; at least 1 provider found
     32 . N IBQ,A,A1,IBARR,IBTAX,IBNOTAX,IBSPEC,IBNOSPEC
     33 . S IBZ=0
     34 . D DEFSEC^IBCEF74(IBIFN,.IBARR)
     35 . ; PRXM/KJH - Add Taxonomy code to display for patch 343. Moved secondary IDs slightly (below).
     36 . S IBTAX=$$PROVTAX^IBCEF73A(IBIFN,.IBNOTAX)
     37 . S IBSPEC=$$SPECTAX^IBCEF73A(IBIFN,.IBNOSPEC)
     38 . F  S IBZ=$O(IB("PRV",IBZ)) Q:'IBZ  D
     39 .. S IBQ=""
     40 .. W !,?5,"- "
     41 .. S A=$$EXPAND^IBTRE(399.0222,.01,IBZ)
     42 .. I $P($G(IB("PRV",IBZ,1)),U,4)'="" S A1=" ("_$E($P(IB("PRV",IBZ,1),U,4),1,3)_")",A=$E(A,1,16-$L(A1))_A1
     43 .. W $E(A_$J("",16),1,16),": "
     44 .. I '$P($G(IB("PRV",IBZ,1)),U,3),$P($G(IB("PRV",IBZ,1)),U)="" W IBU Q
     45 .. I $P($G(IB("PRV",IBZ,1)),U)'="" W:'$G(IB("PRV",IBZ)) $E($P(IB("PRV",IBZ,1),U)_$J("",16),1,16) W:$G(IB("PRV",IBZ)) "(OLD BOX 31 DATA) "_$P(IB("PRV",IBZ,1),U)
     46 .. I $P($G(IB("PRV",IBZ,1)),U)="",$P($G(IB("PRV",IBZ)),U)'="" W $E($P(IB("PRV",IBZ),U)_$J("",16),1,16)
     47 .. W "    Taxonomy: ",$S($P(IBTAX,U,IBZ)'="":$P(IBTAX,U,IBZ),1:IBU),$S($P(IBSPEC,U,IBZ)'="":" ("_$P(IBSPEC,U,IBZ)_")",1:"")
     48 .. F A=1:1:3 I $G(IBARR(IBZ,A))'="" S IBQ=IBQ_"["_$E("PST",A)_"]"_IBARR(IBZ,A)_" "
     49 .. I $L(IBQ) W !,?30,$E(IBQ,1,49)
     50 ;
     51 K IB("PRV")
     52 ;
     53 S Z=4,IBW=1 X IBWW
     54 W " Other Facility (VA/non): " S IBZ=$$EXPAND^IBTRE(399,232,+$P(IB("U2"),U,10))
     55 W $S(IBZ'="":$E(IBZ,1,23),$$PSRV^IBCEU(IBIFN):IBU,1:IBUN)
     56 I IBZ'="" D
     57 . ; PRXM/KJH - Add Taxonomy code to display for patch 343.
     58 . W ?53,"Taxonomy: "
     59 . S IBZ=$$GET1^DIQ(8932.1,+$P(IB("U3"),U,3),"X12 CODE") W $S(IBZ'="":IBZ,1:IBU)
     60 . S IBZ=$$GET1^DIQ(8932.1,+$P(IB("U3"),U,3),"SPECIALTY CODE") W $S(IBZ'="":" ("_IBZ_")",1:"")
     61 . Q
     62 ;
     63 ; clia# display - IB patch 320
     64 S (IBZ,IBZ1)=$P(IB("U2"),U,13)     ; retrieve CLIA# from database
     65 ;
     66 I IBZ="" D
     67 . NEW CLIAREQ,DEFCLIA,DIE,DA,DR
     68 . S CLIAREQ=$$CLIAREQ^IBCEP8A(IBIFN)
     69 . I 'CLIAREQ S IBZ1=IBUN Q          ; clia# not needed
     70 . S DEFCLIA=$$CLIA^IBCEP8A(IBIFN)   ; default clia# for claim
     71 . I DEFCLIA="" S IBZ1=IBU Q         ; no default found
     72 . I $G(IBMDOTCN) K IBMDOTCN S IBZ1=IBU Q     ; user @-deleted clia#
     73 . S IBZ1=DEFCLIA                    ; display and stuff default clia#
     74 . S DIE=399,DA=IBIFN,DR="235///"_DEFCLIA D ^DIE    ; stuff in default
     75 . Q
     76 ;
     77 W !,?4,"Lab CLIA #         : ",IBZ1
     78 ;
     79 ; Mammo# display IB patch 320
     80 S (IBZ,IBZ1)=$P(IB("U3"),U,1)    ; retrieve mammo# from database
     81 ;
     82 ; If mammo# is there, but should not be, then blank it out
     83 I IBZ'="",'$$XRAY^IBCEP8A(IBIFN) D
     84 . NEW DIE,DA,DR
     85 . S IBZ1=IBUN        ; mammo# not needed
     86 . S DIE=399,DA=IBIFN,DR="242////@" D ^DIE
     87 . Q
     88 ;
     89 I IBZ="" S IBZ1=IBUN
     90 W !?4,"Mammography Cert # : ",IBZ1
     91 ;
     92 S Z=5,IBW=1 X IBWW
     93 W " Form Locator 19    : " S IBZ=$P($G(^DGCR(399,IBIFN,"UF31")),U,3) W $S(IBZ'="":IBZ,1:IBUN)
     94 I $P(IB("U2"),U,14)'="" W !,?4,"Homebound          : ",$$EXPAND^IBTRE(399,236,$P(IB("U2"),U,14))
     95 I $P(IB("U2"),U,15)'="" W !,?4,"Date Last Seen     : ",$$EXPAND^IBTRE(399,237,$P(IB("U2"),U,15))
     96 I $P(IB("U2"),U,16)'="" W !,?4,"Spec Prog Indicator: " S IBZ=$$EXPAND^IBTRE(399,238,$P(IB("U2"),U,16)) W $S(IBZ'="":IBZ,$$WNRBILL^IBEFUNC(IBIFN):"31",1:"")
     97 ;
     98 S Z=6,IBW=1 X IBWW
     99 S IBREQ=+$$REQMRA^IBEFUNC(IBIFN) S:IBREQ IBREQ=1
     100 S IBMRASEC=$$MRASEC^IBCEF4(IBIFN)
     101 W " ",$S('IBREQ:"Force To Print?    : ",1:"Force MRA Sec Prt? : ")
     102 S IBZ=$$EXTERNAL^DILFD(399,27+IBREQ,,+$P(IB("TX"),U,8+IBREQ))
     103 I IBMRASEC,'$P(IB("TX"),U,8),$P(IB("TX"),U,9) S IBZ="FORCED TO PRINT BY MRA PRIMARY",$P(IB("TX"),U,8)=0
     104 W $S(IBZ'=""&($P(IB("TX"),U,8+IBREQ)'=""):IBZ,'$$TXMT^IBCEF4(IBIFN):"[NOT APPLICABLE - NOT TRANSMITTABLE]",IBREQ:"NO FORCED PRINT",1:IBZ)
     105 ;
     106 S Z=7,IBW=1 X IBWW
     107 W " Provider ID Maint  : (Edit Provider ID information)",!
     108 G ^IBCSCP
     109Q Q
     110 ;
     111WRT1(IBCRED) ; Write credentials mismatch
     112 W !,*7,"  **Warning** Credentials differ from those found in NEW PERSON or IB NON VA",!,$J("",14),"BILLING PROVIDER file (",$S(IBCRED="":"none",1:IBCRED),")"
     113 W !,$J("",14),"Changes will print local, but only credentials on file transmit"
     114 Q
     115 ;
     116NSAME(DA) ; Returns 1 if div on bill is not the default billing facility
     117 Q ($P($G(^IBE(350.9,1,0)),U,2)'=$P($G(^DG(40.8,+$P(^DGCR(399,DA,0),U,22),0)),U,7))
     118 ;
     119 ;IBCSC8H

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSCE.m

    r613 r623  
    1 IBCSCE  ;ALB/MRL,MJB - MCCR SCREEN EDITS ;07 JUN 88 14:35
    2         ;;2.0;INTEGRATED BILLING;**52,80,91,106,51,137,236,245,287,349,371**;21-MAR-94;Build 57
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5         ;MAP TO DGCRSCE
    6         ; always do procedures last because they are edited upon return to screen routine
    7         I IBDR20["54," S IBDR20=$P(IBDR20,"54,",1)_$P(IBDR20,"54,",2)_"54,"
    8         I IBDR20["44," S IBDR20=$P(IBDR20,"44,",1)_$P(IBDR20,"44,",2)_"44,"
    9 LOOP    N IBDRLP,IBDRL S IBDRLP=IBDR20 F IBDRL=1:1 S IBDR20=$P(IBDRLP,",",IBDRL) Q:IBDR20=""  D EDIT
    10         Q
    11 EDIT    N IBQUERY
    12         I (IBDR20["31") D MCCR^IBCNSP2 G ENQ
    13         I (IBDR20["43")!(IBDR20["52") D ^IBCSC4D G ENQ
    14         I (IBDR20["74")!(IBDR20["53") K DR N I D ^IBCOPV S (DA,Y)=IBIFN G TMPL
    15         I (IBDR20["54"),$P($G(^IBE(350.9,1,1)),"^",17) K DR N I D EN1^IBCCPT(.IBQUERY) D CLOSE^IBSDU(.IBQUERY) G TMPL ;
    16         I (IBDR20["55") D ^IBCSC5A G ENQ
    17         I (IBDR20["45")!(IBDR20["56") D ^IBCSC5B G ENQ
    18         I (IBDR20["66")!(IBDR20["76") D EDIT^IBCRBE(IBIFN) D ASKCMB^IBCU65(IBIFN) G ENQ
    19         I IBDR20["85",$$FT^IBCEF(IBIFN)=2 D ^IBCSC8A G ENQ ; chiropractic data
    20         I IBDR20["84",$$FT^IBCEF(IBIFN)=3 D EN1^IBCEP6 G ENQ   ;UB-04
    21         I IBDR20["88",$$FT^IBCEF(IBIFN)=2 D EN1^IBCEP6 G ENQ   ;CMS-1500
    22         F Q=1:1:9 I IBDR20[("9"_Q) D EDIT^IBCSC9 G ENQ
    23 TMPL    N IBFLIAE S IBFLIAE=1 ;to invoke EN^DGREGAED from [IB SCREEN1]
    24         S DR="[IB SCREEN"_IBSR_IBSR1_"]",(DA,Y)=IBIFN,DIE="^DGCR(399,"
    25         D ^DIE K DIE,DR,DLAYGO
    26         I (IBDR20["61")!(IBDR20["71") I +$G(DGRVRCAL) D PROC^IBCU7A(IBIFN,1)
    27 ENQ     K DIE,DR,IBDR1,IBDR20,DGDRD,DGDRS,DGDRS1,DA Q
    28         ;
    29         ; W I "^11^12^13^15^14^21^22^23^"[("^"_J_"^") G W1
    30         ; I "^44^"[("^"_J_"^") S DR(2,399.0304)=".01;1;I $D(IBIP),X<$P(IBIP,""^"",2)!($P(IBIP,""^"",6)&(X>$P(IBIP,""^"",6))) K X"
    31         ; I "^64^"[("^"_J_"^") S DR(2,399.042)=".01:.03;"
    32         ; I $T(@J) S DGDRD=$P($T(@J),";;",2) D S S K=(J*10) I $T(@K) S DGDRD=$P($T(@K),";;",2) D S
    33         ; D ^IBCSCE1:("^31^")[("^"_J_"^") Q
    34         ; W1 I @DGDRS["^2^DPT(^^D SET^IBCSCE;" D ^IBCSCE1 Q
    35         ; S DGDRD="^2^DPT(^^D SET^IBCSCE;" D S,^IBCSCE1 Q
    36         ; S I $L(@DGDRS)+$L(DGDRD)<241 S @DGDRS=@DGDRS_DGDRD Q
    37         ; S DGCT=DGCT+1,DGDRS="DR(1,399,"_DGCT_")",@DGDRS=DGDRD Q
    38         ; Q
    39 16      ;;.18;
    40 31      ;;.07;S X=$P(^DGCR(399,DA,0),U,11);S Y="@"_$S(X']"":31,X="p":31,X="o":311,1:310);@310;D 1^IBCSCH1 S Y="@"_$S(IBADI=-1:31,'IBADI:312,1:313);@313;^2^DPT(^^D SET^IBCSCE;D UPDT^IBCSCE;@312;
    41 310     ;;101;102;103;S Y="@31";@311;D INST^IBCU;111;K DIC("DR"),DLAYGO;@31;
    42 32      ;;104;105;106;121;107;108;109
    43 41      ;;S:IBPTF Y="@411";159.5;@411;160;159;158;
    44 42      ;;162;
    45 43      ;;I IBPTF S Y="@943";64;65;66;67;68;S Y="@43";@943;D DX^IBCSC4B;@43;
    46 44      ;;S IBZ20=$P(^DGCR(399,DA,0),U,9);.09;D PRO^IBCSC4B;S IBASKCOD=1
    47 45      ;;41;
    48 46      ;;40;
    49 51      ;;.03;
    50 999     ;;64;65;66;67;68;
    51 52      ;;64;S:X="" Y="@99";65;S:X="" Y="@99";66;S:X="" Y="@99";67;S:X="" Y="@99";68;@99;
    52 53      ;;;;same as 74
    53 54      ;;S IBZ20=$P(^DGCR(399,DA,0),U,9);.09;S IBASKCOD=1
    54 55      ;;41;
    55 56      ;;40;
    56 61      ;;.06;164;
    57 62      ;;155;S:X=0 Y=156;157;156;S:'$D(IBOX) Y="@62";153;@62;
    58 63      ;;151;152;
    59 64      ;;161;165;
    60 65      ;;D RCD^IBCU1;42;202;S:'X Y=201;203;201;I $P(^DGCR(399,DA,"U1"),"^",11)']"" S Y="@65";210;@65;
    61 71      ;;.06;164;
    62 72      ;;155;S:X=0 Y=156;157;156;S:'$D(IBOX) Y="@72";153;@72;
    63 73      ;;151;152;
    64 74      ;;S:$D(IBOUT) Y="@999";43;@999;K IBOUT;
    65 75      ;;D RCD^IBCU1;42;202;S:'X Y=201;203;201;I $P(^DGCR(399,DA,"U1"),"^",11)']"" S Y="@75";210;@75;
    66 81      ;;208;
    67 82      ;;204;
    68 83      ;;205;
    69 84      ;;206;
    70 85      ;;207;
    71 86      ;;163;
    72         ; AD S X=$S($D(^DPT(DA,.11)):^(.11),1:""),IBPHO=$S($D(^(.13)):$P(^(.13),U,1),1:""),Y=$S($D(^(IBADD)):^(IBADD),1:""),^(IBADD)=$P(Y,U,1)_U_$P(Y,U,2)_U_$P(X,U,1,6)_U_IBPHO_U_$P(Y,U,10) K IBADD,IBPHO Q
    73         ; SET S I(0,0)=D0,Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:""),X=$P(Y(1),"^",2),D(0)=X,X=$S(D(0)>0:D(0),1:"") Q
    74         ;called by screen 3 (input template)
    75 UPDT    F IBDD=0:0 S IBDD=$O(^DPT(DFN,.312,IBDD)) Q:IBDD'>0  S IBI1=^DPT(DFN,.312,IBDD,0) I $D(^DIC(36,+IBI1,0)),$P(^(0),"^",2)'="N" S IBDD(+IBI1)=IBI1
    76         F IBAIC=0:0 S IBAIC=$O(^DGCR(399,IBIFN,"AIC",IBAIC)) Q:IBAIC'>0  I $D(IBDD(IBAIC)) F IBI1="I1","I2","I3" I $D(^DGCR(399,IBIFN,IBI1)),+^(IBI1)=IBAIC,^(IBI1)'=IBDD(IBAIC) S ^DGCR(399,IBIFN,IBI1)=IBDD(IBAIC)
    77         K IBAIC,IBDD,IBI1 Q
    78         ;
    79         ;Edit patient's address using DGREGAED API
    80 EDADDR(IBDFN)   ;
    81         I $G(IBFLIAE)'=1!(IBDFN=0) Q 0
    82         N IBFL S IBFL(1)=1
    83         N X,Y,DIE,DA,DR,DIDEL,DIW,DIEDA,DG,DICR
    84         D EN^DGREGAED(IBDFN,.IBFL)
    85         Q 1
    86         ;IBCSCE
     1IBCSCE ;ALB/MRL,MJB - MCCR SCREEN EDITS ;07 JUN 88 14:35
     2 ;;2.0;INTEGRATED BILLING;**52,80,91,106,51,137,236,245,287,349**;21-MAR-94;Build 46
     3 ;;Per VHA Directive 2004-038, this routine should not be modified.
     4 ;
     5 ;MAP TO DGCRSCE
     6 ; always do procedures last because they are edited upon return to screen routine
     7 I IBDR20["54," S IBDR20=$P(IBDR20,"54,",1)_$P(IBDR20,"54,",2)_"54,"
     8 I IBDR20["44," S IBDR20=$P(IBDR20,"44,",1)_$P(IBDR20,"44,",2)_"44,"
     9LOOP N IBDRLP,IBDRL S IBDRLP=IBDR20 F IBDRL=1:1 S IBDR20=$P(IBDRLP,",",IBDRL) Q:IBDR20=""  D EDIT
     10 Q
     11EDIT N IBQUERY
     12 I (IBDR20["31") D MCCR^IBCNSP2 G ENQ
     13 I (IBDR20["43")!(IBDR20["52") D ^IBCSC4D G ENQ
     14 I (IBDR20["74")!(IBDR20["53") K DR N I D ^IBCOPV S (DA,Y)=IBIFN G TMPL
     15 I (IBDR20["54"),$P($G(^IBE(350.9,1,1)),"^",17) K DR N I D EN1^IBCCPT(.IBQUERY) D CLOSE^IBSDU(.IBQUERY) G TMPL ;
     16 I (IBDR20["55") D ^IBCSC5A G ENQ
     17 I (IBDR20["45")!(IBDR20["56") D ^IBCSC5B G ENQ
     18 I (IBDR20["66")!(IBDR20["76") D EDIT^IBCRBE(IBIFN) D ASKCMB^IBCU65(IBIFN) G ENQ
     19 I IBDR20["84",$$FT^IBCEF(IBIFN)=3 D EN1^IBCEP6 G ENQ   ;UB-04
     20 I IBDR20["87",$$FT^IBCEF(IBIFN)=2 D EN1^IBCEP6 G ENQ   ;CMS-1500
     21 F Q=1:1:9 I IBDR20[("9"_Q) D EDIT^IBCSC9 G ENQ
     22TMPL N IBFLIAE S IBFLIAE=1 ;to invoke EN^DGREGAED from [IB SCREEN1]
     23 S DR="[IB SCREEN"_IBSR_IBSR1_"]",(DA,Y)=IBIFN,DIE="^DGCR(399,"
     24 D ^DIE K DIE,DR,DLAYGO
     25 I (IBDR20["61")!(IBDR20["71") I +$G(DGRVRCAL) D PROC^IBCU7A(IBIFN,1)
     26ENQ K DIE,DR,IBDR1,IBDR20,DGDRD,DGDRS,DGDRS1,DA Q
     27 ;
     28 ; W I "^11^12^13^15^14^21^22^23^"[("^"_J_"^") G W1
     29 ; I "^44^"[("^"_J_"^") S DR(2,399.0304)=".01;1;I $D(IBIP),X<$P(IBIP,""^"",2)!($P(IBIP,""^"",6)&(X>$P(IBIP,""^"",6))) K X"
     30 ; I "^64^"[("^"_J_"^") S DR(2,399.042)=".01:.03;"
     31 ; I $T(@J) S DGDRD=$P($T(@J),";;",2) D S S K=(J*10) I $T(@K) S DGDRD=$P($T(@K),";;",2) D S
     32 ; D ^IBCSCE1:("^31^")[("^"_J_"^") Q
     33 ; W1 I @DGDRS["^2^DPT(^^D SET^IBCSCE;" D ^IBCSCE1 Q
     34 ; S DGDRD="^2^DPT(^^D SET^IBCSCE;" D S,^IBCSCE1 Q
     35 ; S I $L(@DGDRS)+$L(DGDRD)<241 S @DGDRS=@DGDRS_DGDRD Q
     36 ; S DGCT=DGCT+1,DGDRS="DR(1,399,"_DGCT_")",@DGDRS=DGDRD Q
     37 ; Q
     3816 ;;.18;
     3931 ;;.07;S X=$P(^DGCR(399,DA,0),U,11);S Y="@"_$S(X']"":31,X="p":31,X="o":311,1:310);@310;D 1^IBCSCH1 S Y="@"_$S(IBADI=-1:31,'IBADI:312,1:313);@313;^2^DPT(^^D SET^IBCSCE;D UPDT^IBCSCE;@312;
     40310 ;;101;102;103;S Y="@31";@311;D INST^IBCU;111;K DIC("DR"),DLAYGO;@31;
     4132 ;;104;105;106;121;107;108;109
     4241 ;;S:IBPTF Y="@411";159.5;@411;160;159;158;
     4342 ;;162;
     4443 ;;I IBPTF S Y="@943";64;65;66;67;68;S Y="@43";@943;D DX^IBCSC4B;@43;
     4544 ;;S IBZ20=$P(^DGCR(399,DA,0),U,9);.09;D PRO^IBCSC4B;S IBASKCOD=1
     4645 ;;41;
     4746 ;;40;
     4851 ;;.03;
     49999 ;;64;65;66;67;68;
     5052 ;;64;S:X="" Y="@99";65;S:X="" Y="@99";66;S:X="" Y="@99";67;S:X="" Y="@99";68;@99;
     5153 ;;;;same as 74
     5254 ;;S IBZ20=$P(^DGCR(399,DA,0),U,9);.09;S IBASKCOD=1
     5355 ;;41;
     5456 ;;40;
     5561 ;;.06;164;
     5662 ;;155;S:X=0 Y=156;157;156;S:'$D(IBOX) Y="@62";153;@62;
     5763 ;;151;152;
     5864 ;;161;165;
     5965 ;;D RCD^IBCU1;42;202;S:'X Y=201;203;201;I $P(^DGCR(399,DA,"U1"),"^",11)']"" S Y="@65";210;@65;
     6071 ;;.06;164;
     6172 ;;155;S:X=0 Y=156;157;156;S:'$D(IBOX) Y="@72";153;@72;
     6273 ;;151;152;
     6374 ;;S:$D(IBOUT) Y="@999";43;@999;K IBOUT;
     6475 ;;D RCD^IBCU1;42;202;S:'X Y=201;203;201;I $P(^DGCR(399,DA,"U1"),"^",11)']"" S Y="@75";210;@75;
     6581 ;;208;
     6682 ;;204;
     6783 ;;205;
     6884 ;;206;
     6985 ;;207;
     7086 ;;163;
     71 ; AD S X=$S($D(^DPT(DA,.11)):^(.11),1:""),IBPHO=$S($D(^(.13)):$P(^(.13),U,1),1:""),Y=$S($D(^(IBADD)):^(IBADD),1:""),^(IBADD)=$P(Y,U,1)_U_$P(Y,U,2)_U_$P(X,U,1,6)_U_IBPHO_U_$P(Y,U,10) K IBADD,IBPHO Q
     72 ; SET S I(0,0)=D0,Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:""),X=$P(Y(1),"^",2),D(0)=X,X=$S(D(0)>0:D(0),1:"") Q
     73 ;called by screen 3 (input template)
     74UPDT F IBDD=0:0 S IBDD=$O(^DPT(DFN,.312,IBDD)) Q:IBDD'>0  S IBI1=^DPT(DFN,.312,IBDD,0) I $D(^DIC(36,+IBI1,0)),$P(^(0),"^",2)'="N" S IBDD(+IBI1)=IBI1
     75 F IBAIC=0:0 S IBAIC=$O(^DGCR(399,IBIFN,"AIC",IBAIC)) Q:IBAIC'>0  I $D(IBDD(IBAIC)) F IBI1="I1","I2","I3" I $D(^DGCR(399,IBIFN,IBI1)),+^(IBI1)=IBAIC,^(IBI1)'=IBDD(IBAIC) S ^DGCR(399,IBIFN,IBI1)=IBDD(IBAIC)
     76 K IBAIC,IBDD,IBI1 Q
     77 ;
     78 ;Edit patient's address using DGREGAED API
     79EDADDR(IBDFN) ;
     80 I $G(IBFLIAE)'=1!(IBDFN=0) Q 0
     81 N IBFL S IBFL(1)=1
     82 N X,Y,DIE,DA,DR,DIDEL,DIW,DIEDA,DG,DICR
     83 D EN^DGREGAED(IBDFN,.IBFL)
     84 Q 1
     85 ;IBCSCE

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSCH.m

    r613 r623  
    1 IBCSCH  ;ALB/MJB - MCCR HELP ROUTINE ;03 JUN 88 15:25
    2         ;;2.0;INTEGRATED BILLING;**52,80,106,124,138,51,148,137,161,245,232,287,348,349,374,371,395**;21-MAR-94;Build 3
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5         ;MAP TO DGCRSCH
    6         ;
    7         N I,C,IBSCNNZ,IBQ,IBPRNT,Z S IBSCNNZ=$$UP^XLFSTR($G(IBSCNN)),IBQ=0
    8         I '$D(IBPAR) D  Q:IBQ
    9         . I $F(".?1500.?HCFA.","."_$G(IBSCNNZ)_"."),$$FT^IBCEF(IBIFN)=2 S IBQ=1,IBPRNT=2 D BL24(IBIFN,0) Q
    10         . I $G(IBSCNNZ)="?SC" S IBQ=1 D DISPSC(IBIFN) Q
    11         . I $G(IBSCNNZ)="?INS" S IBQ=1 D INSDSPL(IBIFN) Q
    12         . I $G(IBSCNNZ)="?INX" S IBQ=1 D INSDSPLX(IBIFN) Q
    13         . I $G(IBSCNNZ)="?PRV" S IBQ=1 D DISPROPT(IBIFN) Q
    14         . I $G(IBSCNNZ)="?CHG" S IBQ=1 D DISPCHG^IBCRBH1(IBIFN) Q
    15         . I $G(IBSCNNZ)="?PRC" S IBQ=1 D DISPPRC^IBCSCH1(IBIFN) Q
    16         . I $G(IBSCNNZ)="?CPT" S IBQ=1 D BCPTCHG^IBCRBH2(IBIFN) Q
    17         . I $G(IBSCNNZ)="?INC" S IBQ=1 D EDIT^IBCBB(IBIFN) Q
    18         . I $G(IBSCNNZ)="?CLA",$$CK0^IBCIUT1() S IBQ=1 D CLA^IBCISC(IBIFN) Q
    19         . I $G(IBSCNNZ)="?MRA",$$MCRONBIL^IBEFUNC(IBIFN),$T(SCR^IBCEMVU)'="" S IBQ=1 D SCR^IBCEMVU(IBIFN) Q
    20         . I $G(IBSCNNZ)="?ID" S IBQ=1 D DISPID^IBCEF74(IBIFN) Q
    21         . I $G(IBSCNNZ)="?RX" S IBQ=1 D DISPRX^IBCSCH1(IBIFN) Q
    22         . Q
    23         ;
    24         S IBH("HELP")="" D ^IBCSCU,H^IBCSCU K IBH("HELP") W !,"Enter '^' to stop the display ",$S(IBV:"",1:"and edit "),"of data,"
    25         W:'$D(IBPAR) " '^N' to jump to screen #N (see",!,"listing below), <RET> to continue on to the next available screen" I IBV W "." G M
    26         W " or enter",!,"the field group number(s) you wish to edit using commas and dashes as",!,"delimiters.  Those groups enclosed in brackets ""[]"" are editable while those"
    27         W !,"enclosed in arrows ""<>"" are not."
    28         G:$D(IBPAR) M1
    29 M       W "  Special help screens:"
    30         W !,?5,"Enter '?SC' to view SC Status and Rated Disabilities."
    31         W !,?5,"Enter '?INS' to view the patients insurance policies."
    32         W !,?5,"Enter '?INX' to view the patients insurance policies with comments."
    33         W !,?5,"Enter '?PRV' to view provider specific information."
    34         W !,?5,"Enter '?PRC' to view all procedures on the bill and related data."
    35         W !,?5,"Enter '?CHG' to view all items on the bill with potential charges."
    36         W !,?5,"Enter '?CPT' to view all charges for selected CPT codes and bill type."
    37         I $$FT^IBCEF(IBIFN)=2 W !,?5,"Enter '?1500' to view how block 24 will print on a CMS-1500."
    38         W !,?5,"Enter '?INC' to execute the edits & view the bill inconsistencies."
    39         I $$CK0^IBCIUT1() W !?5,"Enter '?CLA' to view the ClaimsManager options."
    40         I $$MCRONBIL^IBEFUNC(IBIFN) W !?5,"Enter '?MRA' to view Medicare Remittance Advice EOB's on file."
    41         W !,?5,"Enter '?ID' to view all IDs to be electronically transmitted on this claim."
    42         W !,?5,"Enter '?RX' to view all prescriptions on this claim."
    43         ;
    44         I +IBSR'=9 S Z="DATA GROUPS ON SCREEN "_+IBSR W ! X IBWW D @(IBSR1_IBSR) D W
    45         D S W ! F I=$Y:1:20 W !
    46         S Z="PRESS <RETURN> KEY" X IBWW W " to RETURN to SCREEN ",+IBSR R X:DTIME Q
    47 M1      N I,Z S Z="DATA GROUPS ON PARAMETER SCREEN" W !! X IBWW D @(IBSR1_IBSR) D W W ! F I=$Y:1:20 W !
    48         S Z="PRESS <RETURN> KEY" X IBWW W " to RETURN to PARAMETER SCREEN" R X:DTIME Q
    49 1       S X="DOB^Alias Name^Sex, Marital Status^Veteran Status, Eligibility^Address, Temporary Address^SC at Time of Care" Q
    50 2       S X="Patient Employer Name, Address^Spouse Employer Name, Address" Q
    51 3       S X="Payer Information^Provider Numbers^Mailing Address" Q
    52 4       S X="Admission Information^Discharge Information^Diagnosis Code(s)^Coding Method, Inpt Proc Code(s)^Occurrence Code(s)^Condition Code(s)^Value Code(s)" Q
    53 5       S X="Event Date^Outpatient Diagnosis^Outpatient Visits^Coding Method, Opt. Pro. Code(s)^Occurrence Code(s)^Condition Code(s)" Q
    54 6       S X="Bill Type, Covered/Non-Covered Days^R.O.I., Assignment of Benefits^Statement Covers Period^Bedsection, Length of Stay^Revenue Code(s), Offset, Total^Rate Schedule(s)^Prior Payments/Claims" Q
    55 7       S X="Bill Type, Covered/Non-Covered Days^R.O.I., Assignment of Benefits^Statement Covers Period^Outpatient Visits^Revenue Code(s), Offset, Total^Rate Schedule(s)^Prior Payments/Claims" Q
    56 8       S X="Bill Remark^Form Locator 2^Form Locator 9^Form Locator 27^Form Locator 45^Form Locator 92^Form Locator 93^Tx Auth. Code" Q
    57 9       S X="Locally defined fields" Q
    58 28      S X="Bill Remark, ICN/DCN's, Tx Auth. Code, Admit Diagnosis/Source ^Providers^Force to Print^Provider ID Maintenance^Other Facility (VA/non)" Q
    59 H8      S X="Period Unable to Work^Admit Dx, ICN/DCN, Tx/Prior Auth. Code^Providers^Non-VA Facility^Chiropractic Data^Form Locator 19^Force to Print^Provider ID Maintenance" Q
    60 PAR     S X="Fed Tax #, BC/BS #, MAS Svc Pointer^Bill Signer, Billing Supervisor^Security Parameters, Outpatient CPT parameters ^Remarks, Mailgroups^Agent Cashier Address/Phone" Q
    61 S       N C,I,Z,J W !! S Z="AVAILABLE SCREENS" X IBWW
    62         S X="Demographic^Employment^Payer^Inpatient Event^Outpatient Event^Inpatient Billing - General^Outpatient Billing - General^Billing - Specific^Locally Defined"
    63         S C=0 F I=1:1 S J=$P(X,"^",I) Q:J=""  I '$E(IBVV,I) S C=C+1,Z="^"_I,IBW=(C#2) W:'(C#2) ?41 X IBWW S Z=$S(I?1N:" ",1:" ")_J_" Data" W Z
    64         Q
    65 W       N I,J,Z
    66         F I=1:1 S J=$P(X,"^",I) Q:J=""  S Z=I,IBW=(I#2) W:'(I#2) ?42 X IBWW W " "_J
    67         W:'(I-1)#2 ! Q
    68         Q
    69         ;IBCSCH
    70         ;
    71         ;
    72 BL24(IBIFN,IBNOSHOW)    ; display block 24 of CMS-1500
    73         ; IBNOSHOW = 1 for not to show error/warning text line
    74         N X,Y,DIR,IBPG,IBLN,IBCOL,IBX,IBQ,IBLC,IBLIN,IBPFORM,IBD,IBC1,Z,Z0,IBXDATA,IBXSAVE,IBNXPG
    75         K ^TMP("IBXSAVE",$J)
    76         S IBQ=0,IBLC=9 Q:'$G(IBIFN)  K ^TMP("IBXDISP",$J)
    77         ;
    78         S IBLIN=$$BOX24D^IBCEF11()
    79         S IBPFORM=$S($P($G(^IBE(353,2,2)),U,8):$P(^(2),U,8),1:2)
    80         S IBX=$$BILLN^IBCEFG0(0,"1^99",IBLIN,+IBIFN,IBPFORM)
    81         ;
    82         W @IOF,!,"Example of diagnoses, procedures and charges printing on the CMS-1500"
    83         W !,"--------------------------------------------------------------------------------"
    84         ;
    85         ; box 19 - lines 36-37
    86         F Z=+IBLIN,IBLIN+1 I $D(^TMP("IBXDISP",$J,1,Z)) S Z0=$G(^TMP("IBXDISP",$J,1,Z,+$O(^TMP("IBXDISP",$J,1,Z,20),-1))) I Z0'="" S:Z=+IBLIN Z0="BOX 19 DATA: "_Z0 W !,Z0
    87         ;
    88         ; box 21 - lines 39-41
    89         W !,"21. diagnosis"
    90         I $D(^TMP("IBXDISP",$J,2,IBLIN+3)) W ?16,"(1st 4 only)"
    91         W !,?5,"1. ",$G(^TMP("IBXDISP",$J,1,IBLIN+3,3)),?25,"3. ",$G(^TMP("IBXDISP",$J,1,IBLIN+3,30))
    92         W !,?5,"2. ",$G(^TMP("IBXDISP",$J,1,IBLIN+5,3)),?25,"4. ",$G(^TMP("IBXDISP",$J,1,IBLIN+5,30))
    93         ;
    94         ; box 24 - lines 44-55
    95         D PG
    96         S IBPG=0 F  S IBPG=$O(^TMP("IBXDISP",$J,IBPG)) Q:'IBPG  D  Q:IBQ
    97         . I '$D(^TMP("IBXDISP",$J,IBPG,IBLIN+9)) Q   ; no line's on this page
    98         . F IBLN=IBLIN+8:1:+$P(IBLIN,U,2) S IBCOL=$O(^TMP("IBXDISP",$J,IBPG,IBLN,0)) Q:'IBCOL&'$O(^TMP("IBXDISP",$J,IBPG,IBLN))  S IBLC=IBLC+1 I IBCOL D  Q:IBQ
    99         .. S IBCOL=0,IBC1=1 F  S IBCOL=$O(^TMP("IBXDISP",$J,IBPG,IBLN,IBCOL)) Q:'IBCOL  I $TR($G(^(IBCOL))," ")'="" D
    100         ... W:IBC1 ! S IBC1=0 W ?(IBCOL-1),$G(^TMP("IBXDISP",$J,IBPG,IBLN,IBCOL))
    101         . S IBNXPG=$O(^TMP("IBXDISP",$J,IBPG))   ; next page
    102         . I 'IBQ,IBNXPG,$D(^TMP("IBXDISP",$J,IBNXPG,IBLIN+9)) S IBLIN=$$BOX24D^IBCEF11(),IBQ=$$PAUSE^IBCSCH1(IBLC) Q:IBQ  S IBLC=9 W @IOF D PG
    103         . Q
    104         ;
    105         W !,"--------------------------------------------------------------------------------"
    106         I 'IBPG,'IBQ S IBQ=$$PAUSE^IBCSCH1(IBLC)
    107         K ^TMP("IBXDISP",$J),^TMP("IBXSAVE",$J)
    108         Q
    109         ;
    110 PG      ; Display box 24 letters at top of charge list
    111         W !,"24. A             B  C    D                 E         F     G H I    J"
    112         W !,"--------------------------------------------------------------------------------"
    113         Q
    114         ;
    115 INSDSPL(IBIFN)  ; Display patient's policies
    116         N DIR,X,Y,IBX,DFN,IBDTIN,IBCOVEXT W @IOF
    117         S IBX=$G(^DGCR(399,+$G(IBIFN),0)),DFN=$P(IBX,U,2),IBDTIN=$P(IBX,U,3),IBCOVEXT=1
    118         I +DFN D DISPDT^IBCNS W ! S DIR("A")="Press RETURN to continue",DIR(0)="E" D ^DIR K DIR
    119         Q
    120         ;
    121 INSDSPLX(IBIFN) ; Display patient's policies extended (?INX)
    122         N IBX,DFN,IBDATE S IBX=$G(^DGCR(399,+$G(IBIFN),0)),DFN=$P(IBX,U,2),IBDATE=$P(IBX,U,3) D DISP^IBCNS3(DFN,IBDATE,123)
    123         Q
    124         ;
    125 DISPSC(IBIFN)   ; display patients SC Status and Rated Disabilities
    126         N IB0,DFN,IBSC,IBX,VAEL,VAERR
    127         S IB0=$G(^DGCR(399,+$G(IBIFN),0)),DFN=$P(IB0,U,2),IBSC=$P(IB0,U,18)
    128         W !,@IOF,!,"SC Status and Rated Disabilities for ",$P($G(^DPT(+$G(DFN),0)),U,1)
    129         W !,"--------------------------------------------------------------------------------",!
    130         I +$G(IBIFN) W !," SC At Time Of Care: ",$S(IBSC=1:"Yes",IBSC=0:"No",1:"")
    131         I +$G(DFN) D ELIG^VADPT D DIS^DGRPDB
    132         W !!,"--------------------------------------------------------------------------------"
    133         S IBX=$$PAUSE^IBCSCH1(19)
    134         Q
    135         ;
    136 DISPROPT(IBIFN) ; prompt for VA or Non-VA provider.
    137         N X,Y,DIR
    138         S DIR(0)="SAO^V:VA PROVIDER;N:NON-VA PROVIDER",DIR("A")="(V)A or (N)on-VA Provider: ",DIR("B")="V"
    139         D ^DIR
    140         I Y="V" D DISPPRV^IBCSCH2(IBIFN) Q
    141         I Y="N" D DISPNVA^IBCSCH2(IBIFN)
    142         Q
    143         ;
     1IBCSCH ;ALB/MJB - MCCR HELP ROUTINE ;03 JUN 88 15:25
     2 ;;2.0;INTEGRATED BILLING;**52,80,106,124,138,51,148,137,161,245,232,287,348,349,374**;21-MAR-94;Build 16
     3 ;;Per VHA Directive 2004-038, this routine should not be modified.
     4 ;
     5 ;MAP TO DGCRSCH
     6 ;
     7 N I,C,IBSCNNZ,IBQ,IBPRNT,Z S IBSCNNZ=$$UP^XLFSTR($G(IBSCNN)),IBQ=0
     8 I '$D(IBPAR) D  Q:IBQ
     9 . I $F(".?1500.?HCFA.","."_$G(IBSCNNZ)_"."),$$FT^IBCEF(IBIFN)=2 S IBQ=1,IBPRNT=2 D BL24(IBIFN,0) Q
     10 . I $G(IBSCNNZ)="?SC" S IBQ=1 D DISPSC(IBIFN) Q
     11 . I $G(IBSCNNZ)="?INS" S IBQ=1 D INSDSPL(IBIFN) Q
     12 . I $G(IBSCNNZ)="?INX" S IBQ=1 D INSDSPLX(IBIFN) Q
     13 . I $G(IBSCNNZ)="?PRV" S IBQ=1 D DISPROPT(IBIFN) Q
     14 . I $G(IBSCNNZ)="?CHG" S IBQ=1 D DISPCHG^IBCRBH1(IBIFN) Q
     15 . I $G(IBSCNNZ)="?PRC" S IBQ=1 D DISPPRC^IBCSCH1(IBIFN) Q
     16 . I $G(IBSCNNZ)="?CPT" S IBQ=1 D BCPTCHG^IBCRBH2(IBIFN) Q
     17 . I $G(IBSCNNZ)="?INC" S IBQ=1 D EDIT^IBCBB(IBIFN) Q
     18 . I $G(IBSCNNZ)="?CLA",$$CK0^IBCIUT1() S IBQ=1 D CLA^IBCISC(IBIFN) Q
     19 . I $G(IBSCNNZ)="?MRA",$$MCRONBIL^IBEFUNC(IBIFN),$T(SCR^IBCEMVU)'="" S IBQ=1 D SCR^IBCEMVU(IBIFN) Q
     20 . I $G(IBSCNNZ)="?ID" S IBQ=1 D DISPID^IBCEF74(IBIFN) Q
     21 . Q
     22 ;
     23 S IBH("HELP")="" D ^IBCSCU,H^IBCSCU K IBH("HELP") W !,"Enter '^' to stop the display ",$S(IBV:"",1:"and edit "),"of data,"
     24 W:'$D(IBPAR) " '^N' to jump to screen #N (see",!,"listing below), <RET> to continue on to the next available screen" I IBV W "." G M
     25 W " or enter",!,"the field group number(s) you wish to edit using commas and dashes as",!,"delimiters.  Those groups enclosed in brackets ""[]"" are editable while those"
     26 W !,"enclosed in arrows ""<>"" are not."
     27 G:$D(IBPAR) M1
     28M W "  Special help screens:"
     29 W !,?5,"Enter '?SC' to view SC Status and Rated Disabilities."
     30 W !,?5,"Enter '?INS' to view the patients insurance policies."
     31 W !,?5,"Enter '?INX' to view the patients insurance policies with comments."
     32 W !,?5,"Enter '?PRV' to view provider specific information."
     33 W !,?5,"Enter '?PRC' to view all procedures on the bill and related data."
     34 W !,?5,"Enter '?CHG' to view all items on the bill with potential charges."
     35 W !,?5,"Enter '?CPT' to view all charges for selected CPT codes and bill type."
     36 I $$FT^IBCEF(IBIFN)=2 W !,?5,"Enter '?1500' to view how block 24 will print on a CMS-1500."
     37 W !,?5,"Enter '?INC' to execute the edits & view the bill inconsistencies."
     38 I $$CK0^IBCIUT1() W !?5,"Enter '?CLA' to view the ClaimsManager options."
     39 I $$MCRONBIL^IBEFUNC(IBIFN) W !?5,"Enter '?MRA' to view Medicare Remittance Advice EOB's on file."
     40 W !,?5,"Enter '?ID' to view all IDs to be electronically transmitted on this claim."
     41 ;
     42 I +IBSR'=9 S Z="DATA GROUPS ON SCREEN "_+IBSR W ! X IBWW D @(IBSR1_IBSR) D W
     43 D S W ! F I=$Y:1:20 W !
     44 S Z="PRESS <RETURN> KEY" X IBWW W " to RETURN to SCREEN ",+IBSR R X:DTIME Q
     45M1 N I,Z S Z="DATA GROUPS ON PARAMETER SCREEN" W !! X IBWW D @(IBSR1_IBSR) D W W ! F I=$Y:1:20 W !
     46 S Z="PRESS <RETURN> KEY" X IBWW W " to RETURN to PARAMETER SCREEN" R X:DTIME Q
     471 S X="DOB^Alias Name^Sex, Marital Status^Veteran Status, Eligibility^Address, Temporary Address^SC at Time of Care" Q
     482 S X="Patient Employer Name, Address^Spouse Employer Name, Address" Q
     493 S X="Payer Information^Provider Numbers^Mailing Address" Q
     504 S X="Admission Information^Discharge Information^Diagnosis Code(s)^Coding Method, Inpt Proc Code(s)^Occurrence Code(s)^Condition Code(s)^Value Code(s)" Q
     515 S X="Event Date^Outpatient Diagnosis^Outpatient Visits^Coding Method, Opt. Pro. Code(s)^Occurrence Code(s)^Condition Code(s)" Q
     526 S X="Bill Type, Covered/Non-Covered Days^R.O.I., Assignment of Benefits^Statement Covers Period^Bedsection, Length of Stay^Revenue Code(s), Offset, Total^Rate Schedule(s)^Prior Payments/Claims" Q
     537 S X="Bill Type, Covered/Non-Covered Days^R.O.I., Assignment of Benefits^Statement Covers Period^Outpatient Visits^Revenue Code(s), Offset, Total^Rate Schedule(s)^Prior Payments/Claims" Q
     548 S X="Bill Remark^Form Locator 2^Form Locator 9^Form Locator 27^Form Locator 45^Form Locator 92^Form Locator 93^Tx Auth. Code" Q
     559 S X="Locally defined fields" Q
     5628 S X="Bill Remark, ICN/DCN's, Tx Auth. Code, Admit Diagnosis/Source ^Providers^Force to Print^Provider ID Maintenance^Other Facility (VA/non)" Q
     57H8 S X="Period Unable to Work^Admit Dx, ICN/DCN, Tx/Prior Auth. Code^Providers^Non-VA Facility^Form Locator 19^Force to Print" Q
     58PAR S X="Fed Tax #, BC/BS #, MAS Svc Pointer^Bill Signer, Billing Supervisor^Security Parameters, Outpatient CPT parameters ^Remarks, Mailgroups^Agent Cashier Address/Phone" Q
     59S N C,I,Z,J W !! S Z="AVAILABLE SCREENS" X IBWW
     60 S X="Demographic^Employment^Payer^Inpatient Event^Outpatient Event^Inpatient Billing - General^Outpatient Billing - General^Billing - Specific^Locally Defined"
     61 S C=0 F I=1:1 S J=$P(X,"^",I) Q:J=""  I '$E(IBVV,I) S C=C+1,Z="^"_I,IBW=(C#2) W:'(C#2) ?41 X IBWW S Z=$S(I?1N:" ",1:" ")_J_" Data" W Z
     62 Q
     63W N I,J,Z
     64 F I=1:1 S J=$P(X,"^",I) Q:J=""  S Z=I,IBW=(I#2) W:'(I#2) ?42 X IBWW W " "_J
     65 W:'(I-1)#2 ! Q
     66 Q
     67 ;IBCSCH
     68 ;
     69 ;
     70BL24(IBIFN,IBNOSHOW) ; display block 24 of CMS-1500
     71 ; IBNOSHOW = 1 for not to show error/warning text line
     72 N X,Y,DIR,IBPG,IBLN,IBCOL,IBX,IBQ,IBLC,IBLIN,IBPFORM,IBD,IBC1,Z,Z0,IBXDATA,IBXSAVE,IBNXPG
     73 K ^TMP("IBXSAVE",$J)
     74 S IBQ=0,IBLC=9 Q:'$G(IBIFN)  K ^TMP("IBXDISP",$J)
     75 ;
     76 S IBLIN=$$BOX24D^IBCEF11()
     77 S IBPFORM=$S($P($G(^IBE(353,2,2)),U,8):$P(^(2),U,8),1:2)
     78 S IBX=$$BILLN^IBCEFG0(0,"1^99",IBLIN,+IBIFN,IBPFORM)
     79 ;
     80 W @IOF,!,"Example of diagnoses, procedures and charges printing on the CMS-1500"
     81 W !,"--------------------------------------------------------------------------------"
     82 ;
     83 ; box 19 - lines 36-37
     84 F Z=+IBLIN,IBLIN+1 I $D(^TMP("IBXDISP",$J,1,Z)) S Z0=$G(^TMP("IBXDISP",$J,1,Z,+$O(^TMP("IBXDISP",$J,1,Z,20),-1))) I Z0'="" S:Z=+IBLIN Z0="BOX 19 DATA: "_Z0 W !,Z0
     85 ;
     86 ; box 21 - lines 39-41
     87 W !,"21. diagnosis"
     88 I $D(^TMP("IBXDISP",$J,2,IBLIN+3)) W ?16,"(1st 4 only)"
     89 W !,?5,"1. ",$G(^TMP("IBXDISP",$J,1,IBLIN+3,3)),?25,"3. ",$G(^TMP("IBXDISP",$J,1,IBLIN+3,30))
     90 W !,?5,"2. ",$G(^TMP("IBXDISP",$J,1,IBLIN+5,3)),?25,"4. ",$G(^TMP("IBXDISP",$J,1,IBLIN+5,30))
     91 ;
     92 ; box 24 - lines 44-55
     93 D PG
     94 S IBPG=0 F  S IBPG=$O(^TMP("IBXDISP",$J,IBPG)) Q:'IBPG  D  Q:IBQ
     95 . I '$D(^TMP("IBXDISP",$J,IBPG,IBLIN+9)) Q   ; no line's on this page
     96 . F IBLN=IBLIN+8:1:+$P(IBLIN,U,2) S IBCOL=$O(^TMP("IBXDISP",$J,IBPG,IBLN,0)) Q:'IBCOL&'$O(^TMP("IBXDISP",$J,IBPG,IBLN))  S IBLC=IBLC+1 I IBCOL D  Q:IBQ
     97 .. S IBCOL=0,IBC1=1 F  S IBCOL=$O(^TMP("IBXDISP",$J,IBPG,IBLN,IBCOL)) Q:'IBCOL  I $TR($G(^(IBCOL))," ")'="" D
     98 ... W:IBC1 ! S IBC1=0 W ?(IBCOL-1),$G(^TMP("IBXDISP",$J,IBPG,IBLN,IBCOL))
     99 . S IBNXPG=$O(^TMP("IBXDISP",$J,IBPG))   ; next page
     100 . I 'IBQ,IBNXPG,$D(^TMP("IBXDISP",$J,IBNXPG,IBLIN+9)) S IBLIN=$$BOX24D^IBCEF11(),IBQ=$$PAUSE^IBCSCH1(IBLC) Q:IBQ  S IBLC=9 W @IOF D PG
     101 . Q
     102 ;
     103 W !,"--------------------------------------------------------------------------------"
     104 I 'IBPG,'IBQ S IBQ=$$PAUSE^IBCSCH1(IBLC)
     105 K ^TMP("IBXDISP",$J),^TMP("IBXSAVE",$J)
     106 Q
     107 ;
     108PG ; Display box 24 letters at top of charge list
     109 W !,"24. A             B  C    D                 E         F     G H I    J"
     110 W !,"--------------------------------------------------------------------------------"
     111 Q
     112 ;
     113INSDSPL(IBIFN) ; Display patient's policies
     114 N DIR,X,Y,IBX,DFN,IBDTIN,IBCOVEXT W @IOF
     115 S IBX=$G(^DGCR(399,+$G(IBIFN),0)),DFN=$P(IBX,U,2),IBDTIN=$P(IBX,U,3),IBCOVEXT=1
     116 I +DFN D DISPDT^IBCNS W ! S DIR("A")="Press RETURN to continue",DIR(0)="E" D ^DIR K DIR
     117 Q
     118 ;
     119INSDSPLX(IBIFN) ; Display patient's policies extended (?INX)
     120 N IBX,DFN,IBDATE S IBX=$G(^DGCR(399,+$G(IBIFN),0)),DFN=$P(IBX,U,2),IBDATE=$P(IBX,U,3) D DISP^IBCNS3(DFN,IBDATE,123)
     121 Q
     122 ;
     123DISPSC(IBIFN) ; display patients SC Status and Rated Disabilities
     124 N IB0,DFN,IBSC,IBX,VAEL,VAERR
     125 S IB0=$G(^DGCR(399,+$G(IBIFN),0)),DFN=$P(IB0,U,2),IBSC=$P(IB0,U,18)
     126 W !,@IOF,!,"SC Status and Rated Disabilities for ",$P($G(^DPT(+$G(DFN),0)),U,1)
     127 W !,"--------------------------------------------------------------------------------",!
     128 I +$G(IBIFN) W !," SC At Time Of Care: ",$S(IBSC=1:"Yes",IBSC=0:"No",1:"")
     129 I +$G(DFN) D ELIG^VADPT D DIS^DGRPDB
     130 W !!,"--------------------------------------------------------------------------------"
     131 S IBX=$$PAUSE^IBCSCH1(19)
     132 Q
     133 ;
     134DISPROPT(IBIFN) ; prompt for VA or Non-VA provider.
     135 N X,Y,DIR
     136 S DIR(0)="SAO^V:VA PROVIDER;N:NON-VA PROVIDER",DIR("A")="(V)A or (N)on-VA Provider: ",DIR("B")="V"
     137 D ^DIR
     138 I Y="V" D DISPPRV^IBCSCH2(IBIFN) Q
     139 I Y="N" D DISPNVA^IBCSCH2(IBIFN)
     140 Q
     141 ;

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSCH1.m

    r613 r623  
    1 IBCSCH1 ;ALB/MRL - BILLING HELPS (CONTINUED) ; 01 JUN 88 12:00
    2         ;;2.0;INTEGRATED BILLING;**106,125,51,245,266,395**;21-MAR-94;Build 3
    3         ;;Per VHA Directive 10-93-142, this routine should not be modified.
    4         ;
    5         ;MAP TO DGCRSCH1
    6         ;
    7 1       W !!,"DO YOU WISH TO ADD/EDIT INSURANCE COMPANY DATA FOR THIS PATIENT" S %=2 D YN^DICN S IBADI=$S(%=1!(%=-1):%,1:0)
    8         I '% W !!?4,"YES - And I'll prompt you so that you may add insurance data to the PATIENT",!?9,"file for this patient.",!?4,"NO  - To bypass this editing of the PATIENT file." G 1
    9         Q
    10         ;
    11 2       W !!,"If you updated insurance information for any policy which is already specified",!,"as either a PRIMARY, SECONDARY or TERIARY for this billing episode, you will"
    12         W !,"need to press the <RETURN> key through the following prompts in order to insure",!,"that these new values are properly stored.  If you fail to do so, i.e.,"
    13         W !,"enter an up-arrow, the new values will not be stored as part of this billing",!,"record." Q
    14 3       I '$D(IBIFN),$D(DA) S IBIFN=DA
    15         W !,"If a procedure is linked as a prescription to a rev code, it cannot be deleted",!
    16         W:$P(^DGCR(399,IBIFN,0),"^",5)<3 !!?4," - Enter the alphanumeric designation of your choice from",!?7,"the display (e.g. 'A1') to input one of the codes shown",!?7,"above into this billing record."
    17         I $P(^IBE(350.9,1,1),U,15)'=1 G 4
    18         S DGCODMET=$P(^DGCR(399,IBIFN,0),"^",9),DGCODMET=$S(DGCODMET=9:"ICD",DGCODMET="":"",1:"CPT")
    19         W !!?4," - Enter the name or code number of an ",$S($D(IBPY):"ICD DIAGNOSIS ",1:DGCODMET_" PROCEDURE "),"CODE",!?7,"not displayed above to input a ",$S($D(IBPY):"DIAGNOSIS",1:"PROCEDURE")," code"
    20         I $P(^DGCR(399,IBIFN,0),"^",5)>2 W "." G 4
    21         W " not found",!?7,"in the PTF record into this billing record, or '??' for ",!?7,"a list of all ",$S($D(IBPY):"ICD DIAGNOSIS ",1:DGCODMET_" PROCEDURE "),"CODES."
    22 4       W !!?4," - Enter <RETURN> to accept the default ",$S($D(IBPY):"DIAGNOSIS ",1:"PROCEDURE "),"code, or",!?7,"'^' to abort.",!!
    23         K DGCODMET
    24         Q
    25         ;
    26 DISPPRC(IBIFN)  ; display procedures
    27         N IBHDR,IBHDR1,IBD,IBN,IBI,IBX,IBQ,IBLN,IBPR,IBPRD,IBDT,IBDV,IBCL,IBPV,IBLC,PRCARR,IBMOD,IBSUS,IBDATE
    28         S IBQ=0
    29         ;
    30         I '$O(^DGCR(399,+$G(IBIFN),"CP",0)) W !!?5,"No Codes Entered!",! D PAUSE^VALM1 Q
    31         ;
    32         S IBDATE=$$BDATE^IBACSV(IBIFN)
    33         S IBHDR="W @IOF,!,""Procedures Assigned to this Bill"",!,""Code"",?10,""Procedure"",?35,""PO"",?38,""Date"",?48,""Div"",?55,""Clinic"",?68,""Provider"" X IBHDR1"
    34         S IBHDR1="W !,""--------------------------------------------------------------------------------"" S IBLC=2"
    35         ;
    36         X IBHDR D PRCDT^IBCU71(+IBIFN,.PRCARR)
    37         S IBD="" F  S IBD=$O(PRCARR(IBD)) Q:IBD=""  D  Q:IBQ
    38         . S IBN="" F  S IBN=$O(PRCARR(IBD,IBN)) Q:IBN=""  D  Q:IBQ
    39         .. S IBI=0 F  S IBI=$O(PRCARR(IBD,IBN,IBI)) Q:'IBI  D  I IBLC>19 S IBQ=$$PAUSE(IBLC) Q:IBQ  X IBHDR
    40         ... S IBLN=$G(PRCARR(IBD,IBN,IBI)),(IBPR,IBPRD,IBDT,IBDV,IBCL,IBPV,IBSUS)="",IBLC=IBLC+1
    41         ... S IBX=$$PRCNM($P(IBLN,U,1),IBD),IBPR=$P(IBX,U,1),IBPRD=$P(IBX,U,2)
    42         ... S IBDT=$P(IBLN,U,2),IBDT=$E(IBDT,4,5)_"/"_$E(IBDT,6,7)_"/"_$E(IBDT,2,3)
    43         ... I +$P(IBLN,U,6) S IBDV=$P($G(^DG(40.8,+$P(IBLN,U,6),0)),U,2)
    44         ... I +$P(IBLN,U,7) S IBCL=$P($G(^SC(+$P(IBLN,U,7),0)),U,1)
    45         ... I +$P(IBLN,U,18) S IBPV=$P($G(^VA(200,+$P(IBLN,U,18),0)),U,1)
    46         ... I +$P(IBLN,U,16) S IBSUS=$P(IBLN,U,16)_"mn"
    47         ... I +$P(IBLN,U,21) S IBSUS=$P(IBLN,U,21)_"ml"
    48         ... I +$P(IBLN,U,22) S IBSUS=$P(IBLN,U,22)_"hr"
    49         ... ;
    50         ... W !,$E(IBPR,1,6),?7,$E(IBPRD,1,20),?29,IBSUS,?35,$P(IBLN,U,4),?38,IBDT,?48,IBDV,?55,$E(IBCL,1,11),?68,$E(IBPV,1,12)
    51         ... S IBX=$$MODLST^IBEFUNC2($$GETMOD^IBEFUNC(IBIFN,IBI),1,.IBX,IBD)
    52         ... I IBX'="" F IBMOD=1:1:$L(IBX,",") W !,?10,$P(IBX,",",IBMOD),?15,$P($G(IBX(1)),",",IBMOD) S IBLC=IBLC+1
    53         I 'IBI,'IBQ S IBQ=$$PAUSE(IBLC)
    54         Q
    55         ;
    56 PRCNM(PRC,EFDT) ; return procedure name, input first piece of CP node -
    57         ;                                        (in variable pointer format)
    58         ; output: code ^ name
    59         N IBNM
    60         S IBNM=$$PRCD^IBCEF1($G(PRC),1,$G(EFDT))
    61         I $TR(IBNM,U)="" D
    62         . S IBNM="NO ENTRY FOUND^"
    63         E  D
    64         . S IBNM=$P(IBNM,U,2,3)
    65         Q IBNM
    66         ;
    67 PAUSE(CNT)      ;
    68         N IBI F IBI=CNT:1:20 W !
    69         N DIR,DUOUT,DTOUT,DIRUT,IBX,X,Y S IBX=0,DIR(0)="E" D ^DIR K DIR I $D(DIRUT) S IBX=1
    70         Q IBX
    71         ;
    72 DISPRX(IBIFN)   ; display prescriptions
    73         N IBHDR,IBHDR1,IBX,IBZ,IBRXL,IBNPI,IBRX,IBQ,IBORG
    74         S IBQ=0
    75         ;
    76         I '$O(^IBA(362.4,"AIFN"_IBIFN,0)) W !!?5,"No Prescriptions Entered!",! D PAUSE^VALM1 Q
    77         ;
    78         ; get NPIs
    79         S IBX=$$RXSITE^IBCEF73A(IBIFN,.IBRXL)
    80         ;
    81         S IBHDR="W @IOF,!,""Prescriptions Assigned to this Bill"" X IBHDR1"
    82         S IBHDR1="W !,""--------------------------------------------------------------------------------"" "
    83         ;
    84         X IBHDR
    85         S IBRX=0 F  S IBRX=$O(^IBA(362.4,"AIFN"_IBIFN,IBRX)) Q:'IBRX!(IBQ)  S IBX=0 F  S IBX=$O(^IBA(362.4,"AIFN"_IBIFN,IBRX,IBX)) Q:'IBX!(IBQ)  D
    86         . S IBZ=$G(^IBA(362.4,IBX,0))
    87         . W !?5,"RX #: ",$P(IBZ,"^")
    88         . W ?50,"DATE: ",$$FMTE^XLFDT($P(IBZ,"^",3))
    89         . W !?5,"DRUG: ",$$EXTERNAL^DILFD(362.4,.04,"",$P(IBZ,"^",4))
    90         . W ?50,"NDC: ",$P(IBZ,"^",8)
    91         . W !?5,"DAYS SUPPLY: ",$P(IBZ,"^",6)
    92         . W ?50,"QUANTITY: ",$P(IBZ,"^",7)
    93         . S IBORG=$G(IBRXL(+$P(IBZ,"^",5),+$P(IBZ,"^",3)))
    94         . ; ia #4532
    95         . S IBNPI=$S(IBORG:$P($$NPI^XUSNPI("Organization_ID",IBORG),U),1:"")
    96         . W !?5,"NPI INSTITUTION: ",$S(IBORG:$$EXTERNAL^DILFD(350.9,.02,"",IBORG),1:"")
    97         . W ?50,"RX NPI: ",$S(IBNPI>0:IBNPI,1:"")
    98         . W !?5,"PROVIDER: ",$S($P(IBZ,"^",5):$$RXAPI1^IBNCPUT1($P(IBZ,"^",5),4),1:""),!
    99         . I $Y+7>IOSL S IBQ=$$PAUSE(0)
    100         D PAUSE^VALM1
    101         ;
    102         Q
    103         ;
     1IBCSCH1 ;ALB/MRL - BILLING HELPS (CONTINUED) ; 01 JUN 88 12:00
     2 ;;2.0;INTEGRATED BILLING;**106,125,51,245,266**;21-MAR-94
     3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
     4 ;
     5 ;MAP TO DGCRSCH1
     6 ;
     71 W !!,"DO YOU WISH TO ADD/EDIT INSURANCE COMPANY DATA FOR THIS PATIENT" S %=2 D YN^DICN S IBADI=$S(%=1!(%=-1):%,1:0)
     8 I '% W !!?4,"YES - And I'll prompt you so that you may add insurance data to the PATIENT",!?9,"file for this patient.",!?4,"NO  - To bypass this editing of the PATIENT file." G 1
     9 Q
     10 ;
     112 W !!,"If you updated insurance information for any policy which is already specified",!,"as either a PRIMARY, SECONDARY or TERIARY for this billing episode, you will"
     12 W !,"need to press the <RETURN> key through the following prompts in order to insure",!,"that these new values are properly stored.  If you fail to do so, i.e.,"
     13 W !,"enter an up-arrow, the new values will not be stored as part of this billing",!,"record." Q
     143 I '$D(IBIFN),$D(DA) S IBIFN=DA
     15 W !,"If a procedure is linked as a prescription to a rev code, it cannot be deleted",!
     16 W:$P(^DGCR(399,IBIFN,0),"^",5)<3 !!?4," - Enter the alphanumeric designation of your choice from",!?7,"the display (e.g. 'A1') to input one of the codes shown",!?7,"above into this billing record."
     17 I $P(^IBE(350.9,1,1),U,15)'=1 G 4
     18 S DGCODMET=$P(^DGCR(399,IBIFN,0),"^",9),DGCODMET=$S(DGCODMET=9:"ICD",DGCODMET="":"",1:"CPT")
     19 W !!?4," - Enter the name or code number of an ",$S($D(IBPY):"ICD DIAGNOSIS ",1:DGCODMET_" PROCEDURE "),"CODE",!?7,"not displayed above to input a ",$S($D(IBPY):"DIAGNOSIS",1:"PROCEDURE")," code"
     20 I $P(^DGCR(399,IBIFN,0),"^",5)>2 W "." G 4
     21 W " not found",!?7,"in the PTF record into this billing record, or '??' for ",!?7,"a list of all ",$S($D(IBPY):"ICD DIAGNOSIS ",1:DGCODMET_" PROCEDURE "),"CODES."
     224 W !!?4," - Enter <RETURN> to accept the default ",$S($D(IBPY):"DIAGNOSIS ",1:"PROCEDURE "),"code, or",!?7,"'^' to abort.",!!
     23 K DGCODMET
     24 Q
     25 ;
     26DISPPRC(IBIFN) ; display procedures
     27 N IBHDR,IBHDR1,IBD,IBN,IBI,IBX,IBQ,IBLN,IBPR,IBPRD,IBDT,IBDV,IBCL,IBPV,IBLC,PRCARR,IBMOD,IBSUS,IBDATE
     28 S IBQ=0
     29 ;
     30 I '$O(^DGCR(399,+$G(IBIFN),"CP",0)) W !!?5,"No Codes Entered!",! D PAUSE^VALM1 Q
     31 ;
     32 S IBDATE=$$BDATE^IBACSV(IBIFN)
     33 S IBHDR="W @IOF,!,""Procedures Assigned to this Bill"",!,""Code"",?10,""Procedure"",?35,""PO"",?38,""Date"",?48,""Div"",?55,""Clinic"",?68,""Provider"" X IBHDR1"
     34 S IBHDR1="W !,""--------------------------------------------------------------------------------"" S IBLC=2"
     35 ;
     36 X IBHDR D PRCDT^IBCU71(+IBIFN,.PRCARR)
     37 S IBD="" F  S IBD=$O(PRCARR(IBD)) Q:IBD=""  D  Q:IBQ
     38 . S IBN="" F  S IBN=$O(PRCARR(IBD,IBN)) Q:IBN=""  D  Q:IBQ
     39 .. S IBI=0 F  S IBI=$O(PRCARR(IBD,IBN,IBI)) Q:'IBI  D  I IBLC>19 S IBQ=$$PAUSE(IBLC) Q:IBQ  X IBHDR
     40 ... S IBLN=$G(PRCARR(IBD,IBN,IBI)),(IBPR,IBPRD,IBDT,IBDV,IBCL,IBPV,IBSUS)="",IBLC=IBLC+1
     41 ... S IBX=$$PRCNM($P(IBLN,U,1),IBD),IBPR=$P(IBX,U,1),IBPRD=$P(IBX,U,2)
     42 ... S IBDT=$P(IBLN,U,2),IBDT=$E(IBDT,4,5)_"/"_$E(IBDT,6,7)_"/"_$E(IBDT,2,3)
     43 ... I +$P(IBLN,U,6) S IBDV=$P($G(^DG(40.8,+$P(IBLN,U,6),0)),U,2)
     44 ... I +$P(IBLN,U,7) S IBCL=$P($G(^SC(+$P(IBLN,U,7),0)),U,1)
     45 ... I +$P(IBLN,U,18) S IBPV=$P($G(^VA(200,+$P(IBLN,U,18),0)),U,1)
     46 ... I +$P(IBLN,U,16) S IBSUS=$P(IBLN,U,16)_"mn"
     47 ... I +$P(IBLN,U,21) S IBSUS=$P(IBLN,U,21)_"ml"
     48 ... I +$P(IBLN,U,22) S IBSUS=$P(IBLN,U,22)_"hr"
     49 ... ;
     50 ... W !,$E(IBPR,1,6),?7,$E(IBPRD,1,20),?29,IBSUS,?35,$P(IBLN,U,4),?38,IBDT,?48,IBDV,?55,$E(IBCL,1,11),?68,$E(IBPV,1,12)
     51 ... S IBX=$$MODLST^IBEFUNC2($$GETMOD^IBEFUNC(IBIFN,IBI),1,.IBX,IBD)
     52 ... I IBX'="" F IBMOD=1:1:$L(IBX,",") W !,?10,$P(IBX,",",IBMOD),?15,$P($G(IBX(1)),",",IBMOD) S IBLC=IBLC+1
     53 I 'IBI,'IBQ S IBQ=$$PAUSE(IBLC)
     54 Q
     55 ;
     56PRCNM(PRC,EFDT) ; return procedure name, input first piece of CP node -
     57 ;                                        (in variable pointer format)
     58 ; output: code ^ name
     59 N IBNM
     60 S IBNM=$$PRCD^IBCEF1($G(PRC),1,$G(EFDT))
     61 I $TR(IBNM,U)="" D
     62 . S IBNM="NO ENTRY FOUND^"
     63 E  D
     64 . S IBNM=$P(IBNM,U,2,3)
     65 Q IBNM
     66 ;
     67PAUSE(CNT) ;
     68 N IBI F IBI=CNT:1:20 W !
     69 N DIR,DUOUT,DTOUT,DIRUT,IBX,X,Y S IBX=0,DIR(0)="E" D ^DIR K DIR I $D(DIRUT) S IBX=1
     70 Q IBX

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCU4.m

    r613 r623  
    1 IBCU4   ;ALB/AAS - BILLING UTILITY ROUTINE (CONTINUED) ;12-FEB-90
    2         ;;2.0;INTEGRATED BILLING;**109,122,137,245,349,371**;21-MAR-94;Build 57
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5         ;MAP TO DGCRU4
    6         ;
    7 DDAT    ;Input transform for Statement Covers From field
    8         I '$D(DA) G TO
    9         S IB00=+$P(^DGCR(399,+DA,0),"^",3) I +X<$P(IB00,".",1) W !?4,"Cannot precede the 'EVENT DATE'!",*7 K X G DDAT4
    10         I +X>(DT_".2359") W !?4,"Cannot bill for future treatment!",*7 K X G DDAT4
    11         D PROCDT
    12         I DGPRDTB,X>DGPRDTB K X W !?4,"Can't be greater than date of specified Procedures!",*7 G DDAT4
    13         G DDAT4
    14 DDAT1   ;Input transform for Statement covers to
    15         I '$D(DA) G FROM
    16         S IB00=$S($D(^DGCR(399,+DA,"U")):$P(^("U"),"^",1),1:"") I 'IB00 W !?4,"'Start Date' must be specified first!",*7 K X G DDAT4
    17         I +X>DT W !?4,"Cannot bill for future treatment!",*7 K X G DDAT4
    18         I +X<IB00 W !?4,"Cannot preceed the 'Start Date'!",*7 K X G DDAT4
    19         ;I $S($E(IB00,4,5)<10:$E(IB00,2,3),1:$E(IB00,2,3)+1)'=$S($E(X,4,5)<10:$E(X,2,3),1:$E(X,2,3)+1) K X W !?4,"Must be in same fiscal year!",*7 G DDAT4
    20         ;I $$FY(+IB00)'=$$FY(X) K X W !?4,"Must be in same fiscal year!",*7 G DDAT4
    21         ;I $E(IB00,1,3)'=$E(X,1,3) K X W !?4,"Must be in same calendar year!",*7 G DDAT4
    22         D PROCDT
    23         I DGPRDTE,X<DGPRDTE K X W !?4,"Can't be less than date of specified Procedures!",*7 G DDAT4
    24         G DDAT4
    25         ;
    26         ;DDAT2   ;Input transform for OP VISITS DATE(S) field  REPLACED WITH IBCU41 6/15/93
    27         ;S IB00=$G(^DGCR(399,IBIFN,"U")) I $P(IB00,"^",1)']"" W !?4,*7,"No 'Start Date' on file...can't enter OP visit dates..." K X G DDAT4
    28         ;I $P(IB00,"^",2)']"" W !?4,*7,"No 'End Date' on file...can't enter OP visit dates..." K X G DDAT4
    29         ;I X<$P(IB00,"^",1) W !?4,*7,"Can't enter a visit date prior to 'Start Date'..." K X G DDAT4
    30         ;I X>$P(IB00,"^",2) W !?4,*7,"Can't enter a visit date later than 'End Date'..." K X G DDAT4
    31         ;I $P(^DGCR(399,IBIFN,0),"^",19)'=2,$D(^DGCR(399,"ASC2",IBIFN)),$O(^DGCR(399,IBIFN,"OP",0)) W !?4,*7,"Only 1 visit date allowed on bills with Amb. Surg. Codes!" K X G DDAT4
    32         ;D APPT^IBCU3,DUPCHK^IBCU3
    33         G DDAT4
    34         ;
    35 DDAT3   ; - x-ref call for to and from dates, REPLACED BY TRIGGERS ON .08, 151, 152 ON 10/18/93
    36         ;if inpatient bill return DGNEWLOS to cause recalc of los in IBSC6
    37         G DDAT4:'$D(X)
    38         I $D(^DGCR(399,DA,0)),$P(^(0),"^",5)<3 S DGNEWLOS=1
    39         S IB00=$S($D(^DGCR(399,+DA,"U")):^("U"),1:"") I IB00']"" K X G DDAT4
    40         S IB02=$S(+$E(IB00,4,5)<10:$E(IB00,2,3),1:$E(IB00,2,3)+1),IB01=$E(IB00,1)_IB02_"0930",$P(^DGCR(399,DA,"U1"),"^",9)=IB02 ;,$P(^DGCR(399,DA,"U1"),"^",11)=$S($P(IB00,"^",2)>IB01:IB02+1,1:"")
    41         ;I $P(^DGCR(399,DA,"U1"),"^",11)="" S $P(^("U1"),"^",12)=""
    42         ;
    43 DDAT4   K IB00,IB01,IB02,IB03,DGX,DGNOAP,DGJ,DGPROC,DGPRDT,DGPRDTE,DGPRDTB Q
    44         ;
    45 OTDAT   ; Input transform for Other Care Start Date (399,48,.02)
    46         I ('$G(DA(1)))!('$G(X)) Q
    47         N IBX S IBX=$G(^DGCR(399,DA(1),"U"))
    48         I +X<+IBX W !,?4,"Can Not Precede Bill Start Date!",!,*7 K X Q
    49         I +X>+$P(IBX,U,2) W !,?4,"Can not be after Bill End Date!",!,*7 K X Q
    50         Q
    51         ;
    52 CHDAT   ; Input transform for chiropractics-related dates (399/245,246,247)
    53         ; Make sure that date entered is not after end date of the bill
    54         Q:'$D(X)
    55         N IBX,Y
    56         S IBX=$P($G(^DGCR(399,+DA,"U")),U,2)
    57         I IBX="" W !?4,*7,"No end date of the bill on file - can't enter chiropractics-related dates " K X Q
    58         I X>+IBX S Y=IBX D DD^%DT W !,?4,*7,"This date can not be after the end date of the claim ("_Y_") " K X Q
    59         Q
    60         ;
    61 TO      ;151 pseudo input x-form
    62         I +X_.9<IBIDS(.03) W !?4,"Cannot precede the 'EVENT DATE'!",*7 K X Q
    63         I +X>(DT_".2359") W !?4,"Cannot bill for future treatment!",*7 K X
    64         Q
    65 FROM    ;152 pseudo input x-form
    66         I '$D(IBIDS(151)) W !?4,"'Start Date' must be specified first!",*7 K X Q
    67         I +X<IBIDS(151) W !?4,"Cannot preceed the 'Start Date'!",*7 K X Q
    68         ;I $S($E(IBIDS(151),4,5)<10:$E(IBIDS(151),2,3),1:$E(IBIDS(151),2,3)+1)'=$S($E(X,4,5)<10:$E(X,2,3),1:$E(X,2,3)+1) K X W !?4,"Must be in same fiscal year!",*7 Q
    69         ;I $$FY(IBIDS(151))'=$$FY(X) K X W !?4,"Must be in same fiscal year!",*7 Q
    70         ;I $E(IBIDS(151),1,3)'=$E(X,1,3) K X W !?4,"Must be in same calendar year!",*7 Q
    71         Q
    72         ;
    73 FY(DATE)        ; return a dates Fiscal Year
    74         N IBYR,IBFY S IBFY=""
    75         I $G(DATE)?7N.E S IBYR=$S($E(DATE,4,5)<10:$E(DATE,1,3),1:$E(DATE,1,3)+1),IBFY=$E(IBYR,2,3)
    76         Q IBFY
    77         ;
    78 SPEC    ;  - calculate discharge specialty
    79         ;  - input  IBids(.08) = ptf record number
    80         ;  - output IBids(161) = pointer to billing specialty in 399.1
    81         K IBIDS(161)
    82         Q:$S('$D(IBIDS(.08)):1,'$D(^DGPT(+IBIDS(.08),70)):1,'$P(^(70),"^",2):1,'$D(^DIC(42.4,+$P(^(70),"^",2),0)):1,1:0)  S IBIDS(161)=$P(^DGPT(IBIDS(.08),70),"^",2)
    83         S IBIDS(161)=$P($G(^DIC(42.4,+IBIDS(161),0)),"^",5) I IBIDS(161)="" K IBIDS(161) Q
    84         S IBIDS(161)=$O(^DGCR(399.1,"B",IBIDS(161),0))
    85         I '$D(^DGCR(399.1,+IBIDS(161),0)) K IBIDS(161)
    86         Q
    87         ;
    88 PROCDT  ;  - find first and last dates of procedures
    89         ;    can't set from and to date inside of this range
    90         S (DGPRDT,DGPROC,DGPRDTE,DGPRDTB)=0
    91         F  S DGPROC=$O(^DGCR(399,+DA,"CP",DGPROC)) Q:'DGPROC  S DGPRDT=$P($G(^DGCR(399,+DA,"CP",DGPROC,0)),"^",2) D
    92         . I DGPRDTB=0!(DGPRDTB>DGPRDT) S DGPRDTB=DGPRDT
    93         . I DGPRDTE=0!(DGPRDTE<DGPRDT) S DGPRDTE=DGPRDT
    94         . Q
    95         Q
    96         ;
    97 TOBIN(Y,DA)     ; Screen for UB-04 bill classification based on UB-04 location of care
    98         ; Y = internal value of code for field .25 (UB-04 BILL CLASSIFICATION)
    99         ; DA = bill ien in file 399
    100         N IB0
    101         S IB0=$P($G(^DGCR(399,DA,0)),U,24) ; Get UB-04 LOCATION OF CARE value
    102         Q $S('IB0:0,(","_$P($G(^DGCR(399.1,+Y,0)),U,24)_",")'[(","_IB0_","):0,1:1)
    103         ;
    104 TRIG05(X,D0)    ; Trigger executed on field .05 of file 399 to set field .25
    105         ; Find the correct entry in file 399.1 that corresponds to the value in .05
    106         ; X = value of field .05, location of care
    107         ; D0 = IEN of bill entry in file 399
    108         N Z,Z0,IEN,LOC
    109         S LOC=$P($G(^DGCR(399,D0,0)),U,4)
    110         S IEN="",Z=0
    111         I LOC'="" F  S Z=$O(^DGCR(399.1,"C",X,Z)) Q:'Z  S Z0=$P($G(^DGCR(399.1,Z,0)),U,23,24) I +Z0,(","_$P(Z0,U,2)_",")[(","_LOC_",") S IEN=Z Q
    112         Q IEN
    113         ;
    114 TOB(IBIFN,POS)  ;Function returns the 3 digit type of bill from UB-04
    115         ;  fields or the position (1-3) as determined by POS (optional)
    116         N Z
    117         S Z=$P($G(^DGCR(399,IBIFN,0)),U,24,26),Z=$P(Z,U)_$P($G(^DGCR(399.1,+$P(Z,U,2),0)),U,2)_$P(Z,U,3)
    118         Q $S('$G(POS):Z,1:$E(Z,+POS))
    119         ;
     1IBCU4 ;ALB/AAS - BILLING UTILITY ROUTINE (CONTINUED) ; 12-FEB-90
     2 ;;2.0;INTEGRATED BILLING;**109,122,137,245,349**;21-MAR-94;Build 46
     3 ;;Per VHA Directive 2004-038, this routine should not be modified.
     4 ;
     5 ;MAP TO DGCRU4
     6 ;
     7DDAT ;Input transform for Statement Covers From field
     8 I '$D(DA) G TO
     9 S IB00=+$P(^DGCR(399,+DA,0),"^",3) I +X<$P(IB00,".",1) W !?4,"Cannot precede the 'EVENT DATE'!",*7 K X G DDAT4
     10 I +X>(DT_".2359") W !?4,"Cannot bill for future treatment!",*7 K X G DDAT4
     11 D PROCDT
     12 I DGPRDTB,X>DGPRDTB K X W !?4,"Can't be greater than date of specified Procedures!",*7 G DDAT4
     13 G DDAT4
     14DDAT1 ;Input transform for Statement covers to
     15 I '$D(DA) G FROM
     16 S IB00=$S($D(^DGCR(399,+DA,"U")):$P(^("U"),"^",1),1:"") I 'IB00 W !?4,"'Start Date' must be specified first!",*7 K X G DDAT4
     17 I +X>DT W !?4,"Cannot bill for future treatment!",*7 K X G DDAT4
     18 I +X<IB00 W !?4,"Cannot preceed the 'Start Date'!",*7 K X G DDAT4
     19 ;I $S($E(IB00,4,5)<10:$E(IB00,2,3),1:$E(IB00,2,3)+1)'=$S($E(X,4,5)<10:$E(X,2,3),1:$E(X,2,3)+1) K X W !?4,"Must be in same fiscal year!",*7 G DDAT4
     20 ;I $$FY(+IB00)'=$$FY(X) K X W !?4,"Must be in same fiscal year!",*7 G DDAT4
     21 ;I $E(IB00,1,3)'=$E(X,1,3) K X W !?4,"Must be in same calendar year!",*7 G DDAT4
     22 D PROCDT
     23 I DGPRDTE,X<DGPRDTE K X W !?4,"Can't be less than date of specified Procedures!",*7 G DDAT4
     24 G DDAT4
     25 ;
     26 ;DDAT2   ;Input transform for OP VISITS DATE(S) field  REPLACED WITH IBCU41 6/15/93
     27 ;S IB00=$G(^DGCR(399,IBIFN,"U")) I $P(IB00,"^",1)']"" W !?4,*7,"No 'Start Date' on file...can't enter OP visit dates..." K X G DDAT4
     28 ;I $P(IB00,"^",2)']"" W !?4,*7,"No 'End Date' on file...can't enter OP visit dates..." K X G DDAT4
     29 ;I X<$P(IB00,"^",1) W !?4,*7,"Can't enter a visit date prior to 'Start Date'..." K X G DDAT4
     30 ;I X>$P(IB00,"^",2) W !?4,*7,"Can't enter a visit date later than 'End Date'..." K X G DDAT4
     31 ;I $P(^DGCR(399,IBIFN,0),"^",19)'=2,$D(^DGCR(399,"ASC2",IBIFN)),$O(^DGCR(399,IBIFN,"OP",0)) W !?4,*7,"Only 1 visit date allowed on bills with Amb. Surg. Codes!" K X G DDAT4
     32 ;D APPT^IBCU3,DUPCHK^IBCU3
     33 G DDAT4
     34 ;
     35DDAT3 ; - x-ref call for to and from dates, REPLACED BY TRIGGERS ON .08, 151, 152 ON 10/18/93
     36 ;if inpatient bill return DGNEWLOS to cause recalc of los in IBSC6
     37 G DDAT4:'$D(X)
     38 I $D(^DGCR(399,DA,0)),$P(^(0),"^",5)<3 S DGNEWLOS=1
     39 S IB00=$S($D(^DGCR(399,+DA,"U")):^("U"),1:"") I IB00']"" K X G DDAT4
     40 S IB02=$S(+$E(IB00,4,5)<10:$E(IB00,2,3),1:$E(IB00,2,3)+1),IB01=$E(IB00,1)_IB02_"0930",$P(^DGCR(399,DA,"U1"),"^",9)=IB02 ;,$P(^DGCR(399,DA,"U1"),"^",11)=$S($P(IB00,"^",2)>IB01:IB02+1,1:"")
     41 ;I $P(^DGCR(399,DA,"U1"),"^",11)="" S $P(^("U1"),"^",12)=""
     42 ;
     43DDAT4 K IB00,IB01,IB02,IB03,DGX,DGNOAP,DGJ,DGPROC,DGPRDT,DGPRDTE,DGPRDTB Q
     44 ;
     45OTDAT ; Input transform for Other Care Start Date (399,48,.02)
     46 I ('$G(DA(1)))!('$G(X)) Q
     47 N IBX S IBX=$G(^DGCR(399,DA(1),"U"))
     48 I +X<+IBX W !,?4,"Can Not Precede Bill Start Date!",!,*7 K X Q
     49 I +X>+$P(IBX,U,2) W !,?4,"Can not be after Bill End Date!",!,*7 K X Q
     50 Q
     51 ;
     52 ;
     53 ;
     54TO ;151 pseudo input x-form
     55 I +X_.9<IBIDS(.03) W !?4,"Cannot precede the 'EVENT DATE'!",*7 K X Q
     56 I +X>(DT_".2359") W !?4,"Cannot bill for future treatment!",*7 K X
     57 Q
     58FROM ;152 pseudo input x-form
     59 I '$D(IBIDS(151)) W !?4,"'Start Date' must be specified first!",*7 K X Q
     60 I +X<IBIDS(151) W !?4,"Cannot preceed the 'Start Date'!",*7 K X Q
     61 ;I $S($E(IBIDS(151),4,5)<10:$E(IBIDS(151),2,3),1:$E(IBIDS(151),2,3)+1)'=$S($E(X,4,5)<10:$E(X,2,3),1:$E(X,2,3)+1) K X W !?4,"Must be in same fiscal year!",*7 Q
     62 ;I $$FY(IBIDS(151))'=$$FY(X) K X W !?4,"Must be in same fiscal year!",*7 Q
     63 ;I $E(IBIDS(151),1,3)'=$E(X,1,3) K X W !?4,"Must be in same calendar year!",*7 Q
     64 Q
     65 ;
     66FY(DATE) ; return a dates Fiscal Year
     67 N IBYR,IBFY S IBFY=""
     68 I $G(DATE)?7N.E S IBYR=$S($E(DATE,4,5)<10:$E(DATE,1,3),1:$E(DATE,1,3)+1),IBFY=$E(IBYR,2,3)
     69 Q IBFY
     70 ;
     71SPEC ;  - calculate discharge specialty
     72 ;  - input  IBids(.08) = ptf record number
     73 ;  - output IBids(161) = pointer to billing specialty in 399.1
     74 K IBIDS(161)
     75 Q:$S('$D(IBIDS(.08)):1,'$D(^DGPT(+IBIDS(.08),70)):1,'$P(^(70),"^",2):1,'$D(^DIC(42.4,+$P(^(70),"^",2),0)):1,1:0)  S IBIDS(161)=$P(^DGPT(IBIDS(.08),70),"^",2)
     76 S IBIDS(161)=$P($G(^DIC(42.4,+IBIDS(161),0)),"^",5) I IBIDS(161)="" K IBIDS(161) Q
     77 S IBIDS(161)=$O(^DGCR(399.1,"B",IBIDS(161),0))
     78 I '$D(^DGCR(399.1,+IBIDS(161),0)) K IBIDS(161)
     79 Q
     80 ;
     81PROCDT ;  - find first and last dates of procedures
     82 ;    can't set from and to date inside of this range
     83 S (DGPRDT,DGPROC,DGPRDTE,DGPRDTB)=0
     84 F  S DGPROC=$O(^DGCR(399,+DA,"CP",DGPROC)) Q:'DGPROC  S DGPRDT=$P($G(^DGCR(399,+DA,"CP",DGPROC,0)),"^",2) D
     85 . I DGPRDTB=0!(DGPRDTB>DGPRDT) S DGPRDTB=DGPRDT
     86 . I DGPRDTE=0!(DGPRDTE<DGPRDT) S DGPRDTE=DGPRDT
     87 . Q
     88 Q
     89 ;
     90TOBIN(Y,DA) ; Screen for UB-04 bill classification based on UB-04 location of care
     91 ; Y = internal value of code for field .25 (UB-04 BILL CLASSIFICATION)
     92 ; DA = bill ien in file 399
     93 N IB0
     94 S IB0=$P($G(^DGCR(399,DA,0)),U,24) ; Get UB-04 LOCATION OF CARE value
     95 Q $S('IB0:0,(","_$P($G(^DGCR(399.1,+Y,0)),U,24)_",")'[(","_IB0_","):0,1:1)
     96 ;
     97TRIG05(X,D0) ; Trigger executed on field .05 of file 399 to set field .25
     98 ; Find the correct entry in file 399.1 that corresponds to the value in .05
     99 ; X = value of field .05, location of care
     100 ; D0 = IEN of bill entry in file 399
     101 N Z,Z0,IEN,LOC
     102 S LOC=$P($G(^DGCR(399,D0,0)),U,4)
     103 S IEN="",Z=0
     104 I LOC'="" F  S Z=$O(^DGCR(399.1,"C",X,Z)) Q:'Z  S Z0=$P($G(^DGCR(399.1,Z,0)),U,23,24) I +Z0,(","_$P(Z0,U,2)_",")[(","_LOC_",") S IEN=Z Q
     105 Q IEN
     106 ;
     107TOB(IBIFN,POS) ;Function returns the 3 digit type of bill from UB-04
     108 ;  fields or the position (1-3) as determined by POS (optional)
     109 N Z
     110 S Z=$P($G(^DGCR(399,IBIFN,0)),U,24,26),Z=$P(Z,U)_$P($G(^DGCR(399.1,+$P(Z,U,2),0)),U,2)_$P(Z,U,3)
     111 Q $S('$G(POS):Z,1:$E(Z,+POS))
     112 ;

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCU7.m

    r613 r623  
    1 IBCU7   ;ALB/AAS - INTERCEPT SCREEN INPUT OF PROCEDURE CODES ;29-OCT-91
    2         ;;2.0;INTEGRATED BILLING;**62,52,106,125,51,137,210,245,228,260,348,371**;21-MAR-94;Build 57
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5         ;MAP TO DGCRU7
    6         ;
    7 CHKX    ;  -interception of input x from Additional Procedure input
    8         G:X=" " CHKXQ
    9         I $$INPAT^IBCEF(DA(1)),'$P($G(^IBE(350.9,1,1)),"^",15),X'?1A1N D  G CHKXQ
    10         . K X
    11         . D EN^DDIOL("Site param does not allow entry of non-PTF procedures") ;Fileman error here will be: The previous error occurred when performing an action specified in a Pre-lookup transform (7.5 node).
    12         G:'$D(^UTILITY($J,"IB")) CHKXQ
    13         S M=($A($E(X,1))-64),S=+$E(X,2) Q:'$G(^UTILITY($J,"IB",M,S))  S X="`"_+^(S)
    14         I $D(DGPROCDT),DGPROCDT'=$P($G(^UTILITY($J,"IB",M,1)),"^",2) S DGPROCDT=$P(^(1),"^",2) W !!,"Procedure Date: " S Y=DGPROCDT X ^DD("DD") W Y,!
    15 CHKXQ   Q
    16         ;
    17 CODMUL  ;Date oriented entry of procedure
    18 DELASK  I $D(IBZ20),IBZ20,IBZ20'=$P(^DGCR(399,IBIFN,0),U,9) S %=2 W !,"SINCE THE PROCEDURE CODING METHOD HAS BEEN CHANGED, DO YOU WANT TO DELETE ALL",!,"PROCEDURE CODES IN THIS BILL"
    19         I  D YN^DICN Q:%=-1  D:%=1 DELADD I %Y?1."?" W !!,"If you answer 'Yes', all procedure codes will be DELETED from this bill.",! G DELASK
    20         K %,%Y,DA,IBZ20,DIK ;W !,"Procedure Entry:"
    21         ;
    22 CODDT   I $D(IBIFN),$D(^DGCR(399,IBIFN,0)),$P(^(0),U,9) S DIC("V")=$S($P(^(0),U,9)=9:"I +Y(0)=80.1",$P(^(0),U,9)=4!($P(^(0),U,9)=5):"I +Y(0)=81",1:"")
    23         I $P($G(^DGCR(399,IBIFN,0)),"^",5)<3 S IBZTYPE=1 I $P($G(^UTILITY($J,"IB",1,1)),"^",2) S DGPROCDT=$P(^(1),"^",2) D ASKCOD
    24         S X=$$PRCDIV^IBCU71(IBIFN) I +X W !!,$P(X,U,2),!
    25         N Z,Z0 S Z=$G(^DGCR(399,IBIFN,"U")),Z0=$$FMTE^XLFDT($P(Z,U),"2D")_"-"_$$FMTE^XLFDT($P(Z,U,2),"2D")
    26         W !,"Select PROCEDURE DATE"_$S($TR(Z0,"-")'="":" ("_Z0_")",1:"")_": " R X:DTIME G:'$T!("^"[X) CODQ D:X["?" CODHLP
    27         S IBEX=0 D  ; Get procedure date
    28         . I X=" ",$D(DGPROCDT),DGPROCDT?7N S Y=DGPROCDT D D^DIQ W "   (",Y,")" Q
    29         . I X=" ",+$P($G(^DGCR(399,IBIFN,"OP",0)),"^",4) S (DGPROCDT,Y)=$O(^DGCR(399,IBIFN,"OP",0)) D D^DIQ W "   (",Y,")" Q
    30         . S %DT="EXP",%DT(0)=-DT D ^%DT K %DT I Y<1 S IBEX=1 Q
    31         . I '$$OPV2^IBCU41(Y,IBIFN,1) S IBEX=1 Q
    32         . S:'$G(IBZTYPE) X=$$OPV^IBCU41(Y,IBIFN) S DGPROCDT=Y
    33         I 'IBEX D ASKCOD,ADDCPT^IBCU71:$D(DGCPT)
    34         K IBEX
    35         G CODDT
    36         ;
    37 ASKCOD  N Z,Z0,DA,IBACT,IBQUIT
    38         K DGCPT
    39         S DGCPT=0,DGCPTUP=$P($G(^IBE(350.9,1,1)),"^",19),DGADDVST=0,IBFT=$P($G(^DGCR(399,IBIFN,0)),"^",19)
    40         I '$D(^DGCR(399,IBIFN,"CP",0)) S ^DGCR(399,IBIFN,"CP",0)=U_$$GETSPEC^IBEFUNC(399,304)
    41         ;
    42         F  S IBQUIT=0 D  Q:IBQUIT
    43         . S DIC("A")="   Select PROCEDURE: "
    44         . S DIC="^DGCR(399,"_IBIFN_",""CP"","
    45         . S DIC(0)="AEQMNL"
    46         . S DIC("S")="I '$D(DIV(""S""))&($P(^(0),U,2)=DGPROCDT)"
    47         . S DIC("DR")="1///^S X=DGPROCDT"
    48         . S DA(1)=IBIFN,DLAYGO=399
    49         . W ! D ^DIC I Y<1 S IBQUIT=1 Q
    50         . ; If we just added inactive code - it must be deleted.
    51         . S IBACT=0 ; Active flag
    52         . I Y["ICD0" S IBACT=$$ICD0ACT^IBACSV(+$P(Y,U,2),DGPROCDT)
    53         . I Y["ICPT" S IBACT=$$CPTACT^IBACSV(+$P(Y,U,2),DGPROCDT)
    54         . S DGCPTNEW=$P(Y,"^",3) ;Was the procedure just added?
    55         . I DGCPTNEW,'IBACT D DELPROC Q
    56         . I 'IBACT W !,*7,"Warning:  Procedure code is inactive on this date",!
    57         . I DGCPTNEW,$D(^UTILITY($J,"IB")),$$INPAT^IBCEF(IBIFN),Y["ICPT(" D DATA^IBCU74(Y)
    58         . S DGADDVST=$S(DGCPTNEW:1,$D(DGADDVST):DGADDVST,1:0)
    59         . N IBPRV,IBPRVO,IBPRVN
    60         . S IBPRVO=$$MAINPRV^IBCEU(IBIFN),IBPRV=$P(IBPRVO,U,3),IBPRVN=(IBPRVO["IBA(355.93,"),IBPRV=$S(IBPRV="":"",'IBPRVN:$P(IBPRVO,U),1:"")
    61         . I IBPRV="",'IBPRVN D
    62         .. S IBPRV=0 F  S IBPRV=$O(^DGCR(399,IBIFN,"CP",IBPRV)) S:'IBPRV IBPRV="" Q:'IBPRV  S Z=$P($G(^(IBPRV,0)),U,18) I Z S IBPRV=$P($G(^VA(200,Z,0)),U) Q
    63         . S DR="" I Y["ICPT" S DR="16"_$S(IBPRVN:";18///@",1:";18//"_IBPRV)_";6;5//"_$$DEFDIV(IBIFN)_";"
    64         . S DR=".01;"_DR_$S(IBFT=2:"8;9;17//NO;",1:"")_3,DIE=DIC,(IBPROCP,DA)=+Y D ^DIE Q:'$D(DA)!($E($G(Y))=U)
    65         . ;
    66         . S DR=$$SPCUNIT(IBIFN,IBPROCP) I DR'="" D ^DIE ; miles/minutes/hours
    67         . ;
    68         . I IBFT=2 D
    69         .. D DX^IBCU72(IBIFN,IBPROCP)
    70         .. S X=$$ADDTNL(IBIFN,.DA)
    71         . Q:$$INPAT^IBCEF(IBIFN)  ;only outpatient bills
    72         . ;add procedures to array for download to PCE: dgcpt(assoc clinic,cpt,'provider^first dx^modifiers',cnt)=""
    73         . S DGPROC=$G(^DGCR(399,IBIFN,"CP",+DA,0))
    74         . S X=$P(DGPROC,U,18)_U_+$G(^IBA(362.3,+$P(DGPROC,U,11),0))_U_$P(DGPROC,U,15)
    75         . I 'DGCPTNEW,$P(DGPROC,"^",7)="" S DGCPTNEW=2
    76         . I DGCPTUP,DGCPTNEW S DGCPT=DGCPT+1 I $P(DGPROC,"^",7) S DGCPT($P(DGPROC,"^",7),+DGPROC,X,DGCPT)=""
    77         . ; add visit date to bill
    78         . I DGADDVST S (X,DINUM)=DGPROCDT D VFILE1^IBCOPV1 K DINUM,X,DGNOADD,DGADDVST
    79         ; Delete modifers with only a sequence #, no code
    80         S Z=0 F  S Z=$O(^DGCR(399,IBIFN,"CP",Z)) Q:'Z  S Z0=0 F  S Z0=$O(^DGCR(399,IBIFN,"CP",Z,"MOD",Z0)) Q:'Z0  I $P($G(^(Z0,0)),U,2)="" S DA(2)=IBIFN,DA(1)=Z,DA=Z0,DIK="^DGCR(399,"_DA(2)_",""CP"","_DA(1)_",""MOD""," D ^DIK
    81         Q
    82 CODQ    K %DT,DGPROC,DIC,DIE,DR,DGPROCDT,IBPROCP,DLAYGO
    83         K IBFT,DGNOADD,DGADDVST,DGCPT,DGCPTUP,IBZTYPE,DGCPTNEW
    84         Q
    85         ;
    86 DELPROC ; Remove the selected procedure, because of inactive status (cancel selection)
    87         W !!,*7,"The Procedure code is inactive on ",$$DAT1^IBOUTL(DGPROCDT),"."
    88         W !,"Please select another Procedure."
    89         S DA(1)=IBIFN,DA=+Y,DIK="^DGCR(399,"_IBIFN_",""CP"","
    90         D ^DIK
    91         Q
    92         ;
    93 DELADD  N Z,Z0,DA,DIK,X,Y
    94         S DA(1)=IBIFN
    95         ;Delete references to proc on rev codes
    96         S Z=0 F  S Z=$O(^DGCR(399,IBIFN,"RC",Z)) Q:'Z  S Z0=$G(^(Z,0)) I Z0'="",$P(Z0,U,15)!$S($P(Z0,U,10)=3:$P(Z0,U,11),1:0) S DIE="^DGCR(399,"_DA(1)_",""RC"",",DA=Z,DR=".11///@;.15///@"_$S($P(Z0,U,8):"",1:";.08////1") D ^DIE
    97         S DIK="^DGCR(399,"_DA(1)_",""CP""," F DA=0:0 S DA=$O(^DGCR(399,DA(1),"CP",DA)) Q:'DA  D ^DIK
    98         S DGRVRCAL=1
    99         Q
    100         ;
    101 DTMES   ;Message if procedure date not in date range
    102         Q:'$D(IBIFN)  Q:'$D(^DGCR(399,IBIFN,"U"))  S DGNODUU=^("U")
    103         G:X'<$P(DGNODUU,"^")&(X'>$P(DGNODUU,"^",2)) DTMESQ
    104         W *7,!!?3,"Date must be within STATEMENT COVERS FROM and STATEMENT COVERS TO period."
    105         S Y=$P(DGNODUU,"^") X ^DD("DD")
    106         W !?3,"Enter a date between ",Y," and " S Y=$P(DGNODUU,"^",2) X ^DD("DD") W Y,!
    107         K X,Y
    108 DTMESQ  K DGNODUU Q
    109         ;
    110 CODHLP  ;Display Additional Procedure codes
    111         N I,J,Y,IBMOD
    112         I '$O(^DGCR(399,IBIFN,"CP",0)) W !!?5,"No Codes Entered!",! Q
    113         F I=0:0 S I=$O(^DGCR(399,IBIFN,"CP",I)) Q:'I  S Y=$G(^(I,0)) S Z=$$PRCNM^IBCSCH1($P(Y,"^",1),$P(Y,"^",2)) W !?5,$E($P(Z,"^",2),1,28),?35,"- ",$P(Z,"^") D
    114         . N IBY
    115         . S IBY=$P(Y,U,2)
    116         . S IBMOD=$$GETMOD^IBEFUNC(IBIFN,I,1)
    117         . I IBMOD'="" S IBMOD="/"_IBMOD W IBMOD
    118         . W ?60,"Date: " S Y=IBY D DT^DIQ
    119         ;
    120         K Z Q
    121         ;
    122 DICV    I $D(IBIFN),$D(^DGCR(399,IBIFN,0)),$P(^(0),U,9) S DIC("V")=$S($P(^(0),U,9)=9:"I +Y(0)=80.1",$P(^(0),U,9)=4!($P(^(0),U,9)=5):"I +Y(0)=81",1:"")
    123         Q
    124         ;
    125 DEFDIV(IBIFN)   ; Find default division for bill IBIFN
    126         Q $P($G(^DG(40.8,+$P($G(^DGCR(399,IBIFN,0)),U,22),0)),U)
    127         ;
    128 ADDTNL(IBIFN,DA)        ;
    129         N DR,IBOK,X,Y,DIR
    130         S IBOK=1
    131         S DR="19;50.09;50.08" D ^DIE
    132         I $D(Y) S IBOK=0 G ADDTNLQ
    133         S DIR("B")="NO",DIR("A")="EDIT CMS-1500 SPECIAL PROGRAM FIELDS and BOX 19?: ",DIR("A",1)=" ",DIR(0)="YA"
    134         S DIR("?",1)="Respond YES only if you need to add/edit data for chiropractic visits,"
    135         S DIR("?")="EPSDT care, or if billing for HOSPICE and attending is not a hospice employee."
    136         D ^DIR K DIR
    137         I Y'=1 S IBOK=0 G ADDTNLQ
    138         S DR="W !,""  <<EPSDT>>"";50.07;W !!,""  <<HOSPICE>>"";50.03"
    139         D ^DIE
    140         W !
    141 ADDTNLQ Q IBOK
    142         ;
    143 XTRA1(Y)        ;
    144         K Y
    145         Q
    146         ;
    147 SPCUNIT(IBIFN,DA)       ; return fields for special units if applicable, in DR form
    148         N IB0,IBCPT,IBDR,IBCT,IBFT,DFN S IBDR=""
    149         S IB0=$G(^DGCR(399,+$G(IBIFN),0)),IBCT=$P(IB0,U,27),IBFT=$P(IB0,U,19),DFN=$P(IB0,U,2)
    150         S IBCPT=$G(^DGCR(399,+$G(IBIFN),"CP",+$G(DA),0)) I IBCPT'["ICPT" G SPCUNTQ
    151         I +$$ITMUNIT^IBCRU4(+IBCPT,5,IBCT) S IBDR="15;" D SROMIN^IBCU74(IBIFN,DA) G SPCUNTQ ; minutes
    152         I +$$ITMUNIT^IBCRU4(+IBCPT,4,IBCT) S IBDR="21;" G SPCUNTQ ; miles
    153         I +$$ITMUNIT^IBCRU4(+IBCPT,6,IBCT) S IBDR="22//"_$$OBSHOUR^IBCU74(DFN,$P(IBCPT,U,2))_";" G SPCUNTQ ; hours
    154         I +IBFT=2,$P($G(^IBE(353.2,+$P(IBCPT,U,10),0)),U,2)="ANESTHESIA" S IBDR="15;" ; minutes
    155 SPCUNTQ Q IBDR
     1IBCU7 ;ALB/AAS - INTERCEPT SCREEN INPUT OF PROCEDURE CODES ;29-OCT-91
     2 ;;2.0;INTEGRATED BILLING;**62,52,106,125,51,137,210,245,228,260,348**;21-MAR-94;Build 5
     3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
     4 ;
     5 ;MAP TO DGCRU7
     6 ;
     7CHKX ;  -interception of input x from Additional Procedure input
     8 G:X=" " CHKXQ
     9 I $$INPAT^IBCEF(DA(1)),'$P($G(^IBE(350.9,1,1)),"^",15),X'?1A1N D  G CHKXQ
     10 . K X
     11 . D EN^DDIOL("Site param does not allow entry of non-PTF procedures") ;Fileman error here will be: The previous error occurred when performing an action specified in a Pre-lookup transform (7.5 node).
     12 G:'$D(^UTILITY($J,"IB")) CHKXQ
     13 S M=($A($E(X,1))-64),S=+$E(X,2) Q:'$G(^UTILITY($J,"IB",M,S))  S X="`"_+^(S)
     14 I $D(DGPROCDT),DGPROCDT'=$P($G(^UTILITY($J,"IB",M,1)),"^",2) S DGPROCDT=$P(^(1),"^",2) W !!,"Procedure Date: " S Y=DGPROCDT X ^DD("DD") W Y,!
     15CHKXQ Q
     16 ;
     17CODMUL ;Date oriented entry of procedure
     18DELASK I $D(IBZ20),IBZ20,IBZ20'=$P(^DGCR(399,IBIFN,0),U,9) S %=2 W !,"SINCE THE PROCEDURE CODING METHOD HAS BEEN CHANGED, DO YOU WANT TO DELETE ALL",!,"PROCEDURE CODES IN THIS BILL"
     19 I  D YN^DICN Q:%=-1  D:%=1 DELADD I %Y?1."?" W !!,"If you answer 'Yes', all procedure codes will be DELETED from this bill.",! G DELASK
     20 K %,%Y,DA,IBZ20,DIK ;W !,"Procedure Entry:"
     21 ;
     22CODDT I $D(IBIFN),$D(^DGCR(399,IBIFN,0)),$P(^(0),U,9) S DIC("V")=$S($P(^(0),U,9)=9:"I +Y(0)=80.1",$P(^(0),U,9)=4!($P(^(0),U,9)=5):"I +Y(0)=81",1:"")
     23 I $P($G(^DGCR(399,IBIFN,0)),"^",5)<3 S IBZTYPE=1 I $P($G(^UTILITY($J,"IB",1,1)),"^",2) S DGPROCDT=$P(^(1),"^",2) D ASKCOD
     24 S X=$$PRCDIV^IBCU71(IBIFN) I +X W !!,$P(X,U,2),!
     25 N Z,Z0 S Z=$G(^DGCR(399,IBIFN,"U")),Z0=$$FMTE^XLFDT($P(Z,U),"2D")_"-"_$$FMTE^XLFDT($P(Z,U,2),"2D")
     26 W !,"Select PROCEDURE DATE"_$S($TR(Z0,"-")'="":" ("_Z0_")",1:"")_": " R X:DTIME G:'$T!("^"[X) CODQ D:X["?" CODHLP
     27 S IBEX=0 D  ; Get procedure date
     28 . I X=" ",$D(DGPROCDT),DGPROCDT?7N S Y=DGPROCDT D D^DIQ W "   (",Y,")" Q
     29 . I X=" ",+$P($G(^DGCR(399,IBIFN,"OP",0)),"^",4) S (DGPROCDT,Y)=$O(^DGCR(399,IBIFN,"OP",0)) D D^DIQ W "   (",Y,")" Q
     30 . S %DT="EXP",%DT(0)=-DT D ^%DT K %DT I Y<1 S IBEX=1 Q
     31 . I '$$OPV2^IBCU41(Y,IBIFN,1) S IBEX=1 Q
     32 . S:'$G(IBZTYPE) X=$$OPV^IBCU41(Y,IBIFN) S DGPROCDT=Y
     33 I 'IBEX D ASKCOD,ADDCPT^IBCU71:$D(DGCPT)
     34 K IBEX
     35 G CODDT
     36 ;
     37ASKCOD N Z,Z0,DA,IBACT,IBQUIT
     38 K DGCPT
     39 S DGCPT=0,DGCPTUP=$P($G(^IBE(350.9,1,1)),"^",19),DGADDVST=0,IBFT=$P($G(^DGCR(399,IBIFN,0)),"^",19)
     40 I '$D(^DGCR(399,IBIFN,"CP",0)) S ^DGCR(399,IBIFN,"CP",0)=U_$$GETSPEC^IBEFUNC(399,304)
     41 ;
     42 F  S IBQUIT=0 D  Q:IBQUIT
     43 . S DIC("A")="   Select PROCEDURE: "
     44 . S DIC="^DGCR(399,"_IBIFN_",""CP"","
     45 . S DIC(0)="AEQMNL"
     46 . S DIC("S")="I '$D(DIV(""S""))&($P(^(0),U,2)=DGPROCDT)"
     47 . S DIC("DR")="1///^S X=DGPROCDT"
     48 . S DA(1)=IBIFN,DLAYGO=399
     49 . W ! D ^DIC I Y<1 S IBQUIT=1 Q
     50 . ; If we just added inactive code - it must be deleted.
     51 . S IBACT=0 ; Active flag
     52 . I Y["ICD0" S IBACT=$$ICD0ACT^IBACSV(+$P(Y,U,2),DGPROCDT)
     53 . I Y["ICPT" S IBACT=$$CPTACT^IBACSV(+$P(Y,U,2),DGPROCDT)
     54 . S DGCPTNEW=$P(Y,"^",3) ;Was the procedure just added?
     55 . I DGCPTNEW,'IBACT D DELPROC Q
     56 . I 'IBACT W !,*7,"Warning:  Procedure code is inactive on this date",!
     57 . I DGCPTNEW,$D(^UTILITY($J,"IB")),$$INPAT^IBCEF(IBIFN),Y["ICPT(" D DATA^IBCU74(Y)
     58 . S DGADDVST=$S(DGCPTNEW:1,$D(DGADDVST):DGADDVST,1:0)
     59 . N IBPRV,IBPRVO,IBPRVN
     60 . S IBPRVO=$$MAINPRV^IBCEU(IBIFN),IBPRV=$P(IBPRVO,U,3),IBPRVN=(IBPRVO["IBA(355.93,"),IBPRV=$S(IBPRV="":"",'IBPRVN:$P(IBPRVO,U),1:"")
     61 . I IBPRV="",'IBPRVN D
     62 .. S IBPRV=0 F  S IBPRV=$O(^DGCR(399,IBIFN,"CP",IBPRV)) S:'IBPRV IBPRV="" Q:'IBPRV  S Z=$P($G(^(IBPRV,0)),U,18) I Z S IBPRV=$P($G(^VA(200,Z,0)),U) Q
     63 . S DR="" I Y["ICPT" S DR="16"_$S(IBPRVN:";18///@",1:";18//"_IBPRV)_";6;5//"_$$DEFDIV(IBIFN)_";"
     64 . S DR=".01;"_DR_$S(IBFT=2:"8;9;17//NO;",1:"")_3,DIE=DIC,(IBPROCP,DA)=+Y D ^DIE Q:'$D(DA)!($E($G(Y))=U)
     65 . ;
     66 . S DR=$$SPCUNIT(IBIFN,IBPROCP) I DR'="" D ^DIE ; miles/minutes/hours
     67 . ;
     68 . I IBFT=2 D
     69 .. D DX^IBCU72(IBIFN,IBPROCP)
     70 .. S X=$$ADDTNL(IBIFN,.DA)
     71 . Q:$$INPAT^IBCEF(IBIFN)  ;only outpatient bills
     72 . ;add procedures to array for download to PCE: dgcpt(assoc clinic,cpt,'provider^first dx^modifiers',cnt)=""
     73 . S DGPROC=$G(^DGCR(399,IBIFN,"CP",+DA,0))
     74 . S X=$P(DGPROC,U,18)_U_+$G(^IBA(362.3,+$P(DGPROC,U,11),0))_U_$P(DGPROC,U,15)
     75 . I 'DGCPTNEW,$P(DGPROC,"^",7)="" S DGCPTNEW=2
     76 . I DGCPTUP,DGCPTNEW S DGCPT=DGCPT+1 I $P(DGPROC,"^",7) S DGCPT($P(DGPROC,"^",7),+DGPROC,X,DGCPT)=""
     77 . ; add visit date to bill
     78 . I DGADDVST S (X,DINUM)=DGPROCDT D VFILE1^IBCOPV1 K DINUM,X,DGNOADD,DGADDVST
     79 ; Delete modifers with only a sequence #, no code
     80 S Z=0 F  S Z=$O(^DGCR(399,IBIFN,"CP",Z)) Q:'Z  S Z0=0 F  S Z0=$O(^DGCR(399,IBIFN,"CP",Z,"MOD",Z0)) Q:'Z0  I $P($G(^(Z0,0)),U,2)="" S DA(2)=IBIFN,DA(1)=Z,DA=Z0,DIK="^DGCR(399,"_DA(2)_",""CP"","_DA(1)_",""MOD""," D ^DIK
     81 Q
     82CODQ K %DT,DGPROC,DIC,DIE,DR,DGPROCDT,IBPROCP,DLAYGO
     83 K IBFT,DGNOADD,DGADDVST,DGCPT,DGCPTUP,IBZTYPE,DGCPTNEW
     84 Q
     85 ;
     86DELPROC ; Remove the selected procedure, because of inactive status (cancel selection)
     87 W !!,*7,"The Procedure code is inactive on ",$$DAT1^IBOUTL(DGPROCDT),"."
     88 W !,"Please select another Procedure."
     89 S DA(1)=IBIFN,DA=+Y,DIK="^DGCR(399,"_IBIFN_",""CP"","
     90 D ^DIK
     91 Q
     92 ;
     93DELADD N Z,Z0,DA,DIK,X,Y
     94 S DA(1)=IBIFN
     95 ;Delete references to proc on rev codes
     96 S Z=0 F  S Z=$O(^DGCR(399,IBIFN,"RC",Z)) Q:'Z  S Z0=$G(^(Z,0)) I Z0'="",$P(Z0,U,15)!$S($P(Z0,U,10)=3:$P(Z0,U,11),1:0) S DIE="^DGCR(399,"_DA(1)_",""RC"",",DA=Z,DR=".11///@;.15///@"_$S($P(Z0,U,8):"",1:";.08////1") D ^DIE
     97 S DIK="^DGCR(399,"_DA(1)_",""CP""," F DA=0:0 S DA=$O(^DGCR(399,DA(1),"CP",DA)) Q:'DA  D ^DIK
     98 S DGRVRCAL=1
     99 Q
     100 ;
     101DTMES ;Message if procedure date not in date range
     102 Q:'$D(IBIFN)  Q:'$D(^DGCR(399,IBIFN,"U"))  S DGNODUU=^("U")
     103 G:X'<$P(DGNODUU,"^")&(X'>$P(DGNODUU,"^",2)) DTMESQ
     104 W *7,!!?3,"Date must be within STATEMENT COVERS FROM and STATEMENT COVERS TO period."
     105 S Y=$P(DGNODUU,"^") X ^DD("DD")
     106 W !?3,"Enter a date between ",Y," and " S Y=$P(DGNODUU,"^",2) X ^DD("DD") W Y,!
     107 K X,Y
     108DTMESQ K DGNODUU Q
     109 ;
     110CODHLP ;Display Additional Procedure codes
     111 N I,J,Y,IBMOD
     112 I '$O(^DGCR(399,IBIFN,"CP",0)) W !!?5,"No Codes Entered!",! Q
     113 F I=0:0 S I=$O(^DGCR(399,IBIFN,"CP",I)) Q:'I  S Y=$G(^(I,0)) S Z=$$PRCNM^IBCSCH1($P(Y,"^",1),$P(Y,"^",2)) W !?5,$E($P(Z,"^",2),1,28),?35,"- ",$P(Z,"^") D
     114 . N IBY
     115 . S IBY=$P(Y,U,2)
     116 . S IBMOD=$$GETMOD^IBEFUNC(IBIFN,I,1)
     117 . I IBMOD'="" S IBMOD="/"_IBMOD W IBMOD
     118 . W ?60,"Date: " S Y=IBY D DT^DIQ
     119 ;
     120 K Z Q
     121 ;
     122DICV I $D(IBIFN),$D(^DGCR(399,IBIFN,0)),$P(^(0),U,9) S DIC("V")=$S($P(^(0),U,9)=9:"I +Y(0)=80.1",$P(^(0),U,9)=4!($P(^(0),U,9)=5):"I +Y(0)=81",1:"")
     123 Q
     124 ;
     125DEFDIV(IBIFN) ; Find default division for bill IBIFN
     126 Q $P($G(^DG(40.8,+$P($G(^DGCR(399,IBIFN,0)),U,22),0)),U)
     127 ;
     128ADDTNL(IBIFN,DA) ;
     129 N DR,IBOK,X,Y,DIR
     130 S IBOK=1
     131 S DR="19;50.09;50.08" D ^DIE
     132 I $D(Y) S IBOK=0 G ADDTNLQ
     133 S DIR("B")="NO",DIR("A")="EDIT CMS-1500 SPECIAL PROGRAM FIELDS and BOX 19?: ",DIR("A",1)=" ",DIR(0)="YA"
     134 S DIR("?",1)="Respond YES only if you need to add/edit data for chiropractic visits,"
     135 S DIR("?")="EPSDT care, or if billing for HOSPICE and attending is not a hospice employee."
     136 D ^DIR K DIR
     137 I Y'=1 S IBOK=0 G ADDTNLQ
     138 S DR="W !,""  <<EPSDT>>"";50.07;W !!,""  <<HOSPICE>>"";50.03;W !!,""  <<CHIROPRACTIC>>"";50.04;50.02;50.05;50.06"
     139 D ^DIE
     140 W !
     141ADDTNLQ Q IBOK
     142 ;
     143XTRA1(Y) ;
     144 K Y
     145 Q
     146 ;
     147SPCUNIT(IBIFN,DA) ; return fields for special units if applicable, in DR form
     148 N IB0,IBCPT,IBDR,IBCT,IBFT,DFN S IBDR=""
     149 S IB0=$G(^DGCR(399,+$G(IBIFN),0)),IBCT=$P(IB0,U,27),IBFT=$P(IB0,U,19),DFN=$P(IB0,U,2)
     150 S IBCPT=$G(^DGCR(399,+$G(IBIFN),"CP",+$G(DA),0)) I IBCPT'["ICPT" G SPCUNTQ
     151 I +$$ITMUNIT^IBCRU4(+IBCPT,5,IBCT) S IBDR="15;" D SROMIN^IBCU74(IBIFN,DA) G SPCUNTQ ; minutes
     152 I +$$ITMUNIT^IBCRU4(+IBCPT,4,IBCT) S IBDR="21;" G SPCUNTQ ; miles
     153 I +$$ITMUNIT^IBCRU4(+IBCPT,6,IBCT) S IBDR="22//"_$$OBSHOUR^IBCU74(DFN,$P(IBCPT,U,2))_";" G SPCUNTQ ; hours
     154 I +IBFT=2,$P($G(^IBE(353.2,+$P(IBCPT,U,10),0)),U,2)="ANESTHESIA" S IBDR="15;" ; minutes
     155SPCUNTQ Q IBDR

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCVA0.m

    r613 r623  
    1 IBCVA0  ;ALB/MJB - SET MCCR VARIABLES CONT.  ;04 AUG 88 03:02
    2         ;;2.0;INTEGRATED BILLING;**52,361,371**;21-MAR-94;Build 57
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5         ;MAP TO DGCRVA0
    6         ;
    7         Q
    8 ALL     I $D(DFN) S IBDPT=^DPT(DFN,0) D ADDR ;I IBADD1]"",$L(IBADD1)'>47 S DIE="^DGCR(399,",(DA,Y)=+IBIFN,DR="110///"_IBADD1 D ^DIE K DIE,DR,DA
    9         ;I $D(^DPT(DFN,.11)) S IBST=$P(^(.11),U,5),IBST=$S(IBST'="":$P(^DIC(5,IBST,0),U,2),1:"")
    10         S IBBNO=$P(IB(0),"^"),IBDT=$P(IB(0),"^",3)
    11         D 2^VADPT
    12         ;I $P(IB(0),U,5)<3 S Y=0 F I=1:1 S Y=$O(^DGPM("APTT1",DFN,Y)) Q:'Y  S:$E(Y,1,7)=IBDT IBDA=Y
    13         Q
    14 1       ;Demographic variables set
    15         D Q1^IBCVA
    16 EN1     Q:'$D(DFN)  S IBMAR=$S($P(IBDPT,U,5)'="":$P(IBDPT,U,5),1:"U") I IBMAR'="U" S IBMAR=$S(IBMAR=6:"S",IBMAR=2:"M",IBMAR=1:"D",IBMAR=4:"W",IBMAR=5:"X",1:"U")
    17         I $D(^DPT(DFN,.121)) S IBTADD=^DPT(DFN,.121),IBTST=$P(IBTADD,U,5),IBTST=$S(IBTST'="":$P(^DIC(5,IBTST,0),U,2),1:"") I $P(IBTADD,U)="" S IBT1="NO TEMPORARY ADDRESS"
    18         Q
    19 2       ;Employment variables set
    20         D Q1^IBCVA,Q2^IBCVA
    21 EN2     S:'$D(^DPT(DFN,.311)) IBEMPD="" I $D(^DPT(DFN,.311)) I ^DPT(DFN,.311)'="" S IBEMPD=$P(^(.311),U)_"^"_$P(^(.311),U,6)_"^"_$S($P(^(.311),U,7)'="":$P(^(.311),U,7),1:"")_"^"_$P($G(^DPT(DFN,.22)),U,5)_"^"_$P(IB(0),U,9)_"^"_$P(IB(0),U,8)
    22         I $D(IBEMPD) S:IBEMPD'="" IBEC=$P(^DPT(DFN,.311),"^",15)
    23         I $D(^DPT(DFN,.25)) S:$P(^DPT(DFN,.25),U,6)'="" IBSEST=$P(^(.25),U,6),IBSEST=$P(^DIC(5,IBSEST,0),U,2)
    24         Q
    25 3       ;Insurance variables set
    26 EN3     D 123^IBCVA
    27 EN31    ; -IBdd(i) = value of ins node in dpt
    28         I '$D(^DGCR(399,IBIFN,"AIC")) S IBINDT=$S(+$G(IB("U")):+IB("U"),+$G(^DGCR(399,IBIFN,"U")):+$G(^("U")),1:DT) D ALL^IBCNS1(DFN,"IBDD",1,IBINDT) S I="" F  S I=$O(IBDD(I)) Q:'I  D INS
    29         I $D(^DGCR(399,IBIFN,"AIC")) S IBIN="I" F I=1:1:3 S IBIN=$O(^DGCR(399,IBIFN,IBIN)) Q:IBIN'?1"I".N  S IBDD(I,0)=^DGCR(399,IBIFN,IBIN) D INS
    30         Q
    31 INS     I $P(IBDD(I,0),U,6)="v" S IBISEX(I)=$P(^DPT(DFN,0),U,2)
    32         E  S IBISEX(I)=$P($G(^DPT(DFN,.312,+$P($G(^DGCR(399,IBIFN,"M")),U,I+11),3)),U,12) ; *361 replaces old calculation of insured's sex
    33         S IBISEX(I)=$S(IBISEX(I)="M":"MALE",IBISEX(I)="F":"FEMALE",1:"UNSPECIFIED")
    34         S IBIRN(I)=$P(IBDD(I,0),U,16)
    35         S IBIR(I)=$$EXTERNAL^DILFD(2.312,16,,IBIRN(I))
    36         Q
    37 ADDR    ;SET ADDRESS
    38         S IBADD1="" I $D(^DGCR(399,IBIFN,"M")),$P(^("M"),"^",10)]"" Q
    39         S X=$S($D(^DPT(DFN,.11)):^(.11),1:"") F I=1:1:4 I $P(X,"^",I)]"" S IBADD1=IBADD1_$P(X,"^",I)_","
    40         I $D(^DIC(5,+$P(X,"^",5),0)) S IBADD1=IBADD1_$P(^(0),"^",2),IBST=$P(^(0),"^",2)
    41         S:$P(X,"^",12)]"" IBADD1=IBADD1_" "_$P(X,"^",12) Q
    42         ;IBCVA0
     1IBCVA0 ;ALB/MJB - SET MCCR VARIABLES CONT.  ;04 AUG 88 03:02
     2 ;;2.0;INTEGRATED BILLING;**52,361**;21-MAR-94;Build 9
     3 ;;Per VHA Directive 2004-038, this routine should not be modified.
     4 ;
     5 ;MAP TO DGCRVA0
     6 ;
     7 Q
     8ALL I $D(DFN) S IBDPT=^DPT(DFN,0) D ADDR ;I IBADD1]"",$L(IBADD1)'>47 S DIE="^DGCR(399,",(DA,Y)=+IBIFN,DR="110///"_IBADD1 D ^DIE K DIE,DR,DA
     9 ;I $D(^DPT(DFN,.11)) S IBST=$P(^(.11),U,5),IBST=$S(IBST'="":$P(^DIC(5,IBST,0),U,2),1:"")
     10 S IBBNO=$P(IB(0),"^"),IBDT=$P(IB(0),"^",3)
     11 D 2^VADPT
     12 ;I $P(IB(0),U,5)<3 S Y=0 F I=1:1 S Y=$O(^DGPM("APTT1",DFN,Y)) Q:'Y  S:$E(Y,1,7)=IBDT IBDA=Y
     13 Q
     141 ;Demographic variables set
     15 D Q1^IBCVA
     16EN1 Q:'$D(DFN)  S IBMAR=$S($P(IBDPT,U,5)'="":$P(IBDPT,U,5),1:"U") I IBMAR'="U" S IBMAR=$S(IBMAR=6:"S",IBMAR=2:"M",IBMAR=1:"D",IBMAR=4:"W",IBMAR=5:"X",1:"U")
     17 I $D(^DPT(DFN,.121)) S IBTADD=^DPT(DFN,.121),IBTST=$P(IBTADD,U,5),IBTST=$S(IBTST'="":$P(^DIC(5,IBTST,0),U,2),1:"") I $P(IBTADD,U)="" S IBT1="NO TEMPORARY ADDRESS"
     18 Q
     192 ;Employment variables set
     20 D Q1^IBCVA,Q2^IBCVA
     21EN2 S:'$D(^DPT(DFN,.311)) IBEMPD="" I $D(^DPT(DFN,.311)) I ^DPT(DFN,.311)'="" S IBEMPD=$P(^(.311),U)_"^"_$P(^(.311),U,6)_"^"_$S($P(^(.311),U,7)'="":$P(^(.311),U,7),1:"")_"^"_$P($G(^DPT(DFN,.22)),U,5)_"^"_$P(IB(0),U,9)_"^"_$P(IB(0),U,8)
     22 I $D(IBEMPD) S:IBEMPD'="" IBEC=$P(^DPT(DFN,.311),"^",15)
     23 I $D(^DPT(DFN,.25)) S:$P(^DPT(DFN,.25),U,6)'="" IBSEST=$P(^(.25),U,6),IBSEST=$P(^DIC(5,IBSEST,0),U,2)
     24 Q
     253 ;Insurance variables set
     26EN3 D 123^IBCVA
     27EN31 ; -IBdd(i) = value of ins node in dpt
     28 I '$D(^DGCR(399,IBIFN,"AIC")) S IBINDT=$S(+$G(IB("U")):+IB("U"),+$G(^DGCR(399,IBIFN,"U")):+$G(^("U")),1:DT) D ALL^IBCNS1(DFN,"IBDD",1,IBINDT) S I="" F  S I=$O(IBDD(I)) Q:'I  D INS
     29 I $D(^DGCR(399,IBIFN,"AIC")) S IBIN="I" F I=1:1:3 S IBIN=$O(^DGCR(399,IBIFN,IBIN)) Q:IBIN'?1"I".N  S IBDD(I,0)=^DGCR(399,IBIFN,IBIN) D INS
     30 Q
     31INS I $P(IBDD(I,0),U,6)="v" S IBISEX(I)=$P(^DPT(DFN,0),U,2)
     32 E  S IBISEX(I)=$P($G(^DPT(DFN,.312,+$P($G(^DGCR(399,IBIFN,"M")),U,I+11),3)),U,12) ; *361 replaces old calculation of insured's sex
     33 S IBISEX(I)=$S(IBISEX(I)="M":"MALE",IBISEX(I)="F":"FEMALE",1:"UNSPECIFIED")
     34 S IBIRN(I)=$P(IBDD(I,0),U,16),IBIR(I)=$S(IBIRN(I)="01":"PATIENT",IBIRN(I)="02":"SPOUSE",IBIRN(I)="03":"CHILD",IBIRN(I)="08":"EMPLOYEE",IBIRN(I)="11":"ORGAN DONOR",IBIRN(I)="18":"PARENT",IBIRN(I)=15:"PLANTIFF",1:"UNKNOWN")
     35 I IBIR(I)="UNKNOWN" S IBIR(I)=$S('$D(IBDD(I,0)):"UNKNOWN",$P(IBDD(I,0),U,6)="v":"PATIENT",$P(IBDD(I,0),U,6)="s":"SPOUSE",1:"UNKNOWN")
     36 ;S IBIUTL(I)=IBDD(I,0)_"^"_IBISEX(I)_"^"_IBIRN(I)
     37 Q
     38ADDR ;SET ADDRESS
     39 S IBADD1="" I $D(^DGCR(399,IBIFN,"M")),$P(^("M"),"^",10)]"" Q
     40 S X=$S($D(^DPT(DFN,.11)):^(.11),1:"") F I=1:1:4 I $P(X,"^",I)]"" S IBADD1=IBADD1_$P(X,"^",I)_","
     41 I $D(^DIC(5,+$P(X,"^",5),0)) S IBADD1=IBADD1_$P(^(0),"^",2),IBST=$P(^(0),"^",2)
     42 S:$P(X,"^",12)]"" IBADD1=IBADD1_" "_$P(X,"^",12) Q
     43 ;IBCVA0

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCVA1.m

    r613 r623  
    1 IBCVA1  ;ALB/MJB - SET MCCR VARIABLES CONT. ;09 JUN 88 14:49
    2         ;;2.0;INTEGRATED BILLING;**52,80,109,51,137,210,349,371**;21-MAR-94;Build 57
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5         ;MAP TO DGCRVA1
    6         ;
    7         Q
    8 4       ;Event variables set
    9         D 1234^IBCVA
    10         Q:'$D(IBBT)
    11 EN4     I $E(IBBT,2)>2 G OCC
    12 INP     D INP^IBCSC4
    13         ;NOTE (12/1/93): IBDI AND IBDIN ARRAYS WERE NOT UPDATED WITH NEW DX LOCATIONS BECAUSE THEY DO NOT SEEM TO BE USED ANYWHERE
    14 OCC     I $D(^DGCR(399,IBIFN,"C")) D
    15         . N IBDATE,IBC
    16         . S IBDATE=$$BDATE^IBACSV(IBIFN) ; The date of service
    17         . S IBC=^DGCR(399,IBIFN,"C")
    18         . F I=14:1:18 S IBDI(I)=$P(IBC,U,I) Q:IBDI(I)=""  D
    19         .. S IBDIN(I)=IBDI(I)
    20         .. S IBDI(I)=$P($$ICD9^IBACSV(IBDI(I),IBDATE),U,3)
    21         K IBO S:'$D(^DGCR(399,IBIFN,"OC")) IBO="" G:$D(IBO) COND S IBNO=$P(^DGCR(399,IBIFN,"OC",0),U,3),IBOC=0
    22         S C=0 F I=0:1 S IBOC=$O(^DGCR(399,IBIFN,"OC",I)) Q:IBOC'?1N.N!(C=5)  I $D(^DGCR(399,IBIFN,"OC",I)) S C=C+1 D SOCC
    23         ;
    24 COND    S IBCC=0,D=0 F I=0:0 S IBCC=$O(^DGCR(399,IBIFN,"CC",IBCC)) Q:IBCC=""!(D=5)  I $D(^DGCR(399,IBIFN,"CC",IBCC,0)) S D=D+1,IBCC(D)=$P(^DGCR(399,IBIFN,"CC",IBCC,0),"^",1) D CONDN
    25         ;
    26         D PROC
    27         ;
    28         ;Q:'$D(^DGCR(399,IBIFN,"C"))  F I=0,"C" S IB(I)=$S($D(^DGCR(399,IBIFN,I)):^(I),1:"")
    29         ;I $P(IB(0),"^",9)=4 F I=1:1:3 S:$P(IB("C"),"^",I)'="" IBCPT(I)=$P(IB("C"),"^",I)
    30         ;I $P(IB(0),"^",9)=9 F I=4:1:6 S:$P(IB("C"),"^",I)'="" IBICD(I)=$P(IB("C"),"^",I)
    31         ;I $P(IB(0),"^",9)=5 F I=7:1:9 S:$P(IB("C"),"^",I)]"" IBHC(I)=$P(IB("C"),"^",I),IBHCN(I)=$S($D(^ICPT(IBHC(I),0)):$P(^(0),"^",1),1:"")
    32         Q
    33         ;
    34 5       ;Billing variables set
    35         D 123^IBCVA
    36 EN5     I '$D(IBIP) G REVC
    37         S IBLS=$S($P(IB("U"),U,15)]"":$P(IB("U"),U,15),1:0),IBBS=$S($P(IB("U"),U,11)]"":$P(IB("U"),U,11),1:IBU) I IBBS'=IBU S IBBS=$P(^DGCR(399.1,IBBS,0),"^",1)
    38 REVC    S IBREV=0 F I=1:1 S IBREV=$O(^DGCR(399,IBIFN,"RC",IBREV)) Q:IBREV'?1.N  S IBREVC(I)=^DGCR(399,IBIFN,"RC",IBREV,0)
    39         S IBTF=$P(IB(0),U,26),IBTF=$S(IBTF=1:"ADMIT THRU DISCHARGE",IBTF=2:"FIRST CLAIM",IBTF=3:"CONTINUING CLAIM",IBTF=4:"LAST CLAIM",IBTF=5:"LATE CHARGE(S)",IBTF=6:"ADJUSTMENT",IBTF=7:"REPLACEMENT",IBTF=8:"CANCEL",IBTF=0:"ZERO CLAIM",1:"")
    40         S IBBTP1=$E($$EXPAND^IBTRE(399,.24,$P(IB(0),U,24)),1,29)
    41         S IBBTP2=$E($$EXPAND^IBTRE(399,.25,+$P(IB(0),U,25)),1,26)
    42         S IBBTP3=IBTF
    43         Q
    44 SOCC    S IBO(C)=$P(^DGCR(399,IBIFN,"OC",IBOC,0),"^",1),IBO(C)=$P(^DGCR(399.1,IBO(C),0),"^",2),IBOCN(C)=$P(^(0),"^",1)
    45         S IBOCD(C)=$P(^DGCR(399,IBIFN,"OC",IBOC,0),"^",2),IBOCD2(C)=$P(^DGCR(399,IBIFN,"OC",IBOC,0),"^",4) Q
    46         Q
    47         ;
    48 CONDN   S IBCC(D)=$P($G(^DGCR(399.1,+IBCC(D),0)),U,2),IBCCN(D)=$P($G(^(0)),U,1)
    49         Q
    50         ;
    51 PROCX   ; Entrypoint from output formatter
    52         N IBIFN,IBZ
    53         S IBIFN=$G(IBXIEN)
    54         D PROC
    55         D F^IBCEF("N-PROCEDURE CODING METHD","IBZ",,IBIFN)
    56         I IBZ="" K IBPROC S IBPROC=0 Q
    57         S Z=0 F  S Z=$O(IBPROC(Z)) Q:'Z  I $P(IBPROC(Z),U)'[$S(IBZ=9:";ICD",1:";ICP") K IBPROC(Z) S IBPROC=IBPROC-1
    58         Q
    59         ;
    60 PROC    ;  -build array of procedures in IBPROC
    61         N IBHCFA,IBMOD,I,J,X,X1
    62         S IBHCFA=($$FT^IBCEF(IBIFN)=2)
    63         K IBPROC S IBPROC=0
    64         I '$D(IB("C")) S IB("C")=$G(^DGCR(399,IBIFN,"C"))
    65         S:'$D(IB(0)) IB(0)=$G(^DGCR(399,IBIFN,0)) S J=$P($G(IB(0)),"^",9)
    66         I IB("C")'="" F I=1:1:9 I $P(IB("C"),"^",I)'="" S IBPROC(I)=$P(IB("C"),"^",I)_";"_$S(I<4:"ICPT(",I<7:"ICD0(",1:"ICPT(")_"^"_$P(IB("C"),"^",$S(I#3:10+(I#3),1:13)),IBPROC=IBPROC+1
    67         I $D(^DGCR(399,IBIFN,"CP")) S X=0 F I=100:1 S X=$O(^DGCR(399,IBIFN,"CP",X)) Q:'X  S X1=$G(^(X,0)) Q:'X1  D
    68         . S IBMOD=$$GETMOD^IBEFUNC(IBIFN,X)
    69         . I $TR(IBMOD,",")'="" S $P(X1,U,15)=IBMOD
    70         . S IBPROC($S($P(X1,"^",4):$P(X1,"^",4),1:I))=X1
    71         . I IBHCFA S IBPROC($S($P(X1,"^",4):$P(X1,"^",4),1:I),"AUX")=$G(^DGCR(399,IBIFN,"CP",X,"AUX"))
    72         . S IBPROC=IBPROC+1
    73 PROCQ   Q
    74         ;
    75 ALLPROC(IBIFN,IBPROC)   ; Returns all procedures for bill IBIFN in array IBPROC
    76         ;  IBPROC = # of procedures found
    77         ;  IBPROC(prnt order)=0-node of 'CP' entry with piece 15 = the
    78         ;                      modifiers separated by commas
    79         ;  IBPROC(prnt order,"AUX")="AUX" node of 'CP' entry for CMS-1500 forms
    80         ; Pass IBPROC by reference
    81         ;
    82         N IB
    83         K IBPROC
    84         D PROC
    85         Q
    86         ;
    87 VC      ;returns a bills value codes, IBIFN must be defined: IBVC=count,IBVC(VIFN)=CODE ^ NAME ^ VALUE ^ $$?
    88         N IBY,IBX,IBZ S IBVC=0 Q:'$D(^DGCR(399,IBIFN,"CV"))
    89         S IBX=0 F  S IBX=$O(^DGCR(399,IBIFN,"CV",IBX)) Q:'IBX  S IBY=$G(^DGCR(399,IBIFN,"CV",IBX,0)) I +IBY D
    90         . S IBVC=IBVC+1,IBZ=$G(^DGCR(399.1,+IBY,0)) Q:IBZ=""
    91         . S IBVC(+IBY)=$P(IBZ,U,2)_U_$P(IBZ,U,1)_U_$S($P(IBY,U,2)="":"",+$P(IBZ,U,12):$J($P(IBY,U,2),0,2),1:$P(IBY,U,2))_U_$P(IBZ,U,12)
    92         Q
    93         ;
    94 SETMODS(IBMOD,IBZ,IBXSAVE)      ; Set modifiers into IBXSAVE
    95         ; IBMOD = the list of modifier iens for the proc, separated by commas
    96         ; IBZ = the line counter to return the data in
    97         ;
    98         ; Output Formatter utility
    99         ;
    100         ; Variables passed by reference, returned
    101         ; IBXSAVE("PROCMODS",IBZ) = Formatter 'save' array for modifiers
    102         ;
    103         N Q,IBQ
    104         I $L(IBMOD) F Q=1:1:$L(IBMOD,",") I $P(IBMOD,",",Q)'="" D
    105         . S IBQ=$$MOD^ICPTMOD(+$P(IBMOD,",",Q),"I")
    106         . S IBXSAVE("PROCMODS",IBZ)=$G(IBXSAVE("PROCMODS",IBZ))_$P(IBQ,U,2)_","
    107         S Q=$L($G(IBXSAVE("PROCMODS",IBZ)))
    108         I 'Q S IBXSAVE("PROCMODS",IBZ)=""
    109         I Q S IBXSAVE("PROCMODS",IBZ)=$E(IBXSAVE("PROCMODS",IBZ),1,Q-1)
    110         Q
    111         ;
     1IBCVA1 ;ALB/MJB - SET MCCR VARIABLES CONT. ;09 JUN 88 14:49
     2 ;;2.0;INTEGRATED BILLING;**52,80,109,51,137,210,349**;21-MAR-94;Build 46
     3 ;;Per VHA Directive 2004-038, this routine should not be modified.
     4 ;
     5 ;MAP TO DGCRVA1
     6 ;
     7 Q
     84 ;Event variables set
     9 D 1234^IBCVA
     10 Q:'$D(IBBT)
     11EN4 I $E(IBBT,2)>2 G OCC
     12INP D INP^IBCSC4
     13 ;NOTE (12/1/93): IBDI AND IBDIN ARRAYS WERE NOT UPDATED WITH NEW DX LOCATIONS BECAUSE THEY DO NOT SEEM TO BE USED ANYWHERE
     14OCC I $D(^DGCR(399,IBIFN,"C")) D
     15 . N IBDATE,IBC
     16 . S IBDATE=$$BDATE^IBACSV(IBIFN) ; The date of service
     17 . S IBC=^DGCR(399,IBIFN,"C")
     18 . F I=14:1:18 S IBDI(I)=$P(IBC,U,I) Q:IBDI(I)=""  D
     19 .. S IBDIN(I)=IBDI(I)
     20 .. S IBDI(I)=$P($$ICD9^IBACSV(IBDI(I),IBDATE),U,3)
     21 K IBO S:'$D(^DGCR(399,IBIFN,"OC")) IBO="" G:$D(IBO) COND S IBNO=$P(^DGCR(399,IBIFN,"OC",0),U,3),IBOC=0
     22 S C=0 F I=0:1 S IBOC=$O(^DGCR(399,IBIFN,"OC",I)) Q:IBOC'?1N.N!(C=5)  I $D(^DGCR(399,IBIFN,"OC",I)) S C=C+1 D SOCC
     23 ;
     24COND S IBCC=0,D=0 F I=0:0 S IBCC=$O(^DGCR(399,IBIFN,"CC",IBCC)) Q:IBCC=""!(D=5)  I $D(^DGCR(399,IBIFN,"CC",IBCC,0)) S D=D+1,IBCC(D)=$P(^DGCR(399,IBIFN,"CC",IBCC,0),"^",1) D CONDN
     25 ;
     26 D PROC
     27 ;
     28 ;Q:'$D(^DGCR(399,IBIFN,"C"))  F I=0,"C" S IB(I)=$S($D(^DGCR(399,IBIFN,I)):^(I),1:"")
     29 ;I $P(IB(0),"^",9)=4 F I=1:1:3 S:$P(IB("C"),"^",I)'="" IBCPT(I)=$P(IB("C"),"^",I)
     30 ;I $P(IB(0),"^",9)=9 F I=4:1:6 S:$P(IB("C"),"^",I)'="" IBICD(I)=$P(IB("C"),"^",I)
     31 ;I $P(IB(0),"^",9)=5 F I=7:1:9 S:$P(IB("C"),"^",I)]"" IBHC(I)=$P(IB("C"),"^",I),IBHCN(I)=$S($D(^ICPT(IBHC(I),0)):$P(^(0),"^",1),1:"")
     32 Q
     33 ;
     345 ;Billing variables set
     35 D 123^IBCVA
     36EN5 I '$D(IBIP) G REVC
     37 S IBLS=$S($P(IB("U"),U,15)]"":$P(IB("U"),U,15),1:0),IBBS=$S($P(IB("U"),U,11)]"":$P(IB("U"),U,11),1:IBU) I IBBS'=IBU S IBBS=$P(^DGCR(399.1,IBBS,0),"^",1)
     38REVC S IBREV=0 F I=1:1 S IBREV=$O(^DGCR(399,IBIFN,"RC",IBREV)) Q:IBREV'?1.N  S IBREVC(I)=^DGCR(399,IBIFN,"RC",IBREV,0)
     39 S IBTF=$P(IB(0),U,26),IBTF=$S(IBTF=1:"ADMIT THRU DISCHARGE",IBTF=2:"FIRST CLAIM",IBTF=3:"CONTINUING CLAIM",IBTF=4:"LAST CLAIM",IBTF=5:"LATE CHARGE(S)",IBTF=6:"ADJUSTMENT",IBTF=7:"REPLACEMENT",IBTF=8:"CANCEL",IBTF=0:"ZERO CLAIM",1:"")
     40 S IBBTP1=$E($$EXPAND^IBTRE(399,.24,$P(IB(0),U,24)),1,29)
     41 S IBBTP2=$E($$EXPAND^IBTRE(399,.25,+$P(IB(0),U,25)),1,26)
     42 S IBBTP3=IBTF
     43 Q
     44SOCC S IBO(C)=$P(^DGCR(399,IBIFN,"OC",IBOC,0),"^",1),IBO(C)=$P(^DGCR(399.1,IBO(C),0),"^",2),IBOCN(C)=$P(^(0),"^",1)
     45 S IBOCD(C)=$P(^DGCR(399,IBIFN,"OC",IBOC,0),"^",2),IBOCD2(C)=$P(^DGCR(399,IBIFN,"OC",IBOC,0),"^",4) Q
     46 Q
     47 ;
     48CONDN S IBCC(D)=$P($G(^DGCR(399.1,+IBCC(D),0)),U,2),IBCCN(D)=$P($G(^(0)),U,1)
     49 Q
     50 ;
     51PROCX ; Entrypoint from output formatter
     52 N IBIFN,IBZ
     53 S IBIFN=$G(IBXIEN)
     54 D PROC
     55 D F^IBCEF("N-PROCEDURE CODING METHD","IBZ",,IBIFN)
     56 I IBZ="" K IBPROC S IBPROC=0 Q
     57 S Z=0 F  S Z=$O(IBPROC(Z)) Q:'Z  I $P(IBPROC(Z),U)'[$S(IBZ=9:";ICD",1:";ICP") K IBPROC(Z) S IBPROC=IBPROC-1
     58 Q
     59 ;
     60PROC ;  -build array of procedures in IBPROC
     61 N IBHCFA,IBMOD,I,J,X,X1
     62 S IBHCFA=($$FT^IBCEF(IBIFN)=2)
     63 K IBPROC S IBPROC=0
     64 I '$D(IB("C")) S IB("C")=$G(^DGCR(399,IBIFN,"C"))
     65 S:'$D(IB(0)) IB(0)=$G(^DGCR(399,IBIFN,0)) S J=$P($G(IB(0)),"^",9)
     66 I IB("C")'="" F I=1:1:9 I $P(IB("C"),"^",I)'="" S IBPROC(I)=$P(IB("C"),"^",I)_";"_$S(I<4:"ICPT(",I<7:"ICD0(",1:"ICPT(")_"^"_$P(IB("C"),"^",$S(I#3:10+(I#3),1:13)),IBPROC=IBPROC+1
     67 I $D(^DGCR(399,IBIFN,"CP")) S X=0 F I=100:1 S X=$O(^DGCR(399,IBIFN,"CP",X)) Q:'X  S X1=$G(^(X,0)) Q:'X1  D
     68 . S IBMOD=$$GETMOD^IBEFUNC(IBIFN,X)
     69 . I $TR(IBMOD,",")'="" S $P(X1,U,15)=IBMOD
     70 . S IBPROC($S($P(X1,"^",4):$P(X1,"^",4),1:I))=X1
     71 . I IBHCFA S IBPROC($S($P(X1,"^",4):$P(X1,"^",4),1:I),"AUX")=$G(^DGCR(399,IBIFN,"CP",X,"AUX"))
     72 . S IBPROC=IBPROC+1
     73PROCQ Q
     74 ;
     75ALLPROC(IBIFN,IBPROC) ; Returns all procedures for bill IBIFN in array IBPROC
     76 ;  IBPROC = # of procedures found
     77 ;  IBPROC(prnt order)=0-node of 'CP' entry with piece 15 = the
     78 ;                      modifiers separated by commas
     79 ;  IBPROC(prnt order,"AUX")="AUX" node of 'CP' entry for CMS-1500 forms
     80 ; Pass IBPROC by reference
     81 ;
     82 N IB
     83 K IBPROC
     84 D PROC
     85 Q
     86 ;
     87VC ;returns a bills value codes, IBIFN must be defined: IBVC=count,IBVC(VIFN)=CODE ^ NAME ^ VALUE ^ $$?
     88 N IBY,IBX,IBZ S IBVC=0 Q:'$D(^DGCR(399,IBIFN,"CV"))
     89 S IBX=0 F  S IBX=$O(^DGCR(399,IBIFN,"CV",IBX)) Q:'IBX  S IBY=$G(^DGCR(399,IBIFN,"CV",IBX,0)) I +IBY D
     90 . S IBVC=IBVC+1,IBZ=$G(^DGCR(399.1,+IBY,0)) Q:IBZ=""
     91 . S IBVC(+IBY)=$P(IBZ,U,2)_U_$P(IBZ,U,1)_U_$S(+$P(IBZ,U,12):$J($P(IBY,U,2),0,2),1:$P(IBY,U,2))_U_$P(IBZ,U,12)
     92 Q
     93 ;
     94SETMODS(IBMOD,IBZ,IBXSAVE) ; Set modifiers into IBXSAVE
     95 ; IBMOD = the list of modifier iens for the proc, separated by commas
     96 ; IBZ = the line counter to return the data in
     97 ;
     98 ; Output Formatter utility
     99 ;
     100 ; Variables passed by reference, returned
     101 ; IBXSAVE("PROCMODS",IBZ) = Formatter 'save' array for modifiers
     102 ;
     103 N Q,IBQ
     104 I $L(IBMOD) F Q=1:1:$L(IBMOD,",") I $P(IBMOD,",",Q)'="" D
     105 . S IBQ=$$MOD^ICPTMOD(+$P(IBMOD,",",Q),"I")
     106 . S IBXSAVE("PROCMODS",IBZ)=$G(IBXSAVE("PROCMODS",IBZ))_$P(IBQ,U,2)_","
     107 S Q=$L($G(IBXSAVE("PROCMODS",IBZ)))
     108 I 'Q S IBXSAVE("PROCMODS",IBZ)=""
     109 I Q S IBXSAVE("PROCMODS",IBZ)=$E(IBXSAVE("PROCMODS",IBZ),1,Q-1)
     110 Q
     111 ;

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJDB1.m

    r613 r623  
    1 IBJDB1  ;ALB/CPM - BILLING LAG TIME REPORT ; 27-DEC-96
    2         ;;2.0;INTEGRATED BILLING;**69,80,100,118,165**;21-MAR-94
    3         ;
    4 EN      ; - Option entry point.
    5         ;
    6         W !!,"This report measures the amount of time between significant"
    7         W !,"milestones which occur from the time treatment has been provided"
    8         W !,"to the time that the claim to the insurer for that treatment has"
    9         W !,"been closed out.",!
    10         ;
    11 DATE    D DATE^IBOUTL I IBBDT=""!(IBEDT="") G ENQ
    12         ;
    13         ; - Sort by division.
    14         S DIR(0)="Y",DIR("B")="NO"
    15         S DIR("A")="Do you wish to sort this report by division"
    16         S DIR("?")="^D HLP1^IBJDB1" W !
    17         D ^DIR K DIR I $D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) G ENQ
    18         S IBSORT=+Y K DIROUT,DTOUT,DUOUT,DIRUT
    19         ;
    20         ; - Issue prompt for division.
    21         I IBSORT D PSDR^IBODIV G:Y<0 ENQ
    22         ;
    23         ; - Select a Detailed or Summary report.
    24 DS      D DS^IBJD I "^"[IBRPT G ENQ
    25         I IBRPT="S" S IBSEL=",1,2,3,4,5,6,7,8,9,10,11," G DEV
    26         ;
    27 SEL     ; - Select main report or line item reports.
    28         W ! S DIR(0)="LO^1:11^K:+$P(X,""-"",2)>11 X"
    29         F X=1:1:11 S DIR("A",X)=$S(X<10:" ",1:"")_X_" - Print "_$$TITLE(X,1)
    30         S DIR("A",12)="",DIR("A")="Select",DIR("B")=1
    31         S DIR("?")="^D HLP2^IBJDB1" D ^DIR K DIR G:Y["^" ENQ S IBSEL=Y
    32         S DIR(0)="Y",DIR("A",1)="You have selected"
    33         I IBSEL="1,2,3,4,5,6,7,8,9,10,11," D
    34         .S DIR("A",1)=DIR("A",1)_" ALL the above reports."
    35         E  F X=1:1 S X1=$P(IBSEL,",",X) Q:'X1  S DIR("A",X+1)=" "_$$TITLE(X1,1)
    36         S DIR("A")="Are you sure",DIR("B")="NO"
    37         W ! D ^DIR K DIR G ENQ:Y["^",SEL:'Y S IBSEL=","_IBSEL
    38         ;
    39 DEV     W !!,"This report only requires an 80 column printer."
    40         ;
    41         W !!,"Note: This report searches through all Reimb. Insurance claims."
    42         W !?6,"You should queue this report to run after normal business hours."
    43         ;
    44         ; - Select a device.
    45         W ! S %ZIS="QM" D ^%ZIS G:POP ENQ
    46         I $D(IO("Q")) D  G ENQ
    47         .S ZTRTN="DQ^IBJDB1",ZTDESC="IB - BILLING LAG TIME REPORT"
    48         .F X="IB*","VAUTD","VAUTD(" S ZTSAVE(X)=""
    49         .D ^%ZTLOAD W !!,$S($D(ZTSK):"This job has been queued. The task number is "_ZTSK_".",1:"Unable to queue this job.")
    50         .K ZTSK,IO("Q") D HOME^%ZIS
    51         ;
    52         U IO
    53         ;
    54 DQ      ; - Tasked entry point.
    55         ;
    56         I $G(IBXTRACT) D E^IBJDE(10,1) ; Change extract status.
    57         ;
    58         K IBCT,IBTL,^TMP("IBJDB1",$J)
    59         S IBQ=0 D ^IBJDB11 I IBQ G ENQ ; Compile data for reports.
    60         ;
    61         ; - Extract summary data.
    62         I $G(IBXTRACT) D  G ENQ
    63         .S X=0 F Y=1:1:4,9,10,11,"2I","3I","4I" D
    64         ..S X=X+1,IB(X)=$J($S('IBCT(0,"OP",Y):0,1:IBTL(0,"OP",Y)/IBCT(0,"OP",Y)),0,2)
    65         .F Y=5:1:11,"6I","7I","8I" D
    66         ..S X=X+1,IB(X)=$J($S('IBCT(0,"IN",Y):0,1:IBTL(0,"IN",Y)/IBCT(0,"IN",Y)),0,2)
    67         .D E^IBJDE(10,0)
    68         ;
    69         ; - Print the reports.
    70         S IBQ=0
    71         S IBDIV="" F  S IBDIV=$S(IBRPT="D":$O(^TMP("IBJDB1",$J,IBDIV)),1:$O(IBCT(IBDIV))) Q:IBDIV=""  D  Q:IBQ
    72         .S IBPAG=0 D NOW^%DTC S IBRUN=$$DAT2^IBOUTL(%)
    73         .I IBRPT="D" D OPT^IBJDB12 I 'IBQ D INP^IBJDB13
    74         .I IBRPT="S" D SUM^IBJDB12
    75         ;
    76 ENQ     K ^TMP("IBJDB1",$J)
    77         I $D(ZTQUEUED) S ZTREQ="@" G ENQ1
    78         ;
    79         D ^%ZISC
    80 ENQ1    K IB,IBBDT,IBBN,IBEDT,IBCK,IBN,IBN0,IBRPT,IBPAG,IBQ,IBRUN,IBX,IBX1,IBX2
    81         K IBX3,IBAUTH,IBDAT,IBDFN,IBNU,IBPTF,IBPOL,IBPOL1,IBTY,IBS,IBSEL,IBSEL1
    82         K IBCT,IBDIV,IBSORT,IBTL,IBCHK,IBDCHK,DFN,POP,VAUTD,ZTDESC,ZTRTN,ZTSAVE
    83         K IBDR,IBH,DIROUT,DTOUT,DUOUT,DIRUT,%,%ZIS,D,X,X1,X2,Y,Y1,Z,Z1,Z2,Z3
    84         Q
    85         ;
    86 HLP1    ; - 'Sort by Division?' prompt.
    87         W !?1,"Enter a <CR> to print the report without regard to division,"
    88         W !?1,"or 'Y' to select those divisions for which a separate report"
    89         W !?1,"should be created. To quit this option, enter '^'."
    90         Q
    91         ;
    92 HLP2    ; - Line item report prompt.
    93         W !?1,"Select '1-11' (Response can be a single number, list or range,"
    94         W !?1,"e.g.: 1,3,5 or 2-6,10) to print up to 11 lag time reports based"
    95         W !?1,"on the line items of the lag time summary reports. To quit this"
    96         W !?1,"option, enter '^'."
    97         Q
    98         ;
    99 TITLE(X,Y)      ; - Display/print report titles.
    100         Q $P($T(TITLE1+X),";;",2)_$S(Y:$P($T(TITLE1+X),";;",3),1:"")
    101         ;
    102 TITLE1  ; - Line item titles.
    103         ;;Date of Care to Date of Check Out;; (Outpatient claims)
    104         ;;Date of Check Out to Date Claim Authorized;; (Outpatient claims)
    105         ;;Date of Care to Date of First Payment;; (Outpatient claims)
    106         ;;Date of Care to Date Receivable Closed;; (Outpatient claims)
    107         ;;Date of Discharge to Date PTF Transmitted;; (Inpatient claims)
    108         ;;Date PTF Transmitted to Date Claim Authorized;; (Inpatient claims)
    109         ;;Date of Discharge to Date of First Payment;; (Inpatient claims)
    110         ;;Date of Discharge to Date Receivable Closed;; (Inpatient claims)
    111         ;;Date Claim Authorized to Date Claim Activated
    112         ;;Date Claim Activated to Date of First Payment
    113         ;;Date of First Payment to Date Receivable Closed
     1IBJDB1 ;ALB/CPM - BILLING LAG TIME REPORT ; 27-DEC-96
     2 ;;2.0;INTEGRATED BILLING;**69,80,100,118**;21-MAR-94
     3 ;
     4EN ; - Option entry point.
     5 ;
     6 W !!,"This report measures the amount of time between significant"
     7 W !,"milestones which occur from the time treatment has been provided"
     8 W !,"to the time that the claim to the insurer for that treatment has"
     9 W !,"been closed out.",!
     10 ;
     11DATE D DATE^IBOUTL I IBBDT=""!(IBEDT="") G ENQ
     12 ;
     13 ; - Sort by division.
     14 S DIR(0)="Y",DIR("B")="NO"
     15 S DIR("A")="Do you wish to sort this report by division"
     16 S DIR("?")="^D HLP1^IBJDB1" W !
     17 D ^DIR K DIR I $D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) G ENQ
     18 S IBSORT=+Y K DIROUT,DTOUT,DUOUT,DIRUT
     19 ;
     20 ; - Issue prompt for division.
     21 I IBSORT D PSDR^IBODIV G:Y<0 ENQ
     22 ;
     23 ; - Select a Detailed or Summary report.
     24DS D DS^IBJD I "^"[IBRPT G ENQ
     25 I IBRPT="S" S IBSEL=",1,2,3,4,5,6,7,8,9,10,11," G DEV
     26 ;
     27SEL ; - Select main report or line item reports.
     28 W ! S DIR(0)="LO^1:11^K:+$P(X,""-"",2)>11 X"
     29 F X=1:1:11 S DIR("A",X)=$S(X<10:" ",1:"")_X_" - Print "_$$TITLE(X,1)
     30 S DIR("A",12)="",DIR("A")="Select",DIR("B")=1
     31 S DIR("?")="^D HLP2^IBJDB1" D ^DIR K DIR G:Y["^" ENQ S IBSEL=Y
     32 S DIR(0)="Y",DIR("A",1)="You have selected"
     33 I IBSEL="1,2,3,4,5,6,7,8,9,10,11," D
     34 .S DIR("A",1)=DIR("A",1)_" ALL the above reports."
     35 E  F X=1:1 S X1=$P(IBSEL,",",X) Q:'X1  S DIR("A",X+1)=" "_$$TITLE(X1,1)
     36 S DIR("A")="Are you sure",DIR("B")="NO"
     37 W ! D ^DIR K DIR G ENQ:Y["^",SEL:'Y S IBSEL=","_IBSEL
     38 ;
     39DEV W !!,"This report only requires an 80 column printer."
     40 ;
     41 W !!,"Note: This report searches through all Reimb. Insurance claims."
     42 W !?6,"You should queue this report to run after normal business hours."
     43 ;
     44 ; - Select a device.
     45 W ! S %ZIS="QM" D ^%ZIS G:POP ENQ
     46 I $D(IO("Q")) D  G ENQ
     47 .S ZTRTN="DQ^IBJDB1",ZTDESC="IB - BILLING LAG TIME REPORT"
     48 .F X="IB*","VAUTD","VAUTD(" S ZTSAVE(X)=""
     49 .D ^%ZTLOAD W !!,$S($D(ZTSK):"This job has been queued. The task number is "_ZTSK_".",1:"Unable to queue this job.")
     50 .K ZTSK,IO("Q") D HOME^%ZIS
     51 ;
     52 U IO
     53 ;
     54DQ ; - Tasked entry point.
     55 ;
     56 I $G(IBXTRACT) D E^IBJDE(10,1) ; Change extract status.
     57 ;
     58 K IBCT,IBTL,^TMP("IBJDB1",$J)
     59 S IBQ=0 D ^IBJDB11 I IBQ G ENQ ; Compile data for reports.
     60 ;
     61 ; - Extract summary data.
     62 I $G(IBXTRACT) D  G ENQ
     63 .S X=0 F Y=1:1:4,9,10,11,"2I","3I","4I" D
     64 ..S X=X+1,IB(X)=$J($S('IBCT(0,"OP",Y):0,1:IBTL(0,"OP",Y)/IBCT(0,"OP",Y)),0,2)
     65 .F Y=5:1:11,"6I","7I","8I" D
     66 ..S X=X+1,IB(X)=$J($S('IBCT(0,"IN",Y):0,1:IBTL(0,"IN",Y)/IBCT(0,"IN",Y)),0,2)
     67 .D E^IBJDE(10,0)
     68 ;
     69 ; - Print the reports.
     70 S IBQ=0
     71 S IBDIV="" F  S IBDIV=$S(IBRPT="D":$O(^TMP("IBJDB1",$J,IBDIV)),1:$O(IBCT(IBDIV))) Q:IBDIV=""  D  Q:IBQ
     72 .S IBPAG=0 D NOW^%DTC S IBRUN=$$DAT2^IBOUTL(%)
     73 .I IBRPT="D" D OPT^IBJDB12 I 'IBQ D INP^IBJDB13
     74 .I IBRPT="S" D SUM^IBJDB12
     75 ;
     76ENQ K ^TMP("IBJDB1",$J)
     77 I $D(ZTQUEUED) S ZTREQ="@" G ENQ1
     78 ;
     79 D ^%ZISC
     80ENQ1 K IB,IBBDT,IBEDT,IBCK,IBN,IBN0,IBRPT,IBPAG,IBQ,IBRUN,IBX,IBX1,IBX2,IBX3
     81 K IBAUTH,IBDAT,IBDFN,IBNU,IBPTF,IBPOL,IBPOL1,IBTY,IBS,IBSEL,IBSEL1,IBCT
     82 K IBDIV,IBSORT,IBTL,IBCHK,IBDCHK,DFN,POP,VAUTD,ZTDESC,ZTRTN,ZTSAVE
     83 K DIROUT,DTOUT,DUOUT,DIRUT,%,%ZIS,D,X,X1,X2,Y,Y1,Z,Z1,Z2,Z3
     84 Q
     85 ;
     86HLP1 ; - 'Sort by Division?' prompt.
     87 W !?1,"Enter a <CR> to print the report without regard to division,"
     88 W !?1,"or 'Y' to select those divisions for which a separate report"
     89 W !?1,"should be created. To quit this option, enter '^'."
     90 Q
     91 ;
     92HLP2 ; - Line item report prompt.
     93 W !?1,"Select '1-11' (Response can be a single number, list or range,"
     94 W !?1,"e.g.: 1,3,5 or 2-6,10) to print up to 11 lag time reports based"
     95 W !?1,"on the line items of the lag time summary reports. To quit this"
     96 W !?1,"option, enter '^'."
     97 Q
     98 ;
     99TITLE(X,Y) ; - Display/print report titles.
     100 Q $P($T(TITLE1+X),";;",2)_$S(Y:$P($T(TITLE1+X),";;",3),1:"")
     101 ;
     102TITLE1 ; - Line item titles.
     103 ;;Date of Care to Date of Check Out;; (Outpatient claims)
     104 ;;Date of Check Out to Date Claim Authorized;; (Outpatient claims)
     105 ;;Date of Care to Date of First Payment;; (Outpatient claims)
     106 ;;Date of Care to Date Receivable Closed;; (Outpatient claims)
     107 ;;Date of Discharge to Date PTF Transmitted;; (Inpatient claims)
     108 ;;Date PTF Transmitted to Date Claim Authorized;; (Inpatient claims)
     109 ;;Date of Discharge to Date of First Payment;; (Inpatient claims)
     110 ;;Date of Discharge to Date Receivable Closed;; (Inpatient claims)
     111 ;;Date Claim Authorized to Date Claim Activated
     112 ;;Date Claim Activated to Date of First Payment
     113 ;;Date of First Payment to Date Receivable Closed

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJDB11.m

    r613 r623  
    1 IBJDB11 ;ALB/CPM - BILLING LAG TIME REPORT (COMPILE) ; 27-DEC-96
    2         ;;2.0;INTEGRATED BILLING;**69,100,118,165**;21-MAR-94
    3         ;
    4 EN      ; - Entry point from IBJDB1.
    5         ;
    6         ; -
    7         I IBRPT="D" F X=2,3,4,6,7,8 S:IBSEL[X IBSEL=IBSEL_X_"I,"
    8         I 'IBSORT D INIT(0) G REV
    9         S X=0 F  S X=$S('VAUTD:$O(VAUTD(X)),1:$O(^DG(40.8,X))) Q:'X  D INIT(X)
    10         ;
    11 REV     ; - Review all claims in file #399.
    12         S IBN=0 F  S IBN=$O(^DGCR(399,IBN)) Q:'IBN  S IBN0=$G(^(IBN,0)) D  Q:IBQ
    13         .I IBN#100=0 S IBQ=$$STOP^IBOUTL("Billing Lag Time Report") Q:IBQ
    14         .;
    15         .I $P($G(^PRCA(430,IBN,0)),U,2)'=9 Q  ;              Not an RI claim.
    16         .I $P(IBN0,U,13)<3 Q  ;                              Not authorized.
    17         .I $P(IBN0,U,13)=7 Q  ;                              Cancelled in IB.
    18         .S X=$P($G(^PRCA(430,IBN,0)),U,8) I X=26!(X=39) Q  ; Cancelled in AR.
    19         .;
    20         .; - Does claim meet report criteria?
    21         .S IBAUTH=$$AUTH(IBN) I 'IBAUTH Q
    22         .;
    23         .; - Get division, if necessary.
    24         .I 'IBSORT S IBDIV=0
    25         .E  S IBDIV=$$DIV^IBJDF2(IBN) I 'IBDIV S IBDIV=+$$PRIM^VASITE()
    26         .I IBSORT,'VAUTD,'$D(VAUTD(IBDIV)) Q  ;  Not a selected division.
    27         .;
    28         .S IBTY=$S($P(IBN0,U,5)<3:"IN",1:"OP") ; Inpatient or outpatient claim?
    29         .;
    30         .;- Get date PTF transmitted.
    31         .S IBPTF="" I IBTY="IN" S IBPTF=$$PTF($P(IBN0,U,8)) Q:'IBPTF
    32         .;
    33         .; - Get other claim info and build date line.
    34         .S IBDAT=$P(IBAUTH,U,2,5),DFN=+$P(IBN0,U,2),IBDFN=$G(^DPT(DFN,0))
    35         .S IBPOL=+$G(^DPT(DFN,.312,+$P($G(^DGCR(399,IBN,"MP")),U,2),1))
    36         .;
    37         .; - Get care dates; quit if there are none.
    38         .K IBDR S IBNU=$G(^DGCR(399,IBN,"U")) D
    39         ..I IBTY="IN" S X=+$P(IBNU,U,2) S:'X X=+IBNU S:X IBDR(X)="" Q
    40         ..I '$D(^DGCR(399,IBN,"OP")) D  Q
    41         ...S X=+$P(IBNU,U,2) S:X IBDR(X)="" S:+IBNU&(+IBNU'=X) IBDR(+IBNU)=""
    42         ..S X=0 F  S X=$O(^DGCR(399,IBN,"OP",X)) Q:'X  S IBDR(X)=""
    43         .I '$D(IBDR) Q
    44         .;
    45         .; - Calculate statistics for each care date.
    46         .S IBX=0 F  S IBX=$O(IBDR(IBX)) Q:'IBX  D
    47         ..;
    48         ..; - Get discharge date.
    49         ..I IBTY="IN" D
    50         ...S IBX1=+$G(^DGPT(+$P(IBN0,U,8),70))\1 I IBX1 Q
    51         ...S IBX1=+$O(^DGPM("APTT3",DFN,(IBX-.0001)))\1 I 'IBX1 S IBX1=IBX
    52         ..;
    53         ..; - Get most recent check out date that has not been marked as non
    54         ..;   billable by Claims Tracking; quit if there isn't one.
    55         ..I IBTY="OP" D  K IBCL,IBCL1 Q:'IBCHK
    56         ...D CL(IBN) ;GET LIST OF CLINICS FOR THIS BILL
    57         ...S IBCHK=0,IBX1=IBX-.0001
    58         ...F  S IBX1=$O(^SCE("ADFN",DFN,IBX1)) Q:'IBX1!((IBX1\1)>IBX)  D
    59         ....S IBX2=0 F  S IBX2=$O(^SCE("ADFN",DFN,IBX1,IBX2)) Q:'IBX2  D
    60         .....;
    61         .....;CHECK TO SEE IF CLINICS MATCH
    62         .....S IBCL1=+$P($G(^SCE(IBX2,0)),U,4) Q:'$D(IBCL(IBCL1))
    63         .....I $P($G(^IBT(356,+$O(^IBT(356,"ASCE",IBX2,0)),0)),U,19) Q
    64         .....S IBX3=$P($G(^SCE(IBX2,0)),U,7)\1 I IBX3,IBX3'>$P(IBAUTH,U,2)  D
    65         ...... S:IBX3>IBCHK IBCHK=IBX3 Q
    66         ..;
    67         ..S X=$S(IBTY="IN":IBX1_U_+IBPTF,1:IBX_U_IBCHK)_U_IBDAT
    68         ..S IBPOL1=$S(IBPOL>+X:1,1:0) ; Policy found after treatment.
    69         ..;
    70         ..; - Check date line for at least one date within the user specified
    71         ..;   range; quit if there isn't any.
    72         ..S IBDCHK=0 F Y=2:1:6 I $$DL(0,$P(X,U,Y)) S IBDCHK=1 Q
    73         ..I 'IBDCHK Q
    74         ..;
    75         ..K D,Y,Z S IBSEL1=""
    76         ..F Y=1:1:5 S Z(1)=$P(X,U,Y),Z(2)=$P(X,U,Y+1) D
    77         ...;
    78         ...; - Check out date/PTF transmission date.
    79         ...I Y=1 D:Z(2)  Q
    80         ....S D(0)=$$FMDIFF^XLFDT(Z(2),Z(1)),Z=$S(IBTY="IN":5,1:1)
    81         ....I $$DL(Z,Z(2)) S IBSEL1=IBSEL1_Z_",",Y(Z)=$S(IBRPT="D":Z(1)_U_Z(2)_U_D(0),1:D(0))
    82         ...;
    83         ...; - Date authorized.
    84         ...I Y=2 D:Z(1)  Q
    85         ....S D(1)=$$FMDIFF^XLFDT(Z(2),Z(1)),Z=$S(IBTY="IN":6,1:2)
    86         ....I $$DL(Z,Z(2)) D
    87         .....S Z1=$S(IBPOL1:Z_"I",1:Z),IBSEL1=IBSEL1_Z1_",",Y(Z1)=$S(IBRPT="D":Z(1)_U_Z(2)_U_D(1),1:D(1))
    88         .....I Z1=Z D
    89         ......S Z2=Z_"I",IBSEL1=IBSEL1_Z2_",",Y(Z2)=$S(IBRPT="D":Z(1)_U_Z(2)_U_D(1),1:D(1))
    90         ...;
    91         ...; - Date activated.
    92         ...I Y=3 D:Z(2)  Q
    93         ....S D(2)=$$FMDIFF^XLFDT(Z(2),Z(1)) I $$DL(9,Z(2)) S IBSEL1=IBSEL1_"9,",Y(9)=$S(IBRPT="D":Z(1)_U_Z(2)_U_D(2),1:D(2))
    94         ...;
    95         ...; - Payment date.
    96         ...I Y=4 D:Z(2)  Q
    97         ....S D(3)=$$FMDIFF^XLFDT(Z(2),Z(1)),D(6)=$$FMDIFF^XLFDT(Z(2),+X)
    98         ....F Z=$S(IBTY="IN":7,1:3),10 I $$DL(Z,Z(2)) D
    99         .....S Z1=$S(IBPOL1&(Z<10):Z_"I",1:Z),Z2=$S(Z<10:6,1:3)
    100         .....S IBSEL1=IBSEL1_Z1_",",Y(Z1)=$S(IBRPT="D":$S(Z2=3:Z(1),1:+X)_U_Z(2)_U_D(Z2),1:D(Z2))
    101         .....I Z1=Z,Z<10 S Z3=Z_"I",IBSEL1=IBSEL1_Z3_",",Y(Z3)=$S(IBRPT="D":$S(Z2=3:Z(1),1:+X)_U_Z(2)_U_D(Z2),1:D(Z2))
    102         ...;
    103         ...; - Date closed.
    104         ...I Z(2) D
    105         ....S D(4)=$$FMDIFF^XLFDT(Z(2),Z(1)),D(5)=$$FMDIFF^XLFDT(Z(2),+X)
    106         ....F Z=$S(IBTY="IN":8,1:4),11 I $$DL(Z,Z(2)) D
    107         .....S Z1=$S(IBPOL1&(Z<11):Z_"I",1:Z),Z2=$S(Z<11:5,1:4)
    108         .....S IBSEL1=IBSEL1_Z1_",",Y(Z1)=$S(IBRPT="D":$S(Z2=4:Z(1),1:+X)_U_Z(2)_U_D(Z2),1:D(Z2))
    109         .....I Z1=Z,Z<11 S Z3=Z_"I",IBSEL1=IBSEL1_Z3_",",Y(Z3)=$S(IBRPT="D":$S(Z2=4:Z(1),1:+X)_U_Z(2)_U_D(Z2),1:D(Z2))
    110         ..;
    111         ..; - Save data for detail or summary report(s).
    112         ..F Y=1:1 S Z=$P(IBSEL1,",",Y) Q:'Z  D
    113         ...I IBRPT="D" D
    114         ....S IBBN=$P(IBN0,U) S:IBPOL1 IBBN=IBBN_"*"
    115         ....S Y(Z)=IBBN_U_Y(Z),Y1(Z)=$G(Y1(Z))+1
    116         ....S ^TMP("IBJDB1",$J,IBDIV,IBTY,Z,$P(IBDFN,U)_"@@"_$P(IBDFN,U,9),Y1(Z))=Y(Z)
    117         ...E  S IBCT(IBDIV,IBTY,Z)=IBCT(IBDIV,IBTY,Z)+1,IBTL(IBDIV,IBTY,Z)=IBTL(IBDIV,IBTY,Z)+Y(Z)
    118         ;
    119         Q
    120         ;
    121 INIT(X) ; - Initialize summary accumulators/detail division nodes.
    122         I IBRPT="D" S ^TMP("IBJDB1",$J,X)="" Q
    123         F Y=1:1:4,9,10,11,"2I","3I","4I" S (IBCT(X,"OP",Y),IBTL(X,"OP",Y))=0
    124         F Y=5:1:11,"6I","7I","8I" S (IBCT(X,"IN",Y),IBTL(X,"IN",Y))=0
    125         Q
    126         ;
    127 AUTH(IBN)       ; - Is this an authorized claim?
    128         ;  Input: IBN=Pointer to the AR in file #430
    129         ; Output: VAL=1^2^3^4^5, where:
    130         ;             1=1-Authorized claim
    131         ;               0-Not an authorized claim
    132         ;             2=Date AR was authorized
    133         ;             3=Date AR was activated
    134         ;             4=AR first payment date
    135         ;             5=Date AR was closed
    136         ;
    137         N IBPAY,IBT,IBT0,IBT1,VAL,X
    138         S VAL=0 I '$G(IBN) G AUTHQ
    139         ;
    140         ; - Get date authorized (required).
    141         S X=$P($G(^DGCR(399,IBN,"S")),U,10) G:'X AUTHQ S VAL="1^"_X
    142         ;
    143         ; - Get date activated, if available.
    144         S X=$P($G(^PRCA(430,IBN,6)),U,21) I X S $P(VAL,U,3)=X\1 G FP
    145         S X=$P($G(^PRCA(430,IBN,9)),U,3) I X S $P(VAL,U,3)=X\1 G FP
    146         S X=$P($G(^PRCA(430,IBN,0)),U,10) I X S $P(VAL,U,3)=X\1
    147         ;
    148 FP      ; - Get first payment date, if available.
    149         I '$P($G(^PRCA(430,IBN,7)),U,7) G DC ; No payments made.
    150         S (IBPAY,IBT)=0 F  S IBT=$O(^PRCA(433,"C",IBN,IBT)) Q:'IBT  D  Q:IBPAY
    151         .S IBT0=$G(^PRCA(433,IBT,0)),IBT1=$G(^(1))
    152         .I $P(IBT0,U,4)'=2 Q  ;                  Not complete.
    153         .I $P(IBT1,U,2)'=2,$P(IBT1,U,2)'=34 Q  ; Not a payment.
    154         .S X=$S(+IBT1:+IBT1,1:$P(IBT1,U,9)\1),$P(VAL,U,4)=X,IBPAY=1
    155         ;
    156 DC      ; - Get date AR closed.
    157         S X=$$CLO^PRCAFN(IBN) I X>0 S $P(VAL,U,5)=X
    158         ;
    159         ; - Is there a payment date AND a closed date for this claim?
    160         I '$P(VAL,U,4),$P(VAL,U,5) S $P(VAL,U)=0
    161         ;
    162 AUTHQ   Q VAL
    163         ;
    164 DL(X,X1)        ; - Is line item date valid for report?
    165         ;  Input: X=Line item number (or 0), X1=Line item date
    166         ; Output: 1=valid, 0=invalid
    167         ; *Requires pre-defined variables IBBDT, IBEDT, and IBSEL
    168         S X2=0 I 'X1 G DLQ
    169         I 'X S:X1'<IBBDT&(X1'>IBEDT) X2=1 G DLQ
    170         I IBSEL[(","_X_","),X1'<IBBDT,X1'>IBEDT S X2=1
    171 DLQ     Q X2
    172         ;
    173         ;
    174 PTF(X)  ; - Get most recent PTF transmission date.
    175         ;    Input: X=IEN of PTF file entry.
    176         ;   Output: Y=PTF date.
    177         N I,K,Y
    178         S Y=0 G:'$O(^DGP(45.83,"C",+X,0)) PTFQ
    179         S I=0 F  S I=$O(^DGP(45.83,"C",X,I)) Q:'I  D
    180         .S J=$P($G(^DGP(45.83,I,0)),U,2)\1  Q:J>$P(IBAUTH,U,2)  S:J K(J)=""
    181         S I=0 F  S I=$O(K(I)) Q:'I  S Y=I
    182         ;
    183 PTFQ    Q Y
    184         ;
    185 CL(IBN) ; - Get the clinics for bill.
    186         N I,J K IBCL ; IBCL=Bill clinic array.
    187         S I=0 F  S I=$O(^DGCR(399,IBN,"CP",I)) Q:I=""  D
    188         .S J=$P($G(^DGCR(399,IBN,"CP",I,0)),U,7) S:J IBCL(J)=""
    189         Q
     1IBJDB11 ;ALB/CPM - BILLING LAG TIME REPORT (COMPILE) ; 27-DEC-96
     2 ;;2.0;INTEGRATED BILLING;**69,100,118**;21-MAR-94
     3 ;
     4EN ; - Entry point from IBJDB1.
     5 ;
     6 ; -
     7 I IBRPT="D" F X=2,3,4,6,7,8 S:IBSEL[X IBSEL=IBSEL_X_"I,"
     8 I 'IBSORT D INIT(0) G REV
     9 S X=0 F  S X=$S('VAUTD:$O(VAUTD(X)),1:$O(^DG(40.8,X))) Q:'X  D INIT(X)
     10 ;
     11REV ; - Review all claims in file #399.
     12 S IBN=0 F  S IBN=$O(^DGCR(399,IBN)) Q:'IBN  S IBN0=$G(^(IBN,0)) D  Q:IBQ
     13 .I IBN#100=0 S IBQ=$$STOP^IBOUTL("Billing Lag Time Report") Q:IBQ
     14 .;
     15 .I $P($G(^PRCA(430,IBN,0)),U,2)'=9 Q  ;              Not an RI claim.
     16 .I $P(IBN0,U,13)<3 Q  ;                              Not authorized.
     17 .I $P(IBN0,U,13)=7 Q  ;                              Cancelled in IB.
     18 .S X=$P($G(^PRCA(430,IBN,0)),U,8) I X=26!(X=39) Q  ; Cancelled in AR.
     19 .;
     20 .; - Does claim meet report criteria?
     21 .S IBAUTH=$$AUTH(IBN) I 'IBAUTH Q
     22 .;
     23 .; - Get division, if necessary.
     24 .I 'IBSORT S IBDIV=0
     25 .E  S IBDIV=$$DIV^IBJDF2(IBN) I 'IBDIV S IBDIV=+$$PRIM^VASITE()
     26 .I IBSORT,'VAUTD,'$D(VAUTD(IBDIV)) Q  ;  Not a selected division.
     27 .;
     28 .S IBTY=$S($P(IBN0,U,5)<3:"IN",1:"OP") ; Inpatient or outpatient claim?
     29 .;
     30 .; - Get most recent date PTF transmitted.
     31 .I IBTY="IN" D  Q:'IBPTF!('IBPTF&($P(IBAUTH,U,2)))
     32 ..S IBPTF=$P(IBN0,U,8) I 'IBPTF Q
     33 ..S IBPTF=$O(^DGP(45.83,"C",IBPTF,9999999),-1)\1 I IBPTF Q
     34 ..S IBPTF=$P($G(^DGP(45.83,IBPTF,0)),U,2)\1
     35 .;
     36 .; - Get other claim info and build date line.
     37 .S IBDAT=$P(IBAUTH,U,2,5),DFN=+$P(IBN0,U,2),IBDFN=$G(^DPT(DFN,0))
     38 .S IBPOL=+$G(^DPT(DFN,.312,+$P($G(^DGCR(399,IBN,"MP")),U,2),1))
     39 .;
     40 .; - Get care dates; quit if there are none.
     41 .K IBDR S IBNU=$G(^DGCR(399,IBN,"U")) D
     42 ..I IBTY="IN" S X=+$P(IBNU,U,2) S:'X X=+IBNU S:X IBDR(X)="" Q
     43 ..I '$D(^DGCR(399,IBN,"OP")) D  Q
     44 ...S X=+$P(IBNU,U,2) S:X IBDR(X)="" S:+IBNU&(+IBNU'=X) IBDR(+IBNU)=""
     45 ..S X=0 F  S X=$O(^DGCR(399,IBN,"OP",X)) Q:'X  S IBDR(X)=""
     46 .I '$D(IBDR) Q
     47 .;
     48 .; - Calculate statistics for each care date.
     49 .S IBX=0 F  S IBX=$O(IBDR(IBX)) Q:'IBX  D
     50 ..;
     51 ..; - Get discharge date.
     52 ..I IBTY="IN" D
     53 ...S IBX1=+$G(^DGPT(+$P(IBN0,U,8),70))\1 I IBX1 Q
     54 ...S IBX1=+$O(^DGPM("APTT3",DFN,(IBX-.0001)))\1 I 'IBX1 S IBX1=IBX
     55 ..;
     56 ..; - Get most recent check out date that has not been marked as non
     57 ..;   billable by Claims Tracking; quit if there isn't one.
     58 ..I IBTY="OP" D  Q:'IBCHK
     59 ...S IBCHK=0,IBX1=IBX-.0001
     60 ...F  S IBX1=$O(^SCE("ADFN",DFN,IBX1)) Q:'IBX1!((IBX1\1)>IBX)  D
     61 ....S IBX2=0 F  S IBX2=$O(^SCE("ADFN",DFN,IBX1,IBX2)) Q:'IBX2  D
     62 .....I $P($G(^IBT(356,+$O(^IBT(356,"ASCE",IBX2,0)),0)),U,19) Q
     63 .....S IBX3=$P($G(^SCE(IBX2,0)),U,7)\1 I IBX3 S IBCHK=IBX3
     64 ..;
     65 ..S X=$S(IBTY="IN":IBX1_U_IBPTF,1:IBX_U_IBCHK)_U_IBDAT
     66 ..S IBPOL1=$S(IBPOL>+X:1,1:0) ; Policy found after treatment.
     67 ..;
     68 ..; - Check date line for at least one date within the user specified
     69 ..;   range; quit if there isn't any.
     70 ..S IBDCHK=0 F Y=2:1:6 I $$DL(0,$P(X,U,Y)) S IBDCHK=1 Q
     71 ..I 'IBDCHK Q
     72 ..;
     73 ..K D,Y,Z S IBSEL1=""
     74 ..F Y=1:1:5 S Z(1)=$P(X,U,Y),Z(2)=$P(X,U,Y+1) D
     75 ...;
     76 ...; - Check out date/PTF transmission date.
     77 ...I Y=1 D:Z(2)  Q
     78 ....S D(0)=$$FMDIFF^XLFDT(Z(2),Z(1)),Z=$S(IBTY="IN":5,1:1)
     79 ....I $$DL(Z,Z(2)) S IBSEL1=IBSEL1_Z_",",Y(Z)=$S(IBRPT="D":Z(1)_U_Z(2)_U_D(0),1:D(0))
     80 ...;
     81 ...; - Date authorized.
     82 ...I Y=2 D:Z(1)  Q
     83 ....S D(1)=$$FMDIFF^XLFDT(Z(2),Z(1)),Z=$S(IBTY="IN":6,1:2)
     84 ....I $$DL(Z,Z(2)) D
     85 .....S Z1=$S(IBPOL1:Z_"I",1:Z),IBSEL1=IBSEL1_Z1_",",Y(Z1)=$S(IBRPT="D":Z(1)_U_Z(2)_U_D(1),1:D(1))
     86 .....I Z1=Z D
     87 ......S Z2=Z_"I",IBSEL1=IBSEL1_Z2_",",Y(Z2)=$S(IBRPT="D":Z(1)_U_Z(2)_U_D(1),1:D(1))
     88 ...;
     89 ...; - Date activated.
     90 ...I Y=3 D:Z(2)  Q
     91 ....S D(2)=$$FMDIFF^XLFDT(Z(2),Z(1)) I $$DL(9,Z(2)) S IBSEL1=IBSEL1_"9,",Y(9)=$S(IBRPT="D":Z(1)_U_Z(2)_U_D(2),1:D(2))
     92 ...;
     93 ...; - Payment date.
     94 ...I Y=4 D:Z(2)  Q
     95 ....S D(3)=$$FMDIFF^XLFDT(Z(2),Z(1)),D(6)=$$FMDIFF^XLFDT(Z(2),+X)
     96 ....F Z=$S(IBTY="IN":7,1:3),10 I $$DL(Z,Z(2)) D
     97 .....S Z1=$S(IBPOL1&(Z<10):Z_"I",1:Z),Z2=$S(Z<10:6,1:3)
     98 .....S IBSEL1=IBSEL1_Z1_",",Y(Z1)=$S(IBRPT="D":$S(Z2=3:Z(1),1:+X)_U_Z(2)_U_D(Z2),1:D(Z2))
     99 .....I Z1=Z,Z<10 S Z3=Z_"I",IBSEL1=IBSEL1_Z3_",",Y(Z3)=$S(IBRPT="D":$S(Z2=3:Z(1),1:+X)_U_Z(2)_U_D(Z2),1:D(Z2))
     100 ...;
     101 ...; - Date closed.
     102 ...I Z(2) D
     103 ....S D(4)=$$FMDIFF^XLFDT(Z(2),Z(1)),D(5)=$$FMDIFF^XLFDT(Z(2),+X)
     104 ....F Z=$S(IBTY="IN":8,1:4),11 I $$DL(Z,Z(2)) D
     105 .....S Z1=$S(IBPOL1&(Z<11):Z_"I",1:Z),Z2=$S(Z<11:5,1:4)
     106 .....S IBSEL1=IBSEL1_Z1_",",Y(Z1)=$S(IBRPT="D":$S(Z2=4:Z(1),1:+X)_U_Z(2)_U_D(Z2),1:D(Z2))
     107 .....I Z1=Z,Z<11 S Z3=Z_"I",IBSEL1=IBSEL1_Z3_",",Y(Z3)=$S(IBRPT="D":$S(Z2=4:Z(1),1:+X)_U_Z(2)_U_D(Z2),1:D(Z2))
     108 ..;
     109 ..; - Save data for detail or summary report(s).
     110 ..F Y=1:1 S Z=$P(IBSEL1,",",Y) Q:'Z  D
     111 ...I IBRPT="D" D
     112 ....S Y(Z)=$P(IBN0,U)_U_Y(Z)_U_$S(IBPOL1:"*",1:""),Y1(Z)=$G(Y1(Z))+1
     113 ....S ^TMP("IBJDB1",$J,IBDIV,IBTY,Z,$P(IBDFN,U)_"@@"_$P(IBDFN,U,9),Y1(Z))=Y(Z)
     114 ...E  S IBCT(IBDIV,IBTY,Z)=IBCT(IBDIV,IBTY,Z)+1,IBTL(IBDIV,IBTY,Z)=IBTL(IBDIV,IBTY,Z)+Y(Z)
     115 ;
     116 Q
     117 ;
     118INIT(X) ; - Initialize summary accumulators/detail division nodes.
     119 I IBRPT="D" S ^TMP("IBJDB1",$J,X)="" Q
     120 F Y=1:1:4,9,10,11,"2I","3I","4I" S (IBCT(X,"OP",Y),IBTL(X,"OP",Y))=0
     121 F Y=5:1:11,"6I","7I","8I" S (IBCT(X,"IN",Y),IBTL(X,"IN",Y))=0
     122 Q
     123 ;
     124AUTH(IBN) ; - Is this an authorized claim?
     125 ;  Input: IBN=Pointer to the AR in file #430
     126 ; Output: VAL=1^2^3^4^5, where:
     127 ;             1=1-Authorized claim
     128 ;               0-Not an authorized claim
     129 ;             2=Date AR was authorized
     130 ;             3=Date AR was activated
     131 ;             4=AR first payment date
     132 ;             5=Date AR was closed
     133 ;
     134 N IBPAY,IBT,IBT0,IBT1,VAL,X
     135 S VAL=0 I '$G(IBN) G AUTHQ
     136 ;
     137 ; - Get date authorized (required).
     138 S X=$P($G(^DGCR(399,IBN,"S")),U,10) G:'X AUTHQ S VAL="1^"_X
     139 ;
     140 ; - Get date activated, if available.
     141 S X=$P($G(^PRCA(430,IBN,6)),U,21) I X S $P(VAL,U,3)=X\1 G FP
     142 S X=$P($G(^PRCA(430,IBN,9)),U,3) I X S $P(VAL,U,3)=X\1 G FP
     143 S X=$P($G(^PRCA(430,IBN,0)),U,10) I X S $P(VAL,U,3)=X\1
     144 ;
     145FP ; - Get first payment date, if available.
     146 I '$P($G(^PRCA(430,IBN,7)),U,7) G CL ; No payments made.
     147 S (IBPAY,IBT)=0 F  S IBT=$O(^PRCA(433,"C",IBN,IBT)) Q:'IBT  D  Q:IBPAY
     148 .S IBT0=$G(^PRCA(433,IBT,0)),IBT1=$G(^(1))
     149 .I $P(IBT0,U,4)'=2 Q  ;                  Not complete.
     150 .I $P(IBT1,U,2)'=2,$P(IBT1,U,2)'=34 Q  ; Not a payment.
     151 .S X=$S(+IBT1:+IBT1,1:$P(IBT1,U,9)\1),$P(VAL,U,4)=X,IBPAY=1
     152 ;
     153CL ; - Get date AR closed.
     154 S X=$$CLO^PRCAFN(IBN) I X>0 S $P(VAL,U,5)=X
     155 ;
     156 ; - Is there a payment date AND a closed date for this claim?
     157 I '$P(VAL,U,4),$P(VAL,U,5) S $P(VAL,U)=0
     158 ;
     159AUTHQ Q VAL
     160 ;
     161DL(X,X1) ; - Is line item date valid for report?
     162 ;  Input: X=Line item number (or 0), X1=Line item date
     163 ; Output: 1=valid, 0=invalid
     164 ; *Requires pre-defined variables IBBDT, IBEDT, and IBSEL
     165 S X2=0 I 'X1 G DLQ
     166 I 'X S:X1'<IBBDT&(X1'>IBEDT) X2=1 G DLQ
     167 I IBSEL[(","_X_","),X1'<IBBDT,X1'>IBEDT S X2=1
     168DLQ Q X2

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJPS.m

    r613 r623  
    1 IBJPS   ;ALB/MAF,ARH - IBSP IB SITE PARAMETER SCREEN ;22-DEC-1995
    2         ;;2.0;INTEGRATED BILLING;**39,52,70,115,143,51,137,161,155,320,348,349,377**;21-MAR-94;Build 23
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5 EN      ; -- main entry point for IBJP IB SITE PARAMETERS, display IB site parameters
    6         D EN^VALM("IBJP IB SITE PARAMETERS")
    7         Q
    8         ;
    9 HDR     ; -- header code
    10         S VALMHDR(1)="Only authorized persons may edit this data."
    11         Q
    12         ;
    13 INIT    ; -- init variables and list array
    14         K ^TMP("IBJPS",$J),^TMP("IBJPSAX",$J)
    15         D BLD^IBJPS1
    16         Q
    17         ;
    18 HELP    ; -- help code
    19         S X="?" D DISP^XQORM1 W !!
    20         Q
    21         ;
    22 EXIT    ; -- exit code
    23         K ^TMP("IBJPS",$J),^TMP("IBJPSAX",$J)
    24         D CLEAR^VALM1
    25         Q
    26         ;
    27 NXEDIT  ; -- IBJP IB SITE PARAMETER EDIT ACTION (EP): Select data set to edit, do edit
    28         N VALMY,IBSELN,IBSET
    29         D EN^VALM2($G(XQORNOD(0)))
    30         I $D(VALMY) S IBSELN=0 F  S IBSELN=$O(VALMY(IBSELN)) Q:'IBSELN  D
    31         . S IBSET=$P($G(^TMP("IBJPSAX",$J,IBSELN)),U,1) Q:'IBSET
    32         . D EDIT(IBSET)
    33         S VALMBCK="R"
    34         Q
    35         ;
    36 EDIT(IBSET)     ; edit IB Site Parameters
    37         D FULL^VALM1
    38         I IBSET'="" S DR=$P($T(@IBSET),";;",2,999)
    39         I DR'="" S DIE="^IBE(350.9,",DA=1 D ^DIE K DA,DR,DIE,DIC,X,Y
    40         D INIT^IBJPS S VALMBCK="R"
    41         Q
    42         ;
    43 1       ;;.09;.13;.14
    44 2       ;;1.2;.15;.11;.12;7.04
    45 3       ;;1.09;1.07;2.07
    46 4       ;;4.04;6.25;6.24
    47 5       ;;.02;1.14;1.25;1.08
    48 6       ;;1.23;1.16;1.22;1.19;1.15;1.17
    49 7       ;;1.33;1.32;1.31;1.27
    50 8       ;;1.29;1.3;1.18;1.28
    51 9       ;;1.01;1.02;1.05
    52 10      ;;2.12;2.1;2.02;2.03;2.04;2.05;2.06;2.01
    53 11      ;;2.08;2.09
    54 12      ;;9.01;9.02;9.03;9.11;9.12;9.13;9.14;9.15
    55 13      ;;10.02;10.03;10.04;10.05;D INIT^IBATFILE
    56 14      ;;2.11;8.01;8.09;8.03;8.06;8.04;8.07;8.02;8.12T;8.11T
    57 15      ;;50.01;50.02;50.05;50.06;50.03;50.04;50.07
    58         ;
    59         ;
    60 ADD(IBLN,LNG,ARR)       ; output array of address in X, line length=LNG
    61         N IBCNT,IBI,IBY,IBX,IBZ K ARR S IBCNT=1
    62         F IBI=2:1:4 S IBY=$P(IBLN,U,IBI) I IBY'="" D  S ARR(IBCNT)=IBY
    63         . S IBX=$G(ARR(IBCNT)) I IBI=4 S IBY=$P($G(^DIC(5,+IBY,0)),U,2)_" "_$P(IBLN,U,5)
    64         . S IBZ=$S(IBX'="":IBX_", ",1:"")_IBY I $L(IBZ)'>LNG S IBY=IBZ Q
    65         . S IBCNT=IBCNT+1
    66         Q
     1IBJPS ;ALB/MAF,ARH - IBSP IB SITE PARAMETER SCREEN ;22-DEC-1995
     2 ;;2.0;INTEGRATED BILLING;**39,52,70,115,143,51,137,161,155,320,348,349**;21-MAR-94;Build 46
     3 ;;Per VHA Directive 2004-038, this routine should not be modified.
     4 ;
     5EN ; -- main entry point for IBJP IB SITE PARAMETERS, display IB site parameters
     6 D EN^VALM("IBJP IB SITE PARAMETERS")
     7 Q
     8 ;
     9HDR ; -- header code
     10 S VALMHDR(1)="Only authorized persons may edit this data."
     11 Q
     12 ;
     13INIT ; -- init variables and list array
     14 K ^TMP("IBJPS",$J),^TMP("IBJPSAX",$J)
     15 D BLD^IBJPS1
     16 Q
     17 ;
     18HELP ; -- help code
     19 S X="?" D DISP^XQORM1 W !!
     20 Q
     21 ;
     22EXIT ; -- exit code
     23 K ^TMP("IBJPS",$J),^TMP("IBJPSAX",$J)
     24 D CLEAR^VALM1
     25 Q
     26 ;
     27NXEDIT ; -- IBJP IB SITE PARAMETER EDIT ACTION (EP): Select data set to edit, do edit
     28 N VALMY,IBSELN,IBSET
     29 D EN^VALM2($G(XQORNOD(0)))
     30 I $D(VALMY) S IBSELN=0 F  S IBSELN=$O(VALMY(IBSELN)) Q:'IBSELN  D
     31 . S IBSET=$P($G(^TMP("IBJPSAX",$J,IBSELN)),U,1) Q:'IBSET
     32 . D EDIT(IBSET)
     33 S VALMBCK="R"
     34 Q
     35 ;
     36EDIT(IBSET) ; edit IB Site Parameters
     37 D FULL^VALM1
     38 I IBSET'="" S DR=$P($T(@IBSET),";;",2,999)
     39 I DR'="" S DIE="^IBE(350.9,",DA=1 D ^DIE K DA,DR,DIE,DIC,X,Y
     40 D INIT^IBJPS S VALMBCK="R"
     41 Q
     42 ;
     431 ;;.09;.13;.14
     442 ;;1.2;.15;.11;.12;7.04
     453 ;;1.09;1.07;2.07
     464 ;;4.04;6.25;6.24
     475 ;;.02;1.14;1.25;1.08
     486 ;;1.23;1.16;1.22;1.19;1.15;1.17
     497 ;;1.33;1.32;1.31;1.27
     508 ;;1.29;1.3;1.18;1.28
     519 ;;1.01;1.02;1.05;1.04
     5210 ;;2.12;2.1;2.02;2.03;2.04;2.05;2.06;2.01
     5311 ;;2.08;2.09
     5412 ;;9.01;9.02;9.03;9.11;9.12;9.13;9.14;9.15
     5513 ;;10.02;10.03;10.04;10.05;D INIT^IBATFILE
     5614 ;;2.11;8.01;8.09;8.03;8.06;8.04;8.07;8.02;8.12T;8.11T
     5715 ;;50.01;50.02;50.05;50.06;50.03;50.04;50.07
     58 ;
     59 ;
     60ADD(IBLN,LNG,ARR) ; output array of address in X, line length=LNG
     61 N IBCNT,IBI,IBY,IBX,IBZ K ARR S IBCNT=1
     62 F IBI=2:1:4 S IBY=$P(IBLN,U,IBI) I IBY'="" D  S ARR(IBCNT)=IBY
     63 . S IBX=$G(ARR(IBCNT)) I IBI=4 S IBY=$P($G(^DIC(5,+IBY,0)),U,2)_" "_$P(IBLN,U,5)
     64 . S IBZ=$S(IBX'="":IBX_", ",1:"")_IBY I $L(IBZ)'>LNG S IBY=IBZ Q
     65 . S IBCNT=IBCNT+1
     66 Q

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJPS2.m

    r613 r623  
    1 IBJPS2  ;ALB/MAF,ARH - IBSP IB SITE PARAMETER BUILD (cont) ;22-DEC-1995
    2         ;;2.0;INTEGRATED BILLING;**39,52,115,143,51,137,161,155,320,348,349,377**;21-MAR-94;Build 23
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5 BLD2    ; - continue build screen array for IB parameters
    6         ;
    7         N Z,Z0
    8         D RIGHT(1,1,1) ; - facility/med center  (new line for each)
    9         S IBLN=$$SET("Medical Center",$$EXSET^IBJU1($P(IBPD0,U,2),350.9,.02),IBLN,IBLR,IBSEL)
    10         S IBLN=$$SET("MAS Service",$$EXSET^IBJU1($P(IBPD1,U,14),350.9,1.14),IBLN,IBLR,IBSEL)
    11         ;
    12         D LEFT(2)
    13         S IBLN=$$SET("Default Division",$$EXSET^IBJU1($P(IBPD1,U,25),350.9,1.25),IBLN,IBLR,IBSEL)
    14         S IBLN=$$SET("Billing Supervisor",$$EXSET^IBJU1($P(IBPD1,U,8),350.9,1.08),IBLN,IBLR,IBSEL)
    15         ;
    16         D RIGHT(1,1,1)
    17         S IBLN=$$SET("Initiator Authorize",$$YN(+$P(IBPD1,U,23)),IBLN,IBLR,IBSEL)
    18         S IBLN=$$SET("Ask HINQ in MCCR",$$YN(+$P(IBPD1,U,16)),IBLN,IBLR,IBSEL)
    19         S IBLN=$$SET("Multiple Form Types",$$YN(+$P(IBPD1,U,22)),IBLN,IBLR,IBSEL)
    20         ;
    21         D LEFT(2)
    22         S IBLN=$$SET("Xfer Proc to Sched",$$YN(+$P(IBPD1,U,19)),IBLN,IBLR,IBSEL)
    23         S IBLN=$$SET("Use Non-PTF Codes",$$YN(+$P(IBPD1,U,15)),IBLN,IBLR,IBSEL)
    24         S IBLN=$$SET("Use OP CPT screen",$$YN(+$P(IBPD1,U,17)),IBLN,IBLR,IBSEL)
    25         ;
    26         ; IB patch 349 for UB-04 claim form and parameters
    27         D RIGHT(1,1,1)
    28         S IBLN=$$SET("UB-04 Print IDs",$$EXSET^IBJU1($P(IBPD1,U,33),350.9,1.33),IBLN,IBLR,IBSEL)
    29         S IBLN=$$SET("CMS-1500 Print IDs",$$EXSET^IBJU1($P(IBPD1,U,32),350.9,1.32),IBLN,IBLR,IBSEL)
    30         ;
    31         D LEFT(2)
    32         S IBLN=$$SET("UB-04 Address Col",$P(IBPD1,U,31),IBLN,IBLR,IBSEL)
    33         S IBLN=$$SET("CMS-1500 Addr Col",$P(IBPD1,U,27),IBLN,IBLR,IBSEL)
    34         ;
    35         D RIGHT(1,1,1)
    36         S IBLN=$$SET("Default RX DX Cd",$$EXSET^IBJU1($P(IBPD1,U,29),350.9,1.29),IBLN,IBLR,IBSEL)
    37         S IBLN=$$SET("Default RX CPT Cd",$$EXSET^IBJU1($P(IBPD1,U,30),350.9,1.30),IBLN,IBLR,IBSEL)
    38         ;
    39         D LEFT(2)
    40         S IBLN=$$SET("Default ASC Rev Cd",$$EXSET^IBJU1($P(IBPD1,U,18),350.9,1.18),IBLN,IBLR,IBSEL)
    41         S IBLN=$$SET("Default RX Rev Cd",$$EXSET^IBJU1($P(IBPD1,U,28),350.9,1.28),IBLN,IBLR,IBSEL)
    42         ;
    43         D RIGHT(1,1,1)
    44         S IBLN=$$SET("Bill Signer Name","<No longer used>",IBLN,IBLR,IBSEL)
    45         S IBLN=$$SET("Bill Signer Title","<No longer used>",IBLN,IBLR,IBSEL)
    46         ;
    47         D LEFT(2)
    48         S IBLN=$$SET("Federal Tax #",$P(IBPD1,U,5),IBLN,IBLR,IBSEL)
    49         ;
    50         D RIGHT(3,1,1) ; - Remittance/Agent Cashier Address
    51         S IBLN=$$SET("Billing Facility is Another Facility",$$EXPAND^IBTRE(350.9,2.12,+$P(IBPD2,U,12)),IBLN,IBLR,IBSEL)
    52         S IBLN=$$SET("Billing Facility Name",$P(IBPD2,U,10),IBLN,IBLR,IBSEL)
    53         D ADD^IBJPS(IBPD2,IBSW(3),.IBX) D  K IBX
    54         . S IBT="Remittance Address",IBX=0 F  S IBX=$O(IBX(IBX)) Q:'IBX  D
    55         .. S IBLN=$$SET(IBT,IBX(IBX),IBLN,IBLR,IBSEL),IBT=""
    56         S IBLN=$$SET("Phone",$P(IBPD2,U,6),IBLN,IBLR,IBSEL)
    57         ;
    58         D RIGHT(3,1,1)
    59         S IBLN=$$SET("Inpt Health Summary",$$EXSET^IBJU1($P(IBPD2,U,8),350.9,2.08),IBLN,IBLR,IBSEL)
    60         S IBLN=$$SET("Opt Health Summary",$$EXSET^IBJU1($P(IBPD2,U,9),350.9,2.09),IBLN,IBLR,IBSEL)
    61         ;
    62         D RIGHT(5,1,1)
    63         S IBLN=$$SET("Rx Billing Port",$P(IBPD9,U),IBLN,IBLR,IBSEL)
    64         S IBLN=$$SET("AWP Update Port",$P(IBPD9,U,2),IBLN,IBLR,IBSEL)
    65         S IBLN=$$SET("TCP/IP Address",$P(IBPD9,U,3),IBLN,IBLR,IBSEL)
    66         S IBLN=$$SET("Task UCI/VOL",$P(IBPD9,U,11),IBLN,IBLR,IBSEL)
    67         S IBLN=$$SET("AWP Charge Set",$$EXSET^IBJU1($P(IBPD9,U,12),350.9,9.12),IBLN,IBLR,IBSEL)
    68         S IBLN=$$SET("Prescriber ID",$P(IBPD9,U,13),IBLN,IBLR,IBSEL)
    69         S IBLN=$$SET("DEA vs Presc.ID",$$YN($P(IBPD9,U,14)),IBLN,IBLR,IBSEL)
    70         S IBLN=$$SET("Calc comp code",$$YN($P(IBPD9,U,15)),IBLN,IBLR,IBSEL)
    71         ;
    72         D LEFT(6)
    73         S IBLN=$$SET("Prim Billing Task",$P(IBPD9,U,4),IBLN,IBLR,IBSEL)
    74         S IBLN=$$SET("Sec Billing Task",$P(IBPD9,U,5),IBLN,IBLR,IBSEL)
    75         S IBLN=$$SET("Prim AWP Upd Task",$P(IBPD9,U,6),IBLN,IBLR,IBSEL)
    76         S IBLN=$$SET("Sec AWP Upd Task",$P(IBPD9,U,7),IBLN,IBLR,IBSEL)
    77         S IBLN=$$SET("Task Started",$$DAT1^IBOUTL($P(IBPD9,U,8),1),IBLN,IBLR,IBSEL)
    78         S IBLN=$$SET("Task Last Ran",$$DAT1^IBOUTL($P(IBPD9,U,9),1),IBLN,IBLR,IBSEL)
    79         S IBLN=$$SET("Shutdown Tasks?",$$YN($P(IBPD9,U,10)),IBLN,IBLR,IBSEL)
    80         ;
    81         ; transfer pricing
    82         D RIGHT(1,1,1)
    83         S IBLN=$$SET("Inpatient TP Active ",$$YN(+$P(IBPD10,U,2)),IBLN,IBLR,IBSEL)
    84         S IBLN=$$SET("Outpatient TP Active",$$YN(+$P(IBPD10,U,3)),IBLN,IBLR,IBSEL)
    85         S IBLN=$$SET("Pharmacy TP Active  ",$$YN(+$P(IBPD10,U,4)),IBLN,IBLR,IBSEL)
    86         S IBLN=$$SET("Prosthetic TP Active",$$YN(+$P(IBPD10,U,5)),IBLN,IBLR,IBSEL)
    87         ;
    88         ; EDI/MRA parameters
    89         D RIGHT(7,1,1)
    90         N IBZ S IBZ=$P(IBPD8,U,3)
    91         S IBLN=$$SET(" EDI/MRA Activated",$$EXSET^IBJU1(+$P(IBPD8,U,10),350.9,8.1),IBLN,IBLR,IBSEL)
    92         S IBLN=$$SET(" EDI Contact Phone",$P(IBPD2,U,11),IBLN,IBLR,IBSEL)
    93         S IBLN=$$SET(" EDI 837 Live Transmit Queue",$P(IBPD8,U),IBLN,IBLR,IBSEL)
    94         S IBLN=$$SET(" EDI 837 Test Transmit Queue",$P(IBPD8,U,9),IBLN,IBLR,IBSEL)
    95         S IBLN=$$SET(" Auto-Txmt Bill Frequency",$S(IBZ:"Every"_$S(IBZ>1:" "_$P(IBPD8,U,3),1:""),1:"")_$S(IBZ:" Day"_$S(IBZ=1:"",1:"s"),1:"Never Run"),IBLN,IBLR,IBSEL)
    96         S IBLN=$$SET(" Hours To Auto-Transmit",$P(IBPD8,U,6),IBLN,IBLR,IBSEL)
    97         S IBLN=$$SET(" Max # Bills Per Batch",$P(IBPD8,U,4),IBLN,IBLR,IBSEL)
    98         S IBLN=$$SET(" Only Allow 1 Ins Co/Claim Batch?",$$EXPAND^IBTRE(350.9,8.07,+$P(IBPD8,U,7)),IBLN,IBLR,IBSEL)
    99         S IBLN=$$SET(" Last Auto-Txmt Run Date",$$DATE^IBJU1($P(IBPD8,U,5)),IBLN,IBLR,IBSEL)
    100         S IBLN=$$SET(" Days To Wait To Purge Msgs",$P(IBPD8,U,2),IBLN,IBLR,IBSEL)
    101         S IBLN=$$SET(" Allow MRA Processing?",$$YN(+$P(IBPD8,U,12)),IBLN,IBLR,IBSEL)
    102         S IBLN=$$SET(" Enable Automatic MRA Processing?",$$YN(+$P(IBPD8,U,11)),IBLN,IBLR,IBSEL)
    103         ;
    104         ; Ingenix ClaimsManager Information
    105         D RIGHT(9,1,1)
    106         S IBLN=$$SET("Are we using ClaimsManager?",$$YN(+$P(IBPD50,U,1)),IBLN,IBLR,IBSEL)
    107         S IBLN=$$SET("Is ClaimsManager working OK?",$$YN(+$P(IBPD50,U,2)),IBLN,IBLR,IBSEL)
    108         S IBLN=$$SET("ClaimsManager TCP/IP Address",$P(IBPD50,U,5),IBLN,IBLR,IBSEL)
    109         S IBCISOCK=$O(^IBE(350.9,1,50.06,"B",""))
    110         S IBLN=$$SET("ClaimsManager TCP/IP Ports",IBCISOCK,IBLN,IBLR,IBSEL)
    111         F  S IBCISOCK=$O(^IBE(350.9,1,50.06,"B",IBCISOCK)) Q:IBCISOCK=""  D
    112         . S IBLN=$$SET("",IBCISOCK,IBLN,IBLR,IBSEL)
    113         . Q
    114         S IBLN=$$SET("General Error MailGroup",$$EXSET^IBJU1($P(IBPD50,U,3),350.9,50.03),IBLN,IBLR,IBSEL)
    115         S IBLN=$$SET("Communication Error MailGroup",$$EXSET^IBJU1($P(IBPD50,U,4),350.9,50.04),IBLN,IBLR,IBSEL)
    116         S IBCIMFLG=$$EXTERNAL^DILFD(350.9,50.07,"",$P(IBPD50,U,7))
    117         I IBCIMFLG="" S IBCIMFLG="PRIORITY"
    118         S IBLN=$$SET("MailMan Messages",IBCIMFLG,IBLN,IBLR,IBSEL)
    119         ;
    120         Q
    121         ;
    122 SET(TTL,DATA,LN,LR,SEL,HDR)     ;
    123         N IBY,IBX,IBC S IBC=": " I TTL="" S IBC="  "
    124         S IBY=TTL_$J("",(IBTW(LR)-$L(TTL)-2))_$S('$G(HDR):IBC_DATA,1:""),IBX=$G(^TMP("IBJPS",$J,LN,0))
    125         S IBX=$$SETSTR^VALM1(IBY,IBX,IBTC(LR),(IBTW(LR)+IBSW(LR)))
    126         D SET1(IBX,LN,SEL)
    127         S LN=LN+1
    128         Q LN
    129         ;
    130 SET1(STR,LN,SEL,HI)     ; set up TMP array with screen data
    131         S ^TMP("IBJPS",$J,LN,0)=STR
    132         S ^TMP("IBJPS",$J,"IDX",LN,SEL)=""
    133         S ^TMP("IBJPSAX",$J,SEL)=SEL
    134         I $G(HI)'="" D CNTRL^VALM10(LN,1,4,IOINHI,IOINORM)
    135         ;I $G(RV) D CNTRL^VALM10(LN,6,19,IOUON,IOUOFF)
    136         Q
    137         ;
    138 YN(X)   Q $S(+X:"YES",1:"NO")
    139         ;
    140 RIGHT(LR,SEL,BL)        ; - reset control variables for right side of screen
    141         S IBLN=$S(IBLN>IBGRPE:IBLN,1:IBGRPE) I $G(BL) S IBLN=$$SET("","",IBLN,IBLR,IBSEL)
    142         S IBLR=$G(LR),IBGRPB=IBLN I +$G(SEL) S IBSEL=IBSEL+1 D SET1("["_IBSEL_"]",IBLN,IBSEL,1)
    143         Q
    144         ;
    145 LEFT(LR)        ; - reset control variables for left side of screen
    146         S IBLR=$G(LR),IBGRPE=IBLN,IBLN=IBGRPB
    147         Q
     1IBJPS2 ;ALB/MAF,ARH - IBSP IB SITE PARAMETER BUILD (cont) ;22-DEC-1995
     2 ;;2.0;INTEGRATED BILLING;**39,52,115,143,51,137,161,155,320,348,349**;21-MAR-94;Build 46
     3 ;;Per VHA Directive 2004-038, this routine should not be modified.
     4 ;
     5BLD2 ; - continue build screen array for IB parameters
     6 ;
     7 N Z,Z0
     8 D RIGHT(1,1,1) ; - facility/med center  (new line for each)
     9 S IBLN=$$SET("Medical Center",$$EXSET^IBJU1($P(IBPD0,U,2),350.9,.02),IBLN,IBLR,IBSEL)
     10 S IBLN=$$SET("MAS Service",$$EXSET^IBJU1($P(IBPD1,U,14),350.9,1.14),IBLN,IBLR,IBSEL)
     11 ;
     12 D LEFT(2)
     13 S IBLN=$$SET("Default Division",$$EXSET^IBJU1($P(IBPD1,U,25),350.9,1.25),IBLN,IBLR,IBSEL)
     14 S IBLN=$$SET("Billing Supervisor",$$EXSET^IBJU1($P(IBPD1,U,8),350.9,1.08),IBLN,IBLR,IBSEL)
     15 ;
     16 D RIGHT(1,1,1)
     17 S IBLN=$$SET("Initiator Authorize",$$YN(+$P(IBPD1,U,23)),IBLN,IBLR,IBSEL)
     18 S IBLN=$$SET("Ask HINQ in MCCR",$$YN(+$P(IBPD1,U,16)),IBLN,IBLR,IBSEL)
     19 S IBLN=$$SET("Multiple Form Types",$$YN(+$P(IBPD1,U,22)),IBLN,IBLR,IBSEL)
     20 ;
     21 D LEFT(2)
     22 S IBLN=$$SET("Xfer Proc to Sched",$$YN(+$P(IBPD1,U,19)),IBLN,IBLR,IBSEL)
     23 S IBLN=$$SET("Use Non-PTF Codes",$$YN(+$P(IBPD1,U,15)),IBLN,IBLR,IBSEL)
     24 S IBLN=$$SET("Use OP CPT screen",$$YN(+$P(IBPD1,U,17)),IBLN,IBLR,IBSEL)
     25 ;
     26 ; IB patch 349 for UB-04 claim form and parameters
     27 D RIGHT(1,1,1)
     28 S IBLN=$$SET("UB-04 Print IDs",$$EXSET^IBJU1($P(IBPD1,U,33),350.9,1.33),IBLN,IBLR,IBSEL)
     29 S IBLN=$$SET("CMS-1500 Print IDs",$$EXSET^IBJU1($P(IBPD1,U,32),350.9,1.32),IBLN,IBLR,IBSEL)
     30 ;
     31 D LEFT(2)
     32 S IBLN=$$SET("UB-04 Address Col",$P(IBPD1,U,31),IBLN,IBLR,IBSEL)
     33 S IBLN=$$SET("CMS-1500 Addr Col",$P(IBPD1,U,27),IBLN,IBLR,IBSEL)
     34 ;
     35 D RIGHT(1,1,1)
     36 S IBLN=$$SET("Default RX DX Cd",$$EXSET^IBJU1($P(IBPD1,U,29),350.9,1.29),IBLN,IBLR,IBSEL)
     37 S IBLN=$$SET("Default RX CPT Cd",$$EXSET^IBJU1($P(IBPD1,U,30),350.9,1.30),IBLN,IBLR,IBSEL)
     38 ;
     39 D LEFT(2)
     40 S IBLN=$$SET("Default ASC Rev Cd",$$EXSET^IBJU1($P(IBPD1,U,18),350.9,1.18),IBLN,IBLR,IBSEL)
     41 S IBLN=$$SET("Default RX Rev Cd",$$EXSET^IBJU1($P(IBPD1,U,28),350.9,1.28),IBLN,IBLR,IBSEL)
     42 ;
     43 D RIGHT(1,1,1)
     44 S IBLN=$$SET("Bill Signer Name","<No longer used>",IBLN,IBLR,IBSEL)
     45 S IBLN=$$SET("Bill Signer Title","<No longer used>",IBLN,IBLR,IBSEL)
     46 ;
     47 D LEFT(2)
     48 S IBLN=$$SET("Federal Tax #",$P(IBPD1,U,5),IBLN,IBLR,IBSEL)
     49 ;
     50 D RIGHT(3,"","")
     51 S IBLN=$$SET("Remark on Each Bill",$P(IBPD1,U,4),IBLN,IBLR,IBSEL)
     52 ;
     53 D RIGHT(3,1,1) ; - Remittance/Agent Cashier Address
     54 S IBLN=$$SET("Billing Facility is Another Facility",$$EXPAND^IBTRE(350.9,2.12,+$P(IBPD2,U,12)),IBLN,IBLR,IBSEL)
     55 S IBLN=$$SET("Billing Facility Name",$P(IBPD2,U,10),IBLN,IBLR,IBSEL)
     56 D ADD^IBJPS(IBPD2,IBSW(3),.IBX) D  K IBX
     57 . S IBT="Remittance Address",IBX=0 F  S IBX=$O(IBX(IBX)) Q:'IBX  D
     58 .. S IBLN=$$SET(IBT,IBX(IBX),IBLN,IBLR,IBSEL),IBT=""
     59 S IBLN=$$SET("Phone",$P(IBPD2,U,6),IBLN,IBLR,IBSEL)
     60 ;
     61 D RIGHT(3,1,1)
     62 S IBLN=$$SET("Inpt Health Summary",$$EXSET^IBJU1($P(IBPD2,U,8),350.9,2.08),IBLN,IBLR,IBSEL)
     63 S IBLN=$$SET("Opt Health Summary",$$EXSET^IBJU1($P(IBPD2,U,9),350.9,2.09),IBLN,IBLR,IBSEL)
     64 ;
     65 D RIGHT(5,1,1)
     66 S IBLN=$$SET("Rx Billing Port",$P(IBPD9,U),IBLN,IBLR,IBSEL)
     67 S IBLN=$$SET("AWP Update Port",$P(IBPD9,U,2),IBLN,IBLR,IBSEL)
     68 S IBLN=$$SET("TCP/IP Address",$P(IBPD9,U,3),IBLN,IBLR,IBSEL)
     69 S IBLN=$$SET("Task UCI/VOL",$P(IBPD9,U,11),IBLN,IBLR,IBSEL)
     70 S IBLN=$$SET("AWP Charge Set",$$EXSET^IBJU1($P(IBPD9,U,12),350.9,9.12),IBLN,IBLR,IBSEL)
     71 S IBLN=$$SET("Prescriber ID",$P(IBPD9,U,13),IBLN,IBLR,IBSEL)
     72 S IBLN=$$SET("DEA vs Presc.ID",$$YN($P(IBPD9,U,14)),IBLN,IBLR,IBSEL)
     73 S IBLN=$$SET("Calc comp code",$$YN($P(IBPD9,U,15)),IBLN,IBLR,IBSEL)
     74 ;
     75 D LEFT(6)
     76 S IBLN=$$SET("Prim Billing Task",$P(IBPD9,U,4),IBLN,IBLR,IBSEL)
     77 S IBLN=$$SET("Sec Billing Task",$P(IBPD9,U,5),IBLN,IBLR,IBSEL)
     78 S IBLN=$$SET("Prim AWP Upd Task",$P(IBPD9,U,6),IBLN,IBLR,IBSEL)
     79 S IBLN=$$SET("Sec AWP Upd Task",$P(IBPD9,U,7),IBLN,IBLR,IBSEL)
     80 S IBLN=$$SET("Task Started",$$DAT1^IBOUTL($P(IBPD9,U,8),1),IBLN,IBLR,IBSEL)
     81 S IBLN=$$SET("Task Last Ran",$$DAT1^IBOUTL($P(IBPD9,U,9),1),IBLN,IBLR,IBSEL)
     82 S IBLN=$$SET("Shutdown Tasks?",$$YN($P(IBPD9,U,10)),IBLN,IBLR,IBSEL)
     83 ;
     84 ; transfer pricing
     85 D RIGHT(1,1,1)
     86 S IBLN=$$SET("Inpatient TP Active ",$$YN(+$P(IBPD10,U,2)),IBLN,IBLR,IBSEL)
     87 S IBLN=$$SET("Outpatient TP Active",$$YN(+$P(IBPD10,U,3)),IBLN,IBLR,IBSEL)
     88 S IBLN=$$SET("Pharmacy TP Active  ",$$YN(+$P(IBPD10,U,4)),IBLN,IBLR,IBSEL)
     89 S IBLN=$$SET("Prosthetic TP Active",$$YN(+$P(IBPD10,U,5)),IBLN,IBLR,IBSEL)
     90 ;
     91 ; EDI/MRA parameters
     92 D RIGHT(7,1,1)
     93 N IBZ S IBZ=$P(IBPD8,U,3)
     94 S IBLN=$$SET(" EDI/MRA Activated",$$EXSET^IBJU1(+$P(IBPD8,U,10),350.9,8.1),IBLN,IBLR,IBSEL)
     95 S IBLN=$$SET(" EDI Contact Phone",$P(IBPD2,U,11),IBLN,IBLR,IBSEL)
     96 S IBLN=$$SET(" EDI 837 Live Transmit Queue",$P(IBPD8,U),IBLN,IBLR,IBSEL)
     97 S IBLN=$$SET(" EDI 837 Test Transmit Queue",$P(IBPD8,U,9),IBLN,IBLR,IBSEL)
     98 S IBLN=$$SET(" Auto-Txmt Bill Frequency",$S(IBZ:"Every"_$S(IBZ>1:" "_$P(IBPD8,U,3),1:""),1:"")_$S(IBZ:" Day"_$S(IBZ=1:"",1:"s"),1:"Never Run"),IBLN,IBLR,IBSEL)
     99 S IBLN=$$SET(" Hours To Auto-Transmit",$P(IBPD8,U,6),IBLN,IBLR,IBSEL)
     100 S IBLN=$$SET(" Max # Bills Per Batch",$P(IBPD8,U,4),IBLN,IBLR,IBSEL)
     101 S IBLN=$$SET(" Only Allow 1 Ins Co/Claim Batch?",$$EXPAND^IBTRE(350.9,8.07,+$P(IBPD8,U,7)),IBLN,IBLR,IBSEL)
     102 S IBLN=$$SET(" Last Auto-Txmt Run Date",$$DATE^IBJU1($P(IBPD8,U,5)),IBLN,IBLR,IBSEL)
     103 S IBLN=$$SET(" Days To Wait To Purge Msgs",$P(IBPD8,U,2),IBLN,IBLR,IBSEL)
     104 S IBLN=$$SET(" Allow MRA Processing?",$$YN(+$P(IBPD8,U,12)),IBLN,IBLR,IBSEL)
     105 S IBLN=$$SET(" Enable Automatic MRA Processing?",$$YN(+$P(IBPD8,U,11)),IBLN,IBLR,IBSEL)
     106 ;
     107 ; Ingenix ClaimsManager Information
     108 D RIGHT(9,1,1)
     109 S IBLN=$$SET("Are we using ClaimsManager?",$$YN(+$P(IBPD50,U,1)),IBLN,IBLR,IBSEL)
     110 S IBLN=$$SET("Is ClaimsManager working OK?",$$YN(+$P(IBPD50,U,2)),IBLN,IBLR,IBSEL)
     111 S IBLN=$$SET("ClaimsManager TCP/IP Address",$P(IBPD50,U,5),IBLN,IBLR,IBSEL)
     112 S IBCISOCK=$O(^IBE(350.9,1,50.06,"B",""))
     113 S IBLN=$$SET("ClaimsManager TCP/IP Ports",IBCISOCK,IBLN,IBLR,IBSEL)
     114 F  S IBCISOCK=$O(^IBE(350.9,1,50.06,"B",IBCISOCK)) Q:IBCISOCK=""  D
     115 . S IBLN=$$SET("",IBCISOCK,IBLN,IBLR,IBSEL)
     116 . Q
     117 S IBLN=$$SET("General Error MailGroup",$$EXSET^IBJU1($P(IBPD50,U,3),350.9,50.03),IBLN,IBLR,IBSEL)
     118 S IBLN=$$SET("Communication Error MailGroup",$$EXSET^IBJU1($P(IBPD50,U,4),350.9,50.04),IBLN,IBLR,IBSEL)
     119 S IBCIMFLG=$$EXTERNAL^DILFD(350.9,50.07,"",$P(IBPD50,U,7))
     120 I IBCIMFLG="" S IBCIMFLG="PRIORITY"
     121 S IBLN=$$SET("MailMan Messages",IBCIMFLG,IBLN,IBLR,IBSEL)
     122 ;
     123 Q
     124 ;
     125SET(TTL,DATA,LN,LR,SEL,HDR) ;
     126 N IBY,IBX,IBC S IBC=": " I TTL="" S IBC="  "
     127 S IBY=TTL_$J("",(IBTW(LR)-$L(TTL)-2))_$S('$G(HDR):IBC_DATA,1:""),IBX=$G(^TMP("IBJPS",$J,LN,0))
     128 S IBX=$$SETSTR^VALM1(IBY,IBX,IBTC(LR),(IBTW(LR)+IBSW(LR)))
     129 D SET1(IBX,LN,SEL)
     130 S LN=LN+1
     131 Q LN
     132 ;
     133SET1(STR,LN,SEL,HI) ; set up TMP array with screen data
     134 S ^TMP("IBJPS",$J,LN,0)=STR
     135 S ^TMP("IBJPS",$J,"IDX",LN,SEL)=""
     136 S ^TMP("IBJPSAX",$J,SEL)=SEL
     137 I $G(HI)'="" D CNTRL^VALM10(LN,1,4,IOINHI,IOINORM)
     138 ;I $G(RV) D CNTRL^VALM10(LN,6,19,IOUON,IOUOFF)
     139 Q
     140 ;
     141YN(X) Q $S(+X:"YES",1:"NO")
     142 ;
     143RIGHT(LR,SEL,BL) ; - reset control variables for right side of screen
     144 S IBLN=$S(IBLN>IBGRPE:IBLN,1:IBGRPE) I $G(BL) S IBLN=$$SET("","",IBLN,IBLR,IBSEL)
     145 S IBLR=$G(LR),IBGRPB=IBLN I +$G(SEL) S IBSEL=IBSEL+1 D SET1("["_IBSEL_"]",IBLN,IBSEL,1)
     146 Q
     147 ;
     148LEFT(LR) ; - reset control variables for left side of screen
     149 S IBLR=$G(LR),IBGRPE=IBLN,IBLN=IBGRPB
     150 Q

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJTA1.m

    r613 r623  
    1 IBJTA1  ;ALB/ARH - TPI ACTIONS ;2/14/95
    2         ;;2.0;INTEGRATED BILLING;**39,137,377**;21-MAR-94;Build 23
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5 CP      ; -- IBJT CHANGE PATIENT action: change patient, only available on AL screen
    6         ;    user selects new patient, then Active Bills screen rebuilt with that patients active bills
    7         N VALMQUIT,IBDFN
    8         D FULL^VALM1
    9         S IBDFN=DFN S DFN=+$$PAT^IBJTU2 I 'DFN S DFN=IBDFN
    10         K ^TMP("IBJTLA",$J),^TMP("IBJTLAX",$J)
    11         D BLDA^IBJTLA1,HDR^IBJTLA
    12         S VALMBCK="R",VALMBG=1
    13 CPQ     Q
    14         ;
    15 CB      ; -- IBJT CHANGE BILL action: change bill, only available on CI screen
    16         ;    user enters new bill number then Claim Info screen rebuilt/redisplayed for that bill
    17         ;    if option entered through Active List screen then only allows bills for current patient
    18         N VALMQUIT,IBIFN1,IBDFN1
    19         D FULL^VALM1
    20         S IBDFN1=DFN,IBIFN1=IBIFN
    21         I $D(^TMP("IBJTLA",$J)) S DIC("S")="I $P(^(0),U,2)="_DFN
    22         S IBIFN=+$$BILL^IBJTU2 I 'IBIFN S IBIFN=IBIFN1
    23         S DFN=$P(^DGCR(399,+IBIFN,0),U,2)
    24         D CLEAN^VALM10 K IBXSAVE,IBXDATA D BLD^IBJTCA1,HDR^IBJTCA
    25         S VALMBCK="R",VALMBG=1
    26 CBQ     Q
    27         ;
    28 CDI     ; -- IBJT CHANGE DATES INACTIVE action: Change Date range for Inactive screen
    29         ;    user enters end date for search for inactive bills for a patient, Inactive Bills screen then rebuilt with
    30         ;    inactive bills for the patient and new date range,  IBEND passed to screen build
    31         ;    if IBBEG is defined the day before is used as the default end date, otherwise, today
    32         ;    this way the defaults will work backwards until end of bills, then restarts with today
    33         D FULL^VALM1
    34         S DIR("?",1)="Enter most recent date to include in list."
    35         S DIR("?")="A search for inactive bills for this patient will begin on the date entered and go back at least 6 months into the past.  If the patient has few bills then the search may span more than six months."
    36         S DIR("B")=$S(+$G(IBBEG):$$DATE^IBJU1($$FMADD^XLFDT(IBBEG,-1)),1:"TODAY")
    37         S DIR(0)="DO^::EX",DIR("A")="End Date"
    38         D ^DIR K DIR I 'Y!($D(DIRUT))!(Y=$G(IBEND)) S VALMSG="Date range was not changed." G CDIQ
    39         K ^TMP("IBJTLB",$J),^TMP("IBJTLBX",$J)
    40         S IBEND=Y D BLDA^IBJTLB1,HDR^IBJTLB
    41 CDIQ    S VALMBCK="R",VALMBG=1
    42         K VALMB,VALMBEG,VALMEND,DIRUT
    43         Q
    44         ;
    45 ARCA    ;  -- IBJT AR COMMENT ADD action:  add a comment transaction to the AR account, IBIFN required
    46         ;     IBARCOMM set to indicate AR Profile screen needs to be rebuilt when it is reentered
    47         ;     will cause the AR screen to be rebuilt including the new information if the AR screen is already open
    48         N AUTHDT,MRADT,STATUS,VALMQUIT,DIR
    49         D FULL^VALM1
    50         S STATUS=$P($G(^DGCR(399,IBIFN,0)),U,13)
    51         S AUTHDT=$P($G(^DGCR(399,IBIFN,"S")),U,10)
    52         S MRADT=$P($G(^DGCR(399,IBIFN,"S")),U,7)
    53         ; if claim status is "NOT REVIEWED" or claim status is "CANCELLED" with neither MRA request date
    54         ; nor Authorization date present, display an error and bail out.
    55         I STATUS=1!(STATUS=7&(MRADT="")&(AUTHDT="")) D  G ARCAQ
    56         .S DIR(0)="EA",DIR("A",1)="A comment can not be added for an incomplete or cancelled while incomplete claim.",DIR("A")="Press RETURN to continue: " D ^DIR K DIR
    57         ; if claim status is "REQUEST MRA" or claim status is "CANCELLED" with MRA request date present,
    58         ; but no Authorization date, enter MRA comments.
    59         I STATUS=2!(STATUS=7&(MRADT'="")&(AUTHDT="")) D:$G(IBIFN) CMNT^IBCECOB6 G ARCAR
    60         ; otherwise, enter AR comments.
    61         D ADJUST^RCJIBFN3(IBIFN)
    62         I $D(^TMP("IBJTTA",$J)) S IBARCOMM=1
    63         K ^TMP("IBJTTC",$J)
    64 ARCAR   ; rebuild comments screen
    65         D BLD^IBJTTC,HDR^IBJTTC
    66 ARCAQ   S VALMBCK="R",VALMBG=1
    67         Q
    68         ;
    69 HS      ; -- IBJT HS HEALTH SUMMARY action: health summary (inpt (350.9,2.08), outpt (350.9,2.09))
    70         ;    if a Health Summary has been defined for the type of care (Inpt/Outpt) it is printed to the screen
    71         ;    type of care is taken from the current bill if there is one otherwise the user is asked
    72         ;    requires HS 2.5 or greater, if 2.7 is available then a date range can be used
    73         ;    if date range used it is taken from the current bill if available otherwise askes user
    74         N X,Y,IBX,IBHS,DIR,DIRUT,IBIOPT,IBDT1,IBDT2,IBHSVER
    75         S (IBIOPT,IBHS)=0,IBHSVER=$$VERSION^XPDUTL("HEALTH SUMMARY")
    76         I IBHSVER<2.5 S VALMSG="Health Summary package not available." G HSQ
    77         D FULL^VALM1
    78         I +$G(IBIFN) D  I 'IBIOPT G HSQ
    79         . S IBX=$G(^DGCR(399,+IBIFN,0)) I '$G(DFN) S DFN=$P(IBX,U,2) I 'DFN Q
    80         . S IBIOPT=$S($P(IBX,U,5)<1:0,$P(IBX,U,5)<3:1,1:2)
    81         . S IBDT1=$G(^DGCR(399,+IBIFN,"U")),IBDT2=$P(IBDT1,U,2),IBDT1=+IBDT1
    82         ;
    83         I '$G(IBIFN) D  I 'IBIOPT G HSQ
    84         . S DIR(0)="SOB^I:Inpatient;O:Outpatient",DIR("A")="Inpatient or Outpatient Health Summary?" D ^DIR K DIR
    85         . S IBIOPT=$S(Y="I":1,Y="O":2,1:0) Q:'IBIOPT
    86         . ;
    87         . Q:IBHSVER<2.7
    88         . W !!,"Enter the date range the Health Summary should cover."
    89         . S IBDT1=$$DR^IBJTU2($$FMADD^XLFDT(DT,-365),DT),IBDT2=$P(IBDT1,U,2),IBDT1=+IBDT1
    90         ;
    91         S IBX=$G(^IBE(350.9,1,2)),IBHS=$S(IBIOPT=1:$P(IBX,U,8),1:$P(IBX,U,9))
    92         ;
    93         I 'IBHS S VALMSG="No Health Summary Type chosen for "_$S(IBIOPT=1:"In",1:"Out")_"patient." G HSQ
    94         I IBHSVER<2.7 D ENX^GMTSDVR(DFN,IBHS) G HSQ
    95         D ENX^GMTSDVR(DFN,IBHS,IBDT1,IBDT2)
    96 HSQ     S VALMBCK="R"
    97         Q
     1IBJTA1 ;ALB/ARH - TPI ACTIONS ;2/14/95
     2 ;;2.0;INTEGRATED BILLING;**39,137**;21-MAR-94
     3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
     4 ;
     5CP ; -- IBJT CHANGE PATIENT action: change patient, only available on AL screen
     6 ;    user selects new patient, then Active Bills screen rebuilt with that patients active bills
     7 N VALMQUIT,IBDFN
     8 D FULL^VALM1
     9 S IBDFN=DFN S DFN=+$$PAT^IBJTU2 I 'DFN S DFN=IBDFN
     10 K ^TMP("IBJTLA",$J),^TMP("IBJTLAX",$J)
     11 D BLDA^IBJTLA1,HDR^IBJTLA
     12 S VALMBCK="R",VALMBG=1
     13CPQ Q
     14 ;
     15CB ; -- IBJT CHANGE BILL action: change bill, only available on CI screen
     16 ;    user enters new bill number then Claim Info screen rebuilt/redisplayed for that bill
     17 ;    if option entered through Active List screen then only allows bills for current patient
     18 N VALMQUIT,IBIFN1,IBDFN1
     19 D FULL^VALM1
     20 S IBDFN1=DFN,IBIFN1=IBIFN
     21 I $D(^TMP("IBJTLA",$J)) S DIC("S")="I $P(^(0),U,2)="_DFN
     22 S IBIFN=+$$BILL^IBJTU2 I 'IBIFN S IBIFN=IBIFN1
     23 S DFN=$P(^DGCR(399,+IBIFN,0),U,2)
     24 D CLEAN^VALM10 K IBXSAVE,IBXDATA D BLD^IBJTCA1,HDR^IBJTCA
     25 S VALMBCK="R",VALMBG=1
     26CBQ Q
     27 ;
     28CDI ; -- IBJT CHANGE DATES INACTIVE action: Change Date range for Inactive screen
     29 ;    user enters end date for search for inactive bills for a patient, Inactive Bills screen then rebuilt with
     30 ;    inactive bills for the patient and new date range,  IBEND passed to screen build
     31 ;    if IBBEG is defined the day before is used as the default end date, otherwise, today
     32 ;    this way the defaults will work backwards until end of bills, then restarts with today
     33 D FULL^VALM1
     34 S DIR("?",1)="Enter most recent date to include in list."
     35 S DIR("?")="A search for inactive bills for this patient will begin on the date entered and go back at least 6 months into the past.  If the patient has few bills then the search may span more than six months."
     36 S DIR("B")=$S(+$G(IBBEG):$$DATE^IBJU1($$FMADD^XLFDT(IBBEG,-1)),1:"TODAY")
     37 S DIR(0)="DO^::EX",DIR("A")="End Date"
     38 D ^DIR K DIR I 'Y!($D(DIRUT))!(Y=$G(IBEND)) S VALMSG="Date range was not changed." G CDIQ
     39 K ^TMP("IBJTLB",$J),^TMP("IBJTLBX",$J)
     40 S IBEND=Y D BLDA^IBJTLB1,HDR^IBJTLB
     41CDIQ S VALMBCK="R",VALMBG=1
     42 K VALMB,VALMBEG,VALMEND,DIRUT
     43 Q
     44 ;
     45ARCA ;  -- IBJT AR COMMENT ADD action:  add a comment transaction to the AR account, IBIFN required
     46 ;     IBARCOMM set to indicate AR Profile screen needs to be rebuilt when it is reentered
     47 ;     will cause the AR screen to be rebuilt including the new information if the AR screen is already open
     48 N VALMQUIT,DIR
     49 D FULL^VALM1
     50 I $P($G(^DGCR(399,IBIFN,0)),U,13)=2 D  G ARCAQ
     51 . S DIR(0)="EA",DIR("A",1)="A/R comments cannot be added for a bill awaiting an MRA request",DIR("A")="Press RETURN to continue: " D ^DIR K DIR
     52 D ADJUST^RCJIBFN3(IBIFN)
     53 I $D(^TMP("IBJTTA",$J)) S IBARCOMM=1
     54 K ^TMP("IBJTTC",$J) D BLD^IBJTTC,HDR^IBJTTC
     55ARCAQ S VALMBCK="R",VALMBG=1
     56 Q
     57 ;
     58HS ; -- IBJT HS HEALTH SUMMARY action: health summary (inpt (350.9,2.08), outpt (350.9,2.09))
     59 ;    if a Health Summary has been defined for the type of care (Inpt/Outpt) it is printed to the screen
     60 ;    type of care is taken from the current bill if there is one otherwise the user is asked
     61 ;    requires HS 2.5 or greater, if 2.7 is available then a date range can be used
     62 ;    if date range used it is taken from the current bill if available otherwise askes user
     63 N X,Y,IBX,IBHS,DIR,DIRUT,IBIOPT,IBDT1,IBDT2,IBHSVER
     64 S (IBIOPT,IBHS)=0,IBHSVER=$$VERSION^XPDUTL("HEALTH SUMMARY")
     65 I IBHSVER<2.5 S VALMSG="Health Summary package not available." G HSQ
     66 D FULL^VALM1
     67 I +$G(IBIFN) D  I 'IBIOPT G HSQ
     68 . S IBX=$G(^DGCR(399,+IBIFN,0)) I '$G(DFN) S DFN=$P(IBX,U,2) I 'DFN Q
     69 . S IBIOPT=$S($P(IBX,U,5)<1:0,$P(IBX,U,5)<3:1,1:2)
     70 . S IBDT1=$G(^DGCR(399,+IBIFN,"U")),IBDT2=$P(IBDT1,U,2),IBDT1=+IBDT1
     71 ;
     72 I '$G(IBIFN) D  I 'IBIOPT G HSQ
     73 . S DIR(0)="SOB^I:Inpatient;O:Outpatient",DIR("A")="Inpatient or Outpatient Health Summary?" D ^DIR K DIR
     74 . S IBIOPT=$S(Y="I":1,Y="O":2,1:0) Q:'IBIOPT
     75 . ;
     76 . Q:IBHSVER<2.7
     77 . W !!,"Enter the date range the Health Summary should cover."
     78 . S IBDT1=$$DR^IBJTU2($$FMADD^XLFDT(DT,-365),DT),IBDT2=$P(IBDT1,U,2),IBDT1=+IBDT1
     79 ;
     80 S IBX=$G(^IBE(350.9,1,2)),IBHS=$S(IBIOPT=1:$P(IBX,U,8),1:$P(IBX,U,9))
     81 ;
     82 I 'IBHS S VALMSG="No Health Summary Type chosen for "_$S(IBIOPT=1:"In",1:"Out")_"patient." G HSQ
     83 I IBHSVER<2.7 D ENX^GMTSDVR(DFN,IBHS) G HSQ
     84 D ENX^GMTSDVR(DFN,IBHS,IBDT1,IBDT2)
     85HSQ S VALMBCK="R"
     86 Q

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJTBA.m

    r613 r623  
    1 IBJTBA  ;ALB/ARH - TPI BILL CHARGE INFO SCREEN ;01-MAR-1995
    2         ;;2.0;INTEGRATED BILLING;**39,80,51,137,135,309,349,389**;21-MAR-94;Build 6
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5 EN      ; -- main entry point for IBJ TP BILL CHARGES
    6         D EN^VALM("IBJT BILL CHARGES")
    7         Q
    8         ;
    9 HDR     ; -- header code
    10         D HDR^IBJTU1(+IBIFN,+DFN,12)
    11         Q
    12         ;
    13 INIT    ; -- init variables and list array
    14         N IBOK,IBEOBDET
    15         K ^TMP("IBJTBA",$J) N IBFT
    16         I '$G(DFN)!'$G(IBIFN) S VALMQUIT="" G INITQ
    17         S IBFT=+$P($G(^DGCR(399,+IBIFN,0)),U,19),IBOK=1
    18         I $D(^IBM(361.1,"B",IBIFN))!$D(^IBM(361.1,"C",IBIFN)) D  G:'IBOK INITQ
    19         . S DIR("A")="DO YOU WANT ALL EEOB DETAILS?: ",DIR("B")="NO",DIR(0)="YA"
    20         . D FULL^VALM1 W ! D ^DIR K DIR
    21         . I $D(DTOUT)!$D(DUOUT) S IBOK=0 Q
    22         . S IBEOBDET=+Y
    23         D BLD
    24 INITQ   Q
    25         ;
    26 MRA     ; -- mra/eob
    27         N IBI,Z,IBSTR,IBSHEOB,IBCT
    28         S IBCT=0
    29         S IBI=0 F  S IBI=$O(^IBM(361.1,"B",IBIFN,IBI)) Q:'IBI  S Z=+$O(^IBM(361.1,IBI,8,0)) I '$O(^(Z)) S IBCT=IBCT+1,IBSHEOB(IBI)=0  ; Entire EOB belongs to the bill
    30         S IBI=0 F  S IBI=$O(^IBM(361.1,"C",IBIFN,IBI)) Q:'IBI  S IBCT=IBCT+1,IBSHEOB(IBI)=1 ; EOB has been reapportioned at the site
    31         I 'IBCT D
    32         . S IBSTR=$$SETLN("No EEOB/MRA Information","",1,79)
    33         . S IBLN=$$SET(IBSTR,IBLN)
    34         I IBCT D
    35         . S Z=0
    36         . S IBI=0 F  S IBI=$O(IBSHEOB(IBI)) Q:'IBI  S Z=Z+1 D SHEOB^IBJTBA1(IBI,+IBSHEOB(IBI),Z,IBCT)
    37         ;
    38         Q
    39         ;
    40 HELP    ; -- help code
    41         S X="?" D DISP^XQORM1 W !!
    42         Q
    43         ;
    44 EXIT    ; -- exit code
    45         K ^TMP("IBJTBA",$J)
    46         D CLEAR^VALM1
    47         Q
    48         ;
    49 BLD     ; charges, as they would display on the bill
    50         N IBXDATA,IBXSAVE
    51         I $P($G(^DGCR(399,+IBIFN,0)),U,19)=2 D H1500 Q
    52         D UB04
    53         K ^TMP("IBXSAVE",$J)
    54         Q
    55         ;
    56 H1500   ; block 24
    57         N X,IBI,IBJ,IBLN,IBX,IBSTR,IBLKLN,IBPFORM,IBLIN
    58         K ^TMP("IBXSAVE",$J)
    59         S IBLIN=$$BOX24D^IBCEF11("",1),IBLKLN=0,IBLN=1
    60         Q:'$G(IBIFN)  K ^TMP("IBXDISP",$J)
    61         S IBPFORM=$S($P($G(^IBE(353,2,2)),U,8):$P(^(2),U,8),1:2),IBLN=1
    62         S IBX=$$BILLN^IBCEFG0(1,"1^99",IBLIN,+IBIFN,IBPFORM)
    63         S IBI=$O(^TMP("IBXDISP",$J,""),-1)
    64         S IBJ="" F  S IBJ=$O(^TMP("IBXDISP",$J,IBI,IBJ),-1) Q:$S('IBJ:1,1:$TR($G(^(IBJ))," ")'="")  K ^TMP("IBXDISP",$J,IBI,IBJ)
    65         I '$O(^TMP("IBXDISP",$J,IBI,0)) S VALMSG="No charges or procedures defined.",VALMQUIT="" G H1500Q
    66         S IBI="" F  S IBI=$O(^TMP("IBXDISP",$J,IBI)) Q:'IBI  S IBJ=0 F  S IBJ=$O(^TMP("IBXDISP",$J,IBI,IBJ)) Q:'IBJ  D
    67         . S IBX=$G(^TMP("IBXDISP",$J,IBI,IBJ)),IBLN=$$SET(IBX,IBLN)
    68         K ^TMP("IBXDISP",$J)
    69         D COB,MRA
    70         I $$ISRX^IBCEF1(IBIFN) D RX
    71         I $$ISPROS^IBCEF1(IBIFN) D PROS
    72         S VALMCNT=IBLN-1
    73 H1500Q  Q
    74         ;
    75 UB04    ;form locator 42-49,   IBIFN required
    76         N X,Y,DIR,IBI,IBJ,IBX,IBLN,IBLC,IBLIN,IBPFORM,IBSTATE,IBCBILL,IBINPAT,IBQ,Z,Z0
    77         K ^TMP("IBXSAVE",$J)
    78         S IBLIN=$$RCBOX^IBCEF11()
    79         S IBQ=0,IBLC=9 Q:'$G(IBIFN)  K ^TMP("IBXDISP",$J)
    80         S IBPFORM=$S($P($G(^IBE(353,3,2)),U,8):$P(^(2),U,8),1:3)
    81         S IBX=$$BILLN^IBCEFG0(1,"1^99",IBLIN,+IBIFN,IBPFORM)
    82         I '$O(^TMP("IBXDISP",$J,0)) S VALMSG="No charges defined.",VALMQUIT="" G UB04Q
    83         S Z="" F  S Z=$O(^TMP("IBXDISP",$J,1,Z),-1) Q:Z=""  S Z0=$G(^(Z)) Q:$TR(Z0," ")'=""  K ^(Z)
    84         S:Z ^TMP("IBXDISP",$J,1,Z+1)=" "
    85         S IBINPAT=$$INPAT^IBCEF(IBIFN,1)
    86         S IBSTATE=$G(^DGCR(399,IBIFN,"U")),IBCBILL=$G(^DGCR(399,IBIFN,0))
    87         ;
    88         S (VALMCNT,IBLN)=1,IBLKLN=0
    89         I +IBINPAT D  S IBLN=$$SET(IBSTR,IBLN)
    90         . S IBX=$P(IBSTATE,U,15),IBSTR=+IBX_" DAY"_$S(IBX'=1:"S",1:"")_" INPATIENT CARE"
    91         . S IBX=$$LOS^IBCU64(+IBSTATE,+$P(IBSTATE,U,2),+$P(IBCBILL,U,6)),IBX=IBX-$$LOS1^IBCU64(IBIFN) I IBX>0 S IBSTR=IBSTR_$J("Pass Days: "_IBX,55)
    92         ;
    93         S IBI="" F  S IBI=$O(^TMP("IBXDISP",$J,IBI)) Q:'IBI  S IBJ=0 F  S IBJ=$O(^TMP("IBXDISP",$J,IBI,IBJ)) Q:'IBJ  D
    94         . S IBX=$G(^TMP("IBXDISP",$J,IBI,IBJ)),IBLN=$$SET(IBX,IBLN)
    95         . I $E(IBX,1,3)="001" D COB
    96         ;
    97         K ^TMP("IBXDISP",$J)
    98         ;
    99         D MRA
    100         S VALMCNT=IBLN-1
    101 UB04Q   Q
    102         ;
    103 SETLN(STR,IBX,COL,WD)   ;
    104         S IBX=$$SETSTR^VALM1(STR,IBX,COL,WD)
    105         Q IBX
    106         ;
    107 SET(STR,LN)     ; set up TMP array with screen data (allows 2 blank lines, if not at end of array)
    108         N IBX,IBI I STR?80" " S IBLKLN=IBLKLN+1 G SETQ
    109         F IBI=1:1:IBLKLN D SET^VALM10(LN," ") S LN=LN+1 Q:IBI>1
    110         D SET^VALM10(LN,STR)
    111         S LN=LN+1,IBLKLN=0
    112 SETQ    Q LN
    113         ;
    114 COB     ; if there is an offset or a secondary/tertiary payer add it to the display, with ins co, and prior bill #
    115         ; IBIFN and IBLN must exist upon entry, IBLN is updated with new line count
    116         N IBM,IBM1,IBI,IBJ,IBD,IBSTR,IBCU2,IBCU1 Q:'$G(IBIFN)
    117         S IBM=$G(^DGCR(399,IBIFN,"M")),IBM1=$G(^DGCR(399,IBIFN,"M1"))
    118         S IBCU2=$G(^DGCR(399,IBIFN,"U2")),IBCU1=$G(^DGCR(399,IBIFN,"U1"))
    119         S IBJ=$P($G(^DGCR(399,IBIFN,0)),U,21),IBJ=$S(IBJ="P":3,IBJ="S":3,IBJ="T":3,1:0),IBSTR=""
    120         I +$P(IBM,U,2)!(+$P(IBM,U,3)) F IBI=1:1:IBJ I +$P(IBM,U,IBI) D  S IBLN=$$SET(IBSTR,IBLN)
    121         . I IBSTR="" S IBLN=$$SET("",IBLN)
    122         . S IBD=$S(IBI=1:"Primary",IBI=2:"Secondary",1:"Tertiary")_": " S IBSTR=$$SETLN(IBD,"",5,11)
    123         . S IBD=$P($G(^DIC(36,+$P(IBM,U,IBI),0)),U,1) S IBSTR=$$SETLN(IBD,IBSTR,17,25)
    124         . I $P(IBCU2,U,(IBI+3))'="" S IBD=$J(+$P(IBCU2,U,(IBI+3)),9,2) S IBSTR=$$SETLN(IBD,IBSTR,44,11)
    125         . I $P(IBM1,U,(IBI+4))'="" S IBD=$$BN1^PRCAFN(+$P(IBM1,U,(IBI+4))) S IBSTR=$$SETLN(IBD,IBSTR,60,11)
    126         I +$P(IBCU1,U,2) D  S IBLN=$$SET(IBSTR,IBLN)
    127         . I IBSTR="" S IBLN=$$SET("",IBLN)
    128         . S IBD="Offset: " S IBSTR=$$SETLN(IBD,"",5,11)
    129         . S IBD=$P(IBCU1,U,3) S IBSTR=$$SETLN(IBD,IBSTR,17,25)
    130         . S IBD=$J($P(IBCU1,U,2),9,2) S IBSTR=$$SETLN(IBD,IBSTR,44,11)
    131         . S IBD=$P(IBCU1,U,1)-$P(IBCU1,U,2),IBD="Billed: "_$J(IBD,0,2) S IBSTR=$$SETLN(IBD,IBSTR,60,17)
    132         Q
    133         ;
    134 RX      ;RX refill info for CMS-1500 TPJI display
    135         N Z,Z0,Z1,IBSPC,IBD,IBI,IBSTR,IBARRAY,IBRXX
    136         S IBLN=IBLN+1
    137         S IBSPC=$J("",5)
    138         D SET^IBCSC5A(IBIFN,.IBARRAY)
    139         I $D(IBARRAY) D
    140         . S (Z,Z0)=0 F  S Z0=$O(IBARRAY(Z0)) Q:Z0=""  S Z1=0 F  S Z1=$O(IBARRAY(Z0,Z1)) Q:'Z1  S Z=Z+1 S IBXDATA(Z)=$$DAT1^IBOUTL(Z1)_U_$G(IBARRAY(Z0,Z1))
    141         S IBD=$$SET("",IBLN)
    142         S IBD="PRESCRIPTION REFILLS: (For TPJI display only)"
    143         S IBSTR=$$SETLN(IBD,"",1,79),IBLN=$$SET(IBSTR,IBLN)
    144         S IBI=0 F  S IBI=$O(IBXDATA(IBI)) Q:IBI=""  D
    145         . S IBRXX=$G(IBXDATA(IBI))
    146         . D ZERO^IBRXUTL($P(IBRXX,U,3))
    147         . S IBD=$J($P(IBRXX,U,7),9,2)_IBSPC_$P(IBRXX,U)_IBSPC_$G(^TMP($J,"IBDRUG",+$P(IBRXX,U,3),.01))
    148         . K ^TMP($J,"IBDRUG")
    149         . S IBSTR=$$SETLN(IBD,"",1,79),IBLN=$$SET(IBSTR,IBLN)
    150         . S IBD="QTY: "_$P(IBRXX,U,5)_" for "_$P(IBRXX,U,4)_" days supply "_"NDC# "_$P(IBRXX,U,6)
    151         . S IBSTR=$$SETLN(IBD,"",23,79),IBLN=$$SET(IBSTR,IBLN)
    152         Q
    153         ;
    154 PROS    ;prosthetic info for CMS-1500 TPJI display
    155         N Z,Z0,Z1,IBARRAY,IBSPC,IBD,IBI,IBSTR
    156         S IBSPC=$J("",10),IBLN=IBLN+1
    157         D SET^IBCSC5B(IBIFN,.IBARRAY)
    158         I $D(IBARRAY) D
    159         . S (Z,Z0)=0 F  S Z0=$O(IBARRAY(Z0)) Q:Z0=""  S Z1=0 F  S Z1=$O(IBARRAY(Z0,Z1)) Q:'Z1  S Z=Z+1,IBXDATA(Z)=$$DAT1^IBOUTL(Z0)_U_$E($$PINB^IBCSC5B(+IBARRAY(Z0,Z1)),1,39)
    160         S IBD=$$SET("",IBLN)
    161         S IBD="PROSTHETIC REFILLS: (For TPJI display only)"
    162         S IBSTR=$$SETLN(IBD,"",1,79),IBLN=$$SET(IBSTR,IBLN)
    163         S IBI=0 F  S IBI=$O(IBXDATA(IBI)) Q:IBI=""  D
    164         . S IBD=$P(IBXDATA(IBI),U)_IBSPC_$P(IBXDATA(IBI),U,2)
    165         . S IBSTR=$$SETLN(IBD,"",1,79),IBLN=$$SET(IBSTR,IBLN)
    166         Q
    167         ;
     1IBJTBA ;ALB/ARH - TPI BILL CHARGE INFO SCREEN ;01-MAR-1995
     2 ;;2.0;INTEGRATED BILLING;**39,80,51,137,135,309,349**;21-MAR-94;Build 46
     3 ;;Per VHA Directive 2004-038, this routine should not be modified.
     4 ;
     5EN ; -- main entry point for IBJ TP BILL CHARGES
     6 D EN^VALM("IBJT BILL CHARGES")
     7 Q
     8 ;
     9HDR ; -- header code
     10 D HDR^IBJTU1(+IBIFN,+DFN,12)
     11 Q
     12 ;
     13INIT ; -- init variables and list array
     14 N IBOK,IBEOBDET
     15 K ^TMP("IBJTBA",$J) N IBFT
     16 I '$G(DFN)!'$G(IBIFN) S VALMQUIT="" G INITQ
     17 S IBFT=+$P($G(^DGCR(399,+IBIFN,0)),U,19),IBOK=1
     18 I $D(^IBM(361.1,"B",IBIFN))!$D(^IBM(361.1,"C",IBIFN)) D  G:'IBOK INITQ
     19 . S DIR("A")="DO YOU WANT ALL EEOB DETAILS?: ",DIR("B")="NO",DIR(0)="YA"
     20 . D FULL^VALM1 W ! D ^DIR K DIR
     21 . I $D(DTOUT)!$D(DUOUT) S IBOK=0 Q
     22 . S IBEOBDET=+Y
     23 D BLD
     24INITQ Q
     25 ;
     26MRA ; -- mra/eob
     27 N IBI,Z,IBSTR,IBSHEOB,IBCT
     28 S IBCT=0
     29 S IBI=0 F  S IBI=$O(^IBM(361.1,"B",IBIFN,IBI)) Q:'IBI  S Z=+$O(^IBM(361.1,IBI,8,0)) I '$O(^(Z)) S IBCT=IBCT+1,IBSHEOB(IBI)=0  ; Entire EOB belongs to the bill
     30 S IBI=0 F  S IBI=$O(^IBM(361.1,"C",IBIFN,IBI)) Q:'IBI  S IBCT=IBCT+1,IBSHEOB(IBI)=1 ; EOB has been reapportioned at the site
     31 I 'IBCT D
     32 . S IBSTR=$$SETLN("No EEOB/MRA Information","",1,79)
     33 . S IBLN=$$SET(IBSTR,IBLN)
     34 I IBCT D
     35 . S Z=0
     36 . S IBI=0 F  S IBI=$O(IBSHEOB(IBI)) Q:'IBI  S Z=Z+1 D SHEOB^IBJTBA1(IBI,+IBSHEOB(IBI),Z,IBCT)
     37 ;
     38 Q
     39 ;
     40HELP ; -- help code
     41 S X="?" D DISP^XQORM1 W !!
     42 Q
     43 ;
     44EXIT ; -- exit code
     45 K ^TMP("IBJTBA",$J)
     46 D CLEAR^VALM1
     47 Q
     48 ;
     49BLD ; charges, as they would display on the bill
     50 N IBXDATA,IBXSAVE
     51 I $P($G(^DGCR(399,+IBIFN,0)),U,19)=2 D H1500 Q
     52 D UB04
     53 K ^TMP("IBXSAVE",$J)
     54 Q
     55 ;
     56H1500 ; block 24
     57 N X,IBI,IBJ,IBLN,IBX,IBSTR,IBLKLN,IBPFORM,IBLIN
     58 K ^TMP("IBXSAVE",$J)
     59 S IBLIN=$$BOX24D^IBCEF11("",1),IBLKLN=0,IBLN=1
     60 Q:'$G(IBIFN)  K ^TMP("IBXDISP",$J)
     61 S IBPFORM=$S($P($G(^IBE(353,2,2)),U,8):$P(^(2),U,8),1:2),IBLN=1
     62 S IBX=$$BILLN^IBCEFG0(1,"1^99",IBLIN,+IBIFN,IBPFORM)
     63 S IBI=$O(^TMP("IBXDISP",$J,""),-1)
     64 S IBJ="" F  S IBJ=$O(^TMP("IBXDISP",$J,IBI,IBJ),-1) Q:$S('IBJ:1,1:$TR($G(^(IBJ))," ")'="")  K ^TMP("IBXDISP",$J,IBI,IBJ)
     65 I '$O(^TMP("IBXDISP",$J,IBI,0)) S VALMSG="No charges or procedures defined.",VALMQUIT="" G H1500Q
     66 S IBI="" F  S IBI=$O(^TMP("IBXDISP",$J,IBI)) Q:'IBI  S IBJ=0 F  S IBJ=$O(^TMP("IBXDISP",$J,IBI,IBJ)) Q:'IBJ  D
     67 . S IBX=$G(^TMP("IBXDISP",$J,IBI,IBJ)),IBLN=$$SET(IBX,IBLN)
     68 K ^TMP("IBXDISP",$J)
     69 D COB,MRA
     70 I $$ISRX^IBCEF1(IBIFN) D RX
     71 I $$ISPROS^IBCEF1(IBIFN) D PROS
     72 S VALMCNT=IBLN-1
     73H1500Q Q
     74 ;
     75UB04 ;form locator 42-49,   IBIFN required
     76 N X,Y,DIR,IBI,IBJ,IBX,IBLN,IBLC,IBLIN,IBPFORM,IBSTATE,IBCBILL,IBINPAT,IBQ,Z,Z0
     77 K ^TMP("IBXSAVE",$J)
     78 S IBLIN=$$RCBOX^IBCEF11()
     79 S IBQ=0,IBLC=9 Q:'$G(IBIFN)  K ^TMP("IBXDISP",$J)
     80 S IBPFORM=$S($P($G(^IBE(353,3,2)),U,8):$P(^(2),U,8),1:3)
     81 S IBX=$$BILLN^IBCEFG0(1,"1^99",IBLIN,+IBIFN,IBPFORM)
     82 I '$O(^TMP("IBXDISP",$J,0)) S VALMSG="No charges defined.",VALMQUIT="" G UB04Q
     83 S Z="" F  S Z=$O(^TMP("IBXDISP",$J,1,Z),-1) Q:Z=""  S Z0=$G(^(Z)) Q:$TR(Z0," ")'=""  K ^(Z)
     84 S:Z ^TMP("IBXDISP",$J,1,Z+1)=" "
     85 S IBINPAT=$$INPAT^IBCEF(IBIFN,1)
     86 S IBSTATE=$G(^DGCR(399,IBIFN,"U")),IBCBILL=$G(^DGCR(399,IBIFN,0))
     87 ;
     88 S (VALMCNT,IBLN)=1,IBLKLN=0
     89 I +IBINPAT D  S IBLN=$$SET(IBSTR,IBLN)
     90 . S IBX=$P(IBSTATE,U,15),IBSTR=+IBX_" DAY"_$S(IBX'=1:"S",1:"")_" INPATIENT CARE"
     91 . S IBX=$$LOS^IBCU64(+IBSTATE,+$P(IBSTATE,U,2),+$P(IBCBILL,U,6)),IBX=IBX-$$LOS1^IBCU64(IBIFN) I IBX>0 S IBSTR=IBSTR_$J("Pass Days: "_IBX,55)
     92 ;
     93 S IBI="" F  S IBI=$O(^TMP("IBXDISP",$J,IBI)) Q:'IBI  S IBJ=0 F  S IBJ=$O(^TMP("IBXDISP",$J,IBI,IBJ)) Q:'IBJ  D
     94 . S IBX=$G(^TMP("IBXDISP",$J,IBI,IBJ)),IBLN=$$SET(IBX,IBLN)
     95 . I $E(IBX,1,3)="001" D COB
     96 ;
     97 K ^TMP("IBXDISP",$J)
     98 ;
     99 D MRA
     100 S VALMCNT=IBLN-1
     101UB04Q Q
     102 ;
     103SETLN(STR,IBX,COL,WD) ;
     104 S IBX=$$SETSTR^VALM1(STR,IBX,COL,WD)
     105 Q IBX
     106 ;
     107SET(STR,LN) ; set up TMP array with screen data (allows 2 blank lines, if not at end of array)
     108 N IBX,IBI I STR?80" " S IBLKLN=IBLKLN+1 G SETQ
     109 F IBI=1:1:IBLKLN D SET^VALM10(LN," ") S LN=LN+1 Q:IBI>1
     110 D SET^VALM10(LN,STR)
     111 S LN=LN+1,IBLKLN=0
     112SETQ Q LN
     113 ;
     114COB ; if there is an offset or a secondary/tertiary payer add it to the display, with ins co, and prior bill #
     115 ; IBIFN and IBLN must exist upon entry, IBLN is updated with new line count
     116 N IBM,IBM1,IBI,IBJ,IBD,IBSTR,IBCU2,IBCU1 Q:'$G(IBIFN)
     117 S IBM=$G(^DGCR(399,IBIFN,"M")),IBM1=$G(^DGCR(399,IBIFN,"M1"))
     118 S IBCU2=$G(^DGCR(399,IBIFN,"U2")),IBCU1=$G(^DGCR(399,IBIFN,"U1"))
     119 S IBJ=$P($G(^DGCR(399,IBIFN,0)),U,21),IBJ=$S(IBJ="P":3,IBJ="S":3,IBJ="T":3,1:0),IBSTR=""
     120 I +$P(IBM,U,2)!(+$P(IBM,U,3)) F IBI=1:1:IBJ I +$P(IBM,U,IBI) D  S IBLN=$$SET(IBSTR,IBLN)
     121 . I IBSTR="" S IBLN=$$SET("",IBLN)
     122 . S IBD=$S(IBI=1:"Primary",IBI=2:"Secondary",1:"Tertiary")_": " S IBSTR=$$SETLN(IBD,"",5,11)
     123 . S IBD=$P($G(^DIC(36,+$P(IBM,U,IBI),0)),U,1) S IBSTR=$$SETLN(IBD,IBSTR,17,25)
     124 . I $P(IBCU2,U,(IBI+3))'="" S IBD=$J(+$P(IBCU2,U,(IBI+3)),9,2) S IBSTR=$$SETLN(IBD,IBSTR,44,11)
     125 . I $P(IBM1,U,(IBI+4))'="" S IBD=$$BN1^PRCAFN(+$P(IBM1,U,(IBI+4))) S IBSTR=$$SETLN(IBD,IBSTR,60,11)
     126 I +$P(IBCU1,U,2) D  S IBLN=$$SET(IBSTR,IBLN)
     127 . I IBSTR="" S IBLN=$$SET("",IBLN)
     128 . S IBD="Offset: " S IBSTR=$$SETLN(IBD,"",5,11)
     129 . S IBD=$P(IBCU1,U,3) S IBSTR=$$SETLN(IBD,IBSTR,17,25)
     130 . S IBD=$J($P(IBCU1,U,2),9,2) S IBSTR=$$SETLN(IBD,IBSTR,44,11)
     131 . S IBD=$P(IBCU1,U,1)-$P(IBCU1,U,2),IBD="Billed: "_$J(IBD,0,2) S IBSTR=$$SETLN(IBD,IBSTR,60,17)
     132 Q
     133 ;
     134RX ;RX refill info for CMS-1500 TPJI display
     135 N Z,Z0,Z1,IBSPC,IBD,IBI,IBSTR,IBARRAY,IBRXX
     136 S IBLN=IBLN+1
     137 S IBSPC=$J("",5)
     138 D SET^IBCSC5A(IBIFN,.IBARRAY)
     139 I $D(IBARRAY) D
     140 . S (Z,Z0)=0 F  S Z0=$O(IBARRAY(Z0)) Q:Z0=""  S Z1=0 F  S Z1=$O(IBARRAY(Z0,Z1)) Q:'Z1  S Z=Z+1 S IBXDATA(Z)=$$DAT1^IBOUTL(Z1)_U_$G(IBARRAY(Z0,Z1))
     141 S IBD=$$SET("",IBLN)
     142 S IBD="PRESCRIPTION REFILLS: (For TPJI display only)"
     143 S IBSTR=$$SETLN(IBD,"",1,79),IBLN=$$SET(IBSTR,IBLN)
     144 S IBI=0 F  S IBI=$O(IBXDATA(IBI)) Q:IBI=""  D
     145 . S IBRXX=$G(IBXDATA(IBI))
     146 . D ZERO^IBRXUTL($P(IBRXX,U,3))
     147 . S IBD=$J($P(IBRXX,U,7),9,2)_IBSPC_$P(IBRXX,U)_IBSPC_$G(^TMP($J,"IBDRUG",+$P(IBRXX,U,3),.01))
     148 . K ^TMP($J,"IBDRUG")
     149 . S IBSTR=$$SETLN(IBD,"",1,79),IBLN=$$SET(IBSTR,IBLN)
     150 . S IBD="QTY: "_$P(IBRXX,U,5)_" for "_$P(IBRXX,U,4)_" days supply "_"NDC# "_$P(IBRXX,U,6)
     151 . S IBSTR=$$SETLN(IBD,"",23,79),IBLN=$$SET(IBSTR,IBLN)
     152 Q
     153 ;
     154PROS ;prosthetic info for CMS-1500 TPJI display
     155 N Z,Z0,Z1,IBARRAY,IBSPC,IBD,IBI,IBSTR
     156 S IBSPC=$J("",10),IBLN=IBLN+1
     157 D SET^IBCSC5B(IBIFN,.IBARRAY)
     158 I $D(IBARRAY) D
     159 . S (Z,Z0)=0 F  S Z0=$O(IBARRAY(Z0)) Q:Z0=""  S Z1=0 F  S Z1=$O(IBARRAY(Z0,Z1)) Q:'Z1  S Z=Z+1,IBXDATA(Z)=$$DAT1^IBOUTL(Z0)_U_$E($P($$PIN^IBCSC5B(Z1),U,2),1,39)
     160 S IBD=$$SET("",IBLN)
     161 S IBD="PROSTHETIC REFILLS: (For TPJI display only)"
     162 S IBSTR=$$SETLN(IBD,"",1,79),IBLN=$$SET(IBSTR,IBLN)
     163 S IBI=0 F  S IBI=$O(IBXDATA(IBI)) Q:IBI=""  D
     164 . S IBD=$P(IBXDATA(IBI),U)_IBSPC_$P(IBXDATA(IBI),U,2)
     165 . S IBSTR=$$SETLN(IBD,"",1,79),IBLN=$$SET(IBSTR,IBLN)
     166 Q
     167 ;

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJTCA2.m

    r613 r623  
    1 IBJTCA2 ;ALB/ARH - TPI CLAIMS INFO BUILD (CONT) ;7:39 PM  30 Jan 2008
    2         ;;2.0;INTEGRATED BILLING;**39,80,155,320,VWEHR1**;WorldVistA 30-Jan-08;Build 4
    3         ;;Per VHA Directive 10-93-142, this routine should not be modified.
    4         ;
    5         ;Modified from FOIA VISTA,
    6         ;Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
    7         ;General Public License See attached copy of the License.
    8         ;
    9         ;This program is free software; you can redistribute it and/or modify
    10         ;it under the terms of the GNU General Public License as published by
    11         ;the Free Software Foundation; either version 2 of the License, or
    12         ;(at your option) any later version.
    13         ;
    14         ;This program is distributed in the hope that it will be useful,
    15         ;but WITHOUT ANY WARRANTY; without even the implied warranty of
    16         ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    17         ;GNU General Public License for more details.
    18         ;
    19         ;You should have received a copy of the GNU General Public License along
    20         ;with this program; if not, write to the Free Software Foundation, Inc.,
    21         ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    22         ;
    23 CONT    ; Continuation of Claim Information Screen Build
    24         ; reason cancelled
    25         I $P(IBD0,U,13)=7 D
    26         . S (IBNC(1),IBTC(1))=2,(IBNC(2),IBTC(2))=0,IBNC(3)=28,IBTW(1)=29,IBTW(2)=0,IBSW(1)=49,IBSW(2)=0
    27         . S (IBT,IBD)="" S IBLN=$$SET(IBT,IBD,IBLN,1)
    28         . ;
    29         . S IBGRPB=IBLN,IBLR=1
    30         . K IBY D RCANC^IBJTU2(IBIFN,.IBY,50)
    31         . S IBT="Reason Cancelled by ("_$P(IBY,U,3)_"): "
    32         . S IBI=0 F  S IBI=$O(IBY(IBI)) Q:'IBI  S IBD=IBY(IBI) S IBLN=$$SET(IBT,IBD,IBLN,IBLR),IBT=""
    33         ;
    34         S (IBLN,VALMCNT)=$S(IBLN>IBGRPE:IBLN,1:IBGRPE)
    35         S (IBNC(1),IBTC(1))=2,IBTW(1)=16,IBSW(1)=50
    36         S (IBT,IBD)="" S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
    37         ;
    38         S IBGRPB=IBLN,IBLR=1
    39         ;
    40         I +$P(IBDS,U,1) S IBT="Entered: ",IBD=$$EXT(IBDS,1,2) S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
    41         I +$P(IBDS,U,4) S IBT="Initial Review: ",IBD=$$EXT(IBDS,4,5) S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
    42         I +$P(IBDS,U,7) S IBT="MRA Request: ",IBD=$$EXT(IBDS,7,8) S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
    43         I +$P(IBDS,U,10) S IBT="Authorized: ",IBD=$$EXT(IBDS,10,11) S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
    44         I +$P(IBDS,U,12) S IBT="First Printed: ",IBD=$$EXT(IBDS,12,13) S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
    45         I $P(IBDS,U,14)>$P(IBDS,U,12) S IBT="Last Printed: ",IBD=$$EXT(IBDS,14,15) S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
    46         I +$P(IBDS,U,17) S IBT="Cancelled: ",IBD=$$EXT(IBDS,17,18) S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
    47         ;
    48         ; Patch 320 - added bill cloning history to TPJI report.
    49         N IBCCR,IBCURR,IBNEXT,IBBCH,IBINDENT
    50         S IBINDENT=0
    51         D EN^IBCCR(IBIFN,.IBCCR)   ; utility to pull cloning history
    52         ;
    53         ; attempt to go one claim forward from the current claim
    54         S IBCURR="IBCCR("_+$P(IBDS,U,1)_","_IBIFN_")"
    55         S IBNEXT=$Q(@IBCURR)
    56         I IBNEXT'="" D
    57         . N IBX S IBX=@IBNEXT
    58         . S IBT="Copied: "
    59         . S IBD=$$FMTE^XLFDT($P(IBX,U,1),"2Z")_"  by  "_$P(IBX,U,3)
    60         . S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
    61         . S IBT="Copied To: ",IBD=$P(IBX,U,2),IBLN=$$SET(IBT,IBD,IBLN,IBLR)
    62         . S IBINDENT=1
    63         . Q
    64         ;
    65         ; now go backwards for claim cloning history all the way back
    66         S IBBCH=IBCURR
    67         ;
    68         ;WV/EHR REVERSE $Q REPLACEMENT; SO 01/12/08 ;VWEHR1
    69         ;
    70         ;F  S IBBCH=$Q(@IBBCH,-1) Q:IBBCH=""  D
    71         F  S IBBCH=$$Q^VWUTIL($NA(@IBBCH),-1) Q:IBBCH=""  D
    72         . ;
    73         . ;END CHANGE
    74         . ;
    75         . N IBX S IBX=@IBBCH
    76         . S IBT="Copied: " I IBINDENT S IBT="                  "_IBT
    77         . S IBD=$$FMTE^XLFDT($P(IBX,U,1),"2Z")_"  by  "_$P(IBX,U,3)
    78         . S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
    79         . S IBT="Copied From: " I IBINDENT S IBT="             "_IBT
    80         . S IBD=$P(IBX,U,2),IBLN=$$SET(IBT,IBD,IBLN,IBLR)
    81         . S IBT="Reason Copied: " I IBINDENT S IBT="           "_IBT
    82         . S IBD=$P(IBX,U,4),IBLN=$$SET(IBT,IBD,IBLN,IBLR)
    83         . S IBINDENT=1
    84         . Q
    85         ;
    86         I $D(^DGCR(399,IBIFN,"R","AC",1)) S IBT="Returned to AR: ",X=0 F  S X=$O(^DGCR(399,IBIFN,"R","AC",1,X)) Q:'X  D
    87         . S IBY=$G(^DGCR(399,IBIFN,"R",X,0)),IBD=$$EXT(IBY,1,2) S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
    88         ;
    89         N IBCOB,IBX,IBY,IBI,IBJ,IBK D BCOB^IBCU3(IBIFN,.IBCOB) I $O(IBCOB(0)) D
    90         . S IBTC(1)=2,IBTW(1)=12,IBSW(1)=68,IBLR=1,IBNC(1)=26
    91         . S (IBT,IBD)="" S IBLN=$$SET(IBT,IBD,IBLN,1)
    92         . S IBT="Payers and Related Bills" S IBLN=$$SETN^IBJTCA1(IBT,IBLN,IBLR,1)
    93         . S (IBT,IBD)="" S IBLN=$$SET(IBT,IBD,IBLN,1)
    94         . S IBT="",IBD="Insurance Co.    Bill #     Status   Original  Collected    Balance"
    95         . S IBLN=$$SET(IBT,IBD,IBLN,IBLR) D CNTRL^VALM10(IBLN-1,(IBTC(1)+IBTW(1)),IBSW(1),IOUON,IOUOFF)
    96         . S IBI=0 F  S IBI=$O(IBCOB(IBI)) Q:'IBI  D
    97         .. S IBT=$S(IBI=1:"Primary",IBI=2:"Secondary",IBI=3:"Tertiary",1:"Other")_":  "
    98         .. S IBJ=0 F  S IBJ=$O(IBCOB(IBI,IBJ)) Q:'IBJ  S IBK="" F  S IBK=$O(IBCOB(IBI,IBJ,IBK)) Q:IBK=""  D
    99         ... S IBD="",IBY=$$BILL^RCJIBFN2(IBK)
    100         ... S IBX=$P($G(^DIC(36,+IBJ,0)),U,1) S IBD=$$SLINE(IBD,IBX,0,15)
    101         ... I +IBK D
    102         .... S IBX=$P($G(^DGCR(399,+IBK,0)),U,1) S IBD=$$SLINE(IBD,IBX,17,10)
    103         .... S IBX=$P($$STNO^RCJIBFN2(+$P(IBY,U,2)),U,2) ;bill status
    104         .... ; if MRA active & bill pyr seq >1 & dsply'g prmry & prmry ins is WNR
    105         .... I $$EDIACTV^IBCEF4(2),$$COBN^IBCEF(+IBK)>1,IBI=1,$$MCRWNR^IBEFUNC(+IBJ) D
    106         ..... S IBX=" ",IBY="0^^0^0^0" ;blank out status & reset WNR amounts
    107         .... S IBD=$$SLINE(IBD,IBX,30,3)
    108         .... S IBX=$J($P(IBY,U,1),10,2) S IBD=$$SLINE(IBD,IBX,35,10)
    109         .... S IBX=$J($P(IBY,U,4),10,2) S IBD=$$SLINE(IBD,IBX,46,10)
    110         .... S IBX=$J($P(IBY,U,3),10,2) S IBD=$$SLINE(IBD,IBX,57,10)
    111         ... S IBLN=$$SET(IBT,IBD,IBLN,IBLR),IBT=""
    112         Q
    113         ;
    114 EXT(STR,DT,USER)        ; returns external form of user and date, given their position in the string
    115         N X,Y S Y="",STR=$G(STR),DT=+$G(DT),USER=+$G(USER)
    116         S X=$P(STR,U,DT),DT="" I +X S DT=$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3)
    117         S X=$P(STR,U,USER),USER="" I +X S USER=$P($G(^VA(200,+X,0)),U,1)
    118         S Y=DT_"  by  "_$S(USER="":"UNKNOWN",1:USER)
    119         Q Y
    120         ;
    121 SET(IBT,IBD,IBLN,IBLR)  ;
    122         N LN S LN=$$SET^IBJTCA1(IBT,IBD,IBLN,IBLR)
    123         Q LN
    124         ;
    125 SLINE(IBD,DATA,COL,WD)  ; format a single line with multiple data fields
    126         S IBD=$E(IBD,1,(COL-1)),IBD=IBD_$J("",(COL-$L(IBD))),IBD=IBD_$E(DATA,1,WD)
    127         Q IBD
     1IBJTCA2 ;ALB/ARH - TPI CLAIMS INFO BUILD (CONT) ;7:39 PM  30 Jan 2008
     2 ;;2.0;INTEGRATED BILLING;**39,80,155,320,VWEHR1**;WorldVistA 30-Jan-08
     3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
     4 ;
     5 ;Modified from FOIA VISTA,
     6 ;Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
     7 ;General Public License See attached copy of the License.
     8 ;
     9 ;This program is free software; you can redistribute it and/or modify
     10 ;it under the terms of the GNU General Public License as published by
     11 ;the Free Software Foundation; either version 2 of the License, or
     12 ;(at your option) any later version.
     13 ;
     14 ;This program is distributed in the hope that it will be useful,
     15 ;but WITHOUT ANY WARRANTY; without even the implied warranty of
     16 ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     17 ;GNU General Public License for more details.
     18 ;
     19 ;You should have received a copy of the GNU General Public License along
     20 ;with this program; if not, write to the Free Software Foundation, Inc.,
     21 ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
     22 ;
     23CONT ; Continuation of Claim Information Screen Build
     24 ; reason cancelled
     25 I $P(IBD0,U,13)=7 D
     26 . S (IBNC(1),IBTC(1))=2,(IBNC(2),IBTC(2))=0,IBNC(3)=28,IBTW(1)=29,IBTW(2)=0,IBSW(1)=49,IBSW(2)=0
     27 . S (IBT,IBD)="" S IBLN=$$SET(IBT,IBD,IBLN,1)
     28 . ;
     29 . S IBGRPB=IBLN,IBLR=1
     30 . K IBY D RCANC^IBJTU2(IBIFN,.IBY,50)
     31 . S IBT="Reason Cancelled by ("_$P(IBY,U,3)_"): "
     32 . S IBI=0 F  S IBI=$O(IBY(IBI)) Q:'IBI  S IBD=IBY(IBI) S IBLN=$$SET(IBT,IBD,IBLN,IBLR),IBT=""
     33 ;
     34 S (IBLN,VALMCNT)=$S(IBLN>IBGRPE:IBLN,1:IBGRPE)
     35 S (IBNC(1),IBTC(1))=2,IBTW(1)=16,IBSW(1)=50
     36 S (IBT,IBD)="" S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
     37 ;
     38 S IBGRPB=IBLN,IBLR=1
     39 ;
     40 I +$P(IBDS,U,1) S IBT="Entered: ",IBD=$$EXT(IBDS,1,2) S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
     41 I +$P(IBDS,U,4) S IBT="Initial Review: ",IBD=$$EXT(IBDS,4,5) S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
     42 I +$P(IBDS,U,7) S IBT="MRA Request: ",IBD=$$EXT(IBDS,7,8) S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
     43 I +$P(IBDS,U,10) S IBT="Authorized: ",IBD=$$EXT(IBDS,10,11) S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
     44 I +$P(IBDS,U,12) S IBT="First Printed: ",IBD=$$EXT(IBDS,12,13) S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
     45 I $P(IBDS,U,14)>$P(IBDS,U,12) S IBT="Last Printed: ",IBD=$$EXT(IBDS,14,15) S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
     46 I +$P(IBDS,U,17) S IBT="Cancelled: ",IBD=$$EXT(IBDS,17,18) S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
     47 ;
     48 ; Patch 320 - added bill cloning history to TPJI report.
     49 N IBCCR,IBCURR,IBNEXT,IBBCH,IBINDENT
     50 S IBINDENT=0
     51 D EN^IBCCR(IBIFN,.IBCCR)   ; utility to pull cloning history
     52 ;
     53 ; attempt to go one claim forward from the current claim
     54 S IBCURR="IBCCR("_+$P(IBDS,U,1)_","_IBIFN_")"
     55 S IBNEXT=$Q(@IBCURR)
     56 I IBNEXT'="" D
     57 . N IBX S IBX=@IBNEXT
     58 . S IBT="Copied: "
     59 . S IBD=$$FMTE^XLFDT($P(IBX,U,1),"2Z")_"  by  "_$P(IBX,U,3)
     60 . S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
     61 . S IBT="Copied To: ",IBD=$P(IBX,U,2),IBLN=$$SET(IBT,IBD,IBLN,IBLR)
     62 . S IBINDENT=1
     63 . Q
     64 ;
     65 ; now go backwards for claim cloning history all the way back
     66 S IBBCH=IBCURR
     67 ;
     68 ;WV/EHR REVERSE $Q REPLACEMENT; SO 01/12/08 ;VWEHR1
     69 ;
     70 ;F  S IBBCH=$Q(@IBBCH,-1) Q:IBBCH=""  D
     71 F  S IBBCH=$$Q^VWUTIL($NA(@IBBCH),-1) Q:IBBCH=""  D
     72 . ;
     73 . ;END CHANGE
     74 . ;
     75 . N IBX S IBX=@IBBCH
     76 . S IBT="Copied: " I IBINDENT S IBT="                  "_IBT
     77 . S IBD=$$FMTE^XLFDT($P(IBX,U,1),"2Z")_"  by  "_$P(IBX,U,3)
     78 . S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
     79 . S IBT="Copied From: " I IBINDENT S IBT="             "_IBT
     80 . S IBD=$P(IBX,U,2),IBLN=$$SET(IBT,IBD,IBLN,IBLR)
     81 . S IBT="Reason Copied: " I IBINDENT S IBT="           "_IBT
     82 . S IBD=$P(IBX,U,4),IBLN=$$SET(IBT,IBD,IBLN,IBLR)
     83 . S IBINDENT=1
     84 . Q
     85 ;
     86 I $D(^DGCR(399,IBIFN,"R","AC",1)) S IBT="Returned to AR: ",X=0 F  S X=$O(^DGCR(399,IBIFN,"R","AC",1,X)) Q:'X  D
     87 . S IBY=$G(^DGCR(399,IBIFN,"R",X,0)),IBD=$$EXT(IBY,1,2) S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
     88 ;
     89 N IBCOB,IBX,IBY,IBI,IBJ,IBK D BCOB^IBCU3(IBIFN,.IBCOB) I $O(IBCOB(0)) D
     90 . S IBTC(1)=2,IBTW(1)=12,IBSW(1)=68,IBLR=1,IBNC(1)=26
     91 . S (IBT,IBD)="" S IBLN=$$SET(IBT,IBD,IBLN,1)
     92 . S IBT="Payers and Related Bills" S IBLN=$$SETN^IBJTCA1(IBT,IBLN,IBLR,1)
     93 . S (IBT,IBD)="" S IBLN=$$SET(IBT,IBD,IBLN,1)
     94 . S IBT="",IBD="Insurance Co.    Bill #     Status   Original  Collected    Balance"
     95 . S IBLN=$$SET(IBT,IBD,IBLN,IBLR) D CNTRL^VALM10(IBLN-1,(IBTC(1)+IBTW(1)),IBSW(1),IOUON,IOUOFF)
     96 . S IBI=0 F  S IBI=$O(IBCOB(IBI)) Q:'IBI  D
     97 .. S IBT=$S(IBI=1:"Primary",IBI=2:"Secondary",IBI=3:"Tertiary",1:"Other")_":  "
     98 .. S IBJ=0 F  S IBJ=$O(IBCOB(IBI,IBJ)) Q:'IBJ  S IBK="" F  S IBK=$O(IBCOB(IBI,IBJ,IBK)) Q:IBK=""  D
     99 ... S IBD="",IBY=$$BILL^RCJIBFN2(IBK)
     100 ... S IBX=$P($G(^DIC(36,+IBJ,0)),U,1) S IBD=$$SLINE(IBD,IBX,0,15)
     101 ... I +IBK D
     102 .... S IBX=$P($G(^DGCR(399,+IBK,0)),U,1) S IBD=$$SLINE(IBD,IBX,17,10)
     103 .... S IBX=$P($$STNO^RCJIBFN2(+$P(IBY,U,2)),U,2) ;bill status
     104 .... ; if MRA active & bill pyr seq >1 & dsply'g prmry & prmry ins is WNR
     105 .... I $$EDIACTV^IBCEF4(2),$$COBN^IBCEF(+IBK)>1,IBI=1,$$MCRWNR^IBEFUNC(+IBJ) D
     106 ..... S IBX=" ",IBY="0^^0^0^0" ;blank out status & reset WNR amounts
     107 .... S IBD=$$SLINE(IBD,IBX,30,3)
     108 .... S IBX=$J($P(IBY,U,1),10,2) S IBD=$$SLINE(IBD,IBX,35,10)
     109 .... S IBX=$J($P(IBY,U,4),10,2) S IBD=$$SLINE(IBD,IBX,46,10)
     110 .... S IBX=$J($P(IBY,U,3),10,2) S IBD=$$SLINE(IBD,IBX,57,10)
     111 ... S IBLN=$$SET(IBT,IBD,IBLN,IBLR),IBT=""
     112 Q
     113 ;
     114EXT(STR,DT,USER) ; returns external form of user and date, given their position in the string
     115 N X,Y S Y="",STR=$G(STR),DT=+$G(DT),USER=+$G(USER)
     116 S X=$P(STR,U,DT),DT="" I +X S DT=$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3)
     117 S X=$P(STR,U,USER),USER="" I +X S USER=$P($G(^VA(200,+X,0)),U,1)
     118 S Y=DT_"  by  "_$S(USER="":"UNKNOWN",1:USER)
     119 Q Y
     120 ;
     121SET(IBT,IBD,IBLN,IBLR) ;
     122 N LN S LN=$$SET^IBJTCA1(IBT,IBD,IBLN,IBLR)
     123 Q LN
     124 ;
     125SLINE(IBD,DATA,COL,WD) ; format a single line with multiple data fields
     126 S IBD=$E(IBD,1,(COL-1)),IBD=IBD_$J("",(COL-$L(IBD))),IBD=IBD_$E(DATA,1,WD)
     127 Q IBD

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJTRA1.m

    r613 r623  
    1 IBJTRA1 ;ALB/AAS,ARH - TPI CT INSURANCE COMMUNICATIONS BUILD ; 4/1/95
    2         ;;2.0;INTEGRATED BILLING;**39,91,347,389**;21-MAR-94;Build 6
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5         ; copyed from IBTRC with modifications to show reviews for multiple events
    6         ;
    7         ;
    8 BLD     ; -- Build list of Insurance contacts, including reviews, appeals, and denials
    9         K ^TMP("IBJTRA",$J),^TMP("IBJTRADX",$J),IBJTA1,IBJTA2
    10         N X,IBI,IBJ,J,IBTRC,IBTRCD,IBTRCD1,IBJTEVNT,IBCNT,IBTRN,IBTRND,IBETYP,IBBEG
    11         S VALMSG=$$MSG^IBTUTL3(DFN)
    12         S (IBTRC,IBCNT,VALMCNT)=0,IBI=""
    13         D IFNTRN^IBJTU5(IBIFN,.IBJTA1,.IBJTA2)
    14         I 'IBJTA1 S IBCNT=1 D SET1(" ") S IBCNT=2 D SET1("No Claims Tracking Entries.") G BLDQ
    15         S IBJ=0 F  S IBJ=$O(IBJTA2(IBJ)) Q:'IBJ  S IBTRN=IBJTA2(IBJ) D
    16         .S IBTRND=$G(^IBT(356,IBTRN,0))
    17         .S IBJTEVNT="    "_$$EVNT(IBTRND)
    18         .F  S IBI=$O(^IBT(356.2,"ATIDT",IBTRN,IBI)) Q:'IBI  S IBTRC=0 F  S IBTRC=$O(^IBT(356.2,"ATIDT",IBTRN,IBI,IBTRC)) Q:'IBTRC  D
    19         ..S IBTRCD=$G(^IBT(356.2,+IBTRC,0))
    20         ..S IBTRCD1=$G(^IBT(356.2,+IBTRC,1))
    21         ..Q:'+$P(IBTRCD,"^",19)  ;quit if inactive
    22         ..S IBCNT=IBCNT+1
    23         ..I IBJTEVNT'="" D SET(" ",0),SET(IBJTEVNT,0) S IBJTEVNT=""
    24         ..S IBETYP=$G(^IBE(356.11,+$P(IBTRCD,"^",4),0))
    25         ..W "."
    26         ..S X=""
    27         ..S X=$$SETFLD^VALM1(IBCNT,X,"NUMBER")
    28         ..S X=$$SETFLD^VALM1($P($$DAT1^IBOUTL(+IBTRCD,"2P")," "),X,"DATE")
    29         ..S X=$$SETFLD^VALM1($P($G(^DIC(36,+$P(IBTRCD,"^",8),0)),"^"),X,"INS CO")
    30         ..S X=$$SETFLD^VALM1($$EXPAND^IBTRE(356.2,.11,$P(IBTRCD,"^",11)),X,"ACTION")
    31         ..;
    32         ..S X=$$SETFLD^VALM1($P(IBETYP,"^",3),X,"TYPE")
    33         ..S X=$$SETFLD^VALM1($P(IBTRCD,"^",28),X,"PRE-CERT")
    34         ..I $P(IBTRCD,"^",13) S X=$$SETFLD^VALM1($J($$DAY^IBTUTL3($P(IBTRCD,"^",12),$P(IBTRCD,"^",13),IBTRN),3),X,"DAYS")
    35         ..I $P($G(^IBE(356.7,+$P(IBTRCD,"^",11),0)),"^",3)=20 S X=$$SETFLD^VALM1($J($$DAY^IBTUTL3($P(IBTRCD,"^",15),$P(IBTRCD,"^",16),IBTRN),3),X,"DAYS")
    36         ..I $P(IBTRCD1,"^",7)!($P(IBTRCD1,"^",8)) S X=$$SETFLD^VALM1("ALL",X,"DAYS")
    37         ..S X=$$SETFLD^VALM1($P(IBTRCD,"^",6),X,"CONTACT")
    38         ..S X=$$SETFLD^VALM1($P(IBTRCD,"^",7),X,"PHONE")
    39         ..S X=$$SETFLD^VALM1($P(IBTRCD,"^",9),X,"REF NO")
    40         ..I $P(IBETYP,"^",2)=60!($P(IBETYP,"^",2)=65) D APPEAL^IBTRC3
    41         ..D SET(X,1)
    42         I 'IBCNT S IBCNT=1 D SET1(" ") S IBCNT=2 D SET1("No Insurance Reviews for Episodes on this Bill.") G BLDQ
    43 BLDQ    K IBJTA1,IBJTA2
    44         Q
    45         ;
    46 SET1(X) ; set array (no selection)
    47         S VALMCNT=VALMCNT+1
    48         S ^TMP("IBJTRA",$J,VALMCNT,0)=X
    49         Q
    50         ;
    51 SET(X,Y)        ; -- set arrays
    52         S VALMCNT=VALMCNT+1
    53         S ^TMP("IBJTRA",$J,VALMCNT,0)=X
    54         S ^TMP("IBJTRA",$J,"IDX",VALMCNT,IBCNT)=""
    55         I +$G(Y) S ^TMP("IBJTRADX",$J,IBCNT)=VALMCNT_"^"_IBTRC
    56         Q
    57         ;
    58 EVNT(IBTRND)    ; return line for display on event
    59         N X,Y,IBTYP S X="" I $G(IBTRND)="" G EVNTQ
    60         S IBTYP=+$P(IBTRND,U,18)
    61         S X=$$EXSET^IBJU1(IBTYP,356,.18)
    62         I IBTYP=2 S X=X_" of "_$P($G(^DIC(40.7,+$$SCE^IBSDU(+$P(IBTRND,U,4),3),0)),U,1)
    63         I IBTYP=3 S X=X_" of "_$P($$PIN^IBCSC5B(+$P(IBTRND,U,9)),U,2)
    64         I IBTYP=4 S X=X_" of "_$$FILE^IBRXUTL(+$P(IBTRND,U,8),.01)
    65         S X=X_" on "_$$DAT1^IBOUTL($P(IBTRND,U,6),"2P")
    66 EVNTQ   Q X
     1IBJTRA1 ;ALB/AAS,ARH - TPI CT INSURANCE COMMUNICATIONS BUILD ; 4/1/95
     2 ;;2.0;INTEGRATED BILLING;**39,91,347**;21-MAR-94;Build 24
     3 ;;Per VHA Directive 2004-038, this routine should not be modified.
     4 ;
     5 ; copyed from IBTRC with modifications to show reviews for multiple events
     6 ;
     7 ;
     8BLD ; -- Build list of Insurance contacts, including reviews, appeals, and denials
     9 K ^TMP("IBJTRA",$J),^TMP("IBJTRADX",$J),IBJTA1,IBJTA2
     10 N X,IBI,IBJ,J,IBTRC,IBTRCD,IBTRCD1,IBJTEVNT,IBCNT,IBTRN,IBTRND,IBETYP,IBBEG
     11 S VALMSG=$$MSG^IBTUTL3(DFN)
     12 S (IBTRC,IBCNT,VALMCNT)=0,IBI=""
     13 D IFNTRN^IBJTU5(IBIFN,.IBJTA1,.IBJTA2)
     14 I 'IBJTA1 S IBCNT=1 D SET1(" ") S IBCNT=2 D SET1("No Claims Tracking Entries.") G BLDQ
     15 S IBJ=0 F  S IBJ=$O(IBJTA2(IBJ)) Q:'IBJ  S IBTRN=IBJTA2(IBJ) D
     16 .S IBTRND=$G(^IBT(356,IBTRN,0))
     17 .S IBJTEVNT="    "_$$EVNT(IBTRND)
     18 .F  S IBI=$O(^IBT(356.2,"ATIDT",IBTRN,IBI)) Q:'IBI  S IBTRC=0 F  S IBTRC=$O(^IBT(356.2,"ATIDT",IBTRN,IBI,IBTRC)) Q:'IBTRC  D
     19 ..S IBTRCD=$G(^IBT(356.2,+IBTRC,0))
     20 ..S IBTRCD1=$G(^IBT(356.2,+IBTRC,1))
     21 ..Q:'+$P(IBTRCD,"^",19)  ;quit if inactive
     22 ..S IBCNT=IBCNT+1
     23 ..I IBJTEVNT'="" D SET(" ",0),SET(IBJTEVNT,0) S IBJTEVNT=""
     24 ..S IBETYP=$G(^IBE(356.11,+$P(IBTRCD,"^",4),0))
     25 ..W "."
     26 ..S X=""
     27 ..S X=$$SETFLD^VALM1(IBCNT,X,"NUMBER")
     28 ..S X=$$SETFLD^VALM1($P($$DAT1^IBOUTL(+IBTRCD,"2P")," "),X,"DATE")
     29 ..S X=$$SETFLD^VALM1($P($G(^DIC(36,+$P(IBTRCD,"^",8),0)),"^"),X,"INS CO")
     30 ..S X=$$SETFLD^VALM1($$EXPAND^IBTRE(356.2,.11,$P(IBTRCD,"^",11)),X,"ACTION")
     31 ..;
     32 ..S X=$$SETFLD^VALM1($P(IBETYP,"^",3),X,"TYPE")
     33 ..S X=$$SETFLD^VALM1($P(IBTRCD,"^",28),X,"PRE-CERT")
     34 ..I $P(IBTRCD,"^",13) S X=$$SETFLD^VALM1($J($$DAY^IBTUTL3($P(IBTRCD,"^",12),$P(IBTRCD,"^",13),IBTRN),3),X,"DAYS")
     35 ..I $P($G(^IBE(356.7,+$P(IBTRCD,"^",11),0)),"^",3)=20 S X=$$SETFLD^VALM1($J($$DAY^IBTUTL3($P(IBTRCD,"^",15),$P(IBTRCD,"^",16),IBTRN),3),X,"DAYS")
     36 ..I $P(IBTRCD1,"^",7)!($P(IBTRCD1,"^",8)) S X=$$SETFLD^VALM1("ALL",X,"DAYS")
     37 ..S X=$$SETFLD^VALM1($P(IBTRCD,"^",6),X,"CONTACT")
     38 ..S X=$$SETFLD^VALM1($P(IBTRCD,"^",7),X,"PHONE")
     39 ..S X=$$SETFLD^VALM1($P(IBTRCD,"^",9),X,"REF NO")
     40 ..I $P(IBETYP,"^",2)=60!($P(IBETYP,"^",2)=65) D APPEAL^IBTRC3
     41 ..D SET(X,1)
     42 I 'IBCNT S IBCNT=1 D SET1(" ") S IBCNT=2 D SET1("No Insurance Reviews for Episodes on this Bill.") G BLDQ
     43BLDQ K IBJTA1,IBJTA2
     44 Q
     45 ;
     46SET1(X) ; set array (no selection)
     47 S VALMCNT=VALMCNT+1
     48 S ^TMP("IBJTRA",$J,VALMCNT,0)=X
     49 Q
     50 ;
     51SET(X,Y) ; -- set arrays
     52 S VALMCNT=VALMCNT+1
     53 S ^TMP("IBJTRA",$J,VALMCNT,0)=X
     54 S ^TMP("IBJTRA",$J,"IDX",VALMCNT,IBCNT)=""
     55 I +$G(Y) S ^TMP("IBJTRADX",$J,IBCNT)=VALMCNT_"^"_IBTRC
     56 Q
     57 ;
     58EVNT(IBTRND) ; return line for display on event
     59 N X,Y,IBTYP S X="" I $G(IBTRND)="" G EVNTQ
     60 S IBTYP=+$P(IBTRND,U,18)
     61 S X=$$EXSET^IBJU1(IBTYP,356,.18)
     62 I IBTYP=2 S X=X_" of "_$P($G(^DIC(40.7,+$$SCE^IBSDU(+$P(IBTRND,U,4),3),0)),U,1)
     63 I IBTYP=3 S Y=+$P($G(^RMPR(660,+$P(IBTRND,U,9),0)),U,6),X=X_" of "_$$EXSET^IBJU1(Y,660,4)
     64 I IBTYP=4 S X=X_" of "_$$FILE^IBRXUTL(+$P(IBTRND,U,8),.01)
     65 S X=X_" on "_$$DAT1^IBOUTL($P(IBTRND,U,6),"2P")
     66EVNTQ Q X

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJTTC.m

    r613 r623  
    1 IBJTTC  ;ALB/ARH - TPI AR COMMENT HISTORY ; 06-MAR-1995
    2         ;;2.0;INTEGRATED BILLING;**39,377**;21-MAR-94;Build 23
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5         ; AR Profile of Comments:  This screen prints the following Comments:
    6         ;    Bill Comments (430,98)  - entered during auditing
    7         ;    For each COMMENT Transaction:
    8         ;           Brief Comment (433,5.02)
    9         ;           Transaction Comment (433,86)
    10         ;           Comment (433,41)
    11         ;
    12 EN      ; -- main entry point for IBJT AR COMMENT HISTORY
    13         D EN^VALM("IBJT AR COMMENT HISTORY")
    14         Q
    15         ;
    16 HDR     ; -- header code
    17         D HDR^IBJTU1(+IBIFN,+DFN,13)
    18         Q
    19         ;
    20 INIT    ; -- init variables and list array
    21         K ^TMP("IBJTTC",$J)
    22         I '$G(DFN)!'$G(IBIFN) S VALMQUIT="" G INITQ
    23         D BLD
    24 INITQ   Q
    25         ;
    26 HELP    ; -- help code
    27         S X="?" D DISP^XQORM1 W !!
    28         Q
    29         ;
    30 EXIT    ; -- exit code
    31         K ^TMP("IBJTTC",$J)
    32         D CLEAR^VALM1
    33         Q
    34         ;
    35 BLD     ;
    36         N CMLN,CMSTR,X,IBCNT,IBZ,IB0,IBI,IBX,IBD,IBDATE,IBDUZ,IBRCT5,IBLN,IBSTR,IBK,IBJ,DIWL,DIWR,DIWF,COM
    37         ;
    38         S VALMCNT=0,IBLN=0
    39         ;
    40         ; Bill Comments (430,98)
    41         K COM,^UTILITY($J,"W") D BCOM^RCJIBFN2(IBIFN) I $D(COM)>10 D
    42         . S IBSTR="",IBD="AR BILL COMMENTS:" S IBSTR=$$SETLN(IBD,IBSTR,25,54),IBLN=$$SET(IBSTR,IBLN)
    43         . ;
    44         . S IBJ="" F  S IBJ=$O(COM(IBJ)) Q:'IBJ  S X=$G(COM(IBJ)) I X'="" S DIWL=1,DIWR=54,DIWF=""  D ^DIWP
    45         . ;
    46         . I $D(^UTILITY($J,"W")) S (IBK,IBCNT)=0 F  S IBK=$O(^UTILITY($J,"W",1,IBK)) Q:'IBK  D
    47         .. S IBD=$G(^UTILITY($J,"W",1,IBK,0)) S IBSTR=$$SETLN(IBD,IBSTR,25,54),IBLN=$$SET(IBSTR,IBLN),IBSTR=""
    48         . K ^UTILITY($J,"W")
    49         ;
    50         ; AR profile of comment transactions  (433: 5.02, 41, 86)
    51         K ^TMP("RCJIB",$J),^UTILITY($J,"W") D TRN^RCJIBFN2(IBIFN)
    52         I $D(^TMP("RCJIB",$J)) S IBI="" F  S IBI=$O(^TMP("RCJIB",$J,IBI)) Q:'IBI  D
    53         . S IBX=$G(^TMP("RCJIB",$J,IBI)) I $$STNO^RCJIBFN2(+$P(IBX,U,3))'["COMMENT" Q
    54         . S IBRCT5=$$N5^RCJIBFN1(IBI)
    55         . S IBSTR="",IBLN=$$SET(IBSTR,IBLN)
    56         . S IBD=$P(IBX,U,1) S IBSTR=$$SETLN(IBD,IBSTR,2,8)
    57         . S IBD=$$DATE(+$P(IBX,U,2)) S IBSTR=$$SETLN(IBD,IBSTR,14,8)
    58         . S IBD=$P(IBRCT5,U,1) S IBSTR=$$SETLN(IBD,IBSTR,25,30)
    59         . S IBD="FOLLOW-UP DT: "_$$DATE(+$P(IBRCT5,U,2)) S IBSTR=$$SETLN(IBD,IBSTR,57,22)
    60         . S IBLN=$$SET(IBSTR,IBLN),IBSTR=""
    61         . ;
    62         . ;   -- transaction comments (86)
    63         . S X=$P($G(^TMP("RCJIB",$J,IBI)),U,6) I X'="" S DIWL=1,DIWR=54,DIWF=""  D ^DIWP
    64         . ;
    65         . ;   -- comments  (86 & 41)
    66         . K COM D N7^RCJIBFN1(IBI) I $D(COM)>2 D
    67         .. S IBJ="" F  S IBJ=$O(COM(IBJ)) Q:'IBJ  S X=$G(COM(IBJ)) I X'="" S DIWL=1,DIWR=54,DIWF=""  D ^DIWP
    68         . ;
    69         . I $D(^UTILITY($J,"W")) S (IBK,IBCNT)=0 F  S IBK=$O(^UTILITY($J,"W",1,IBK)) Q:'IBK  D
    70         .. S IBD=$G(^UTILITY($J,"W",1,IBK,0)) S IBSTR=$$SETLN(IBD,IBSTR,25,54),IBLN=$$SET(IBSTR,IBLN),IBSTR=""
    71         . K ^UTILITY($J,"W")
    72         K ^TMP("RCJIB",$J),^UTILITY($J,"W")
    73         ; MRA comments
    74         ; check if we have any comments to display
    75         I $D(^DGCR(399,IBIFN,"TXC","B")) D
    76         .S IBLN=$$SET("",IBLN)
    77         .S IBSTR="",IBSTR=$$SETLN("MRA REQUEST CLAIM COMMENTS",IBSTR,25,54),IBLN=$$SET(IBSTR,IBLN)
    78         .S IBSTR="",IBSTR=$$SETLN("--------------------------",IBSTR,25,54),IBLN=$$SET(IBSTR,IBLN)
    79         .; loop through all available comments
    80         .S IBDATE="" F  S IBDATE=$O(^DGCR(399,IBIFN,"TXC","B",IBDATE),-1) Q:IBDATE=""  D
    81         ..S IBZ=$O(^DGCR(399,IBIFN,"TXC","B",IBDATE,"")),IB0=^DGCR(399,IBIFN,"TXC",IBZ,0),IBDUZ=$P(IB0,U,2)
    82         ..S IBLN=$$SET("",IBLN)
    83         ..S IBSTR=""
    84         ..S IBSTR=$$SETLN($$FMTE^XLFDT(IBDATE,"2Z"),IBSTR,14,8)
    85         ..S IBSTR=$$SETLN($J("Entered by "_$$GET1^DIQ(200,IBDUZ,.01),54),IBSTR,25,54)
    86         ..S IBLN=$$SET(IBSTR,IBLN),IBSTR=""
    87         ..; loop through comment lines
    88         ..S CMLN=0 F  S CMLN=$O(^DGCR(399,IBIFN,"TXC",IBZ,1,CMLN)) Q:CMLN=""  D
    89         ...S X=^DGCR(399,IBIFN,"TXC",IBZ,1,CMLN,0) I X'="" S DIWL=1,DIWR=54,DIWF=""  D ^DIWP
    90         ...Q
    91         ..I $D(^UTILITY($J,"W")) S IBK=0 F  S IBK=$O(^UTILITY($J,"W",1,IBK)) Q:'IBK  D
    92         ...S CMSTR=$G(^UTILITY($J,"W",1,IBK,0)) S IBSTR=$$SETLN(CMSTR,IBSTR,25,54),IBLN=$$SET(IBSTR,IBLN),IBSTR=""
    93         ...Q
    94         ..K ^UTILITY($J,"W")
    95         ..Q
    96         .D CLEAN^DILF
    97         .Q
    98         ;
    99         I IBLN=0 S IBLN=$$SET("",IBLN),IBLN=$$SET("No Comment Transactions Exist For This Account.",IBLN)
    100         S VALMCNT=IBLN
    101         Q
    102         ;
    103 DATE(X) ; date in external format
    104         N Y S Y="" I +X S Y=$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3)
    105         Q Y
    106         ;
    107 SETLN(STR,IBX,COL,WD)   ;
    108         S IBX=$$SETSTR^VALM1(STR,IBX,COL,WD)
    109         Q IBX
    110         ;
    111 SET(STR,LN)     ; set up TMP array with screen data
    112         S LN=LN+1 D SET^VALM10(LN,STR)
    113 SETQ    Q LN
     1IBJTTC ;ALB/ARH - TPI AR COMMENT HISTORY ; 06-MAR-1995
     2 ;;Version 2.0 ; INTEGRATED BILLING ;**39**; 21-MAR-94
     3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
     4 ;
     5 ; AR Profile of Comments:  This screen prints the following Comments:
     6 ;    Bill Comments (430,98)  - entered during auditing
     7 ;    For each COMMENT Transaction:
     8 ;           Brief Comment (433,5.02)
     9 ;           Transaction Comment (433,86)
     10 ;           Comment (433,41)
     11 ;
     12EN ; -- main entry point for IBJT AR COMMENT HISTORY
     13 D EN^VALM("IBJT AR COMMENT HISTORY")
     14 Q
     15 ;
     16HDR ; -- header code
     17 D HDR^IBJTU1(+IBIFN,+DFN,13)
     18 Q
     19 ;
     20INIT ; -- init variables and list array
     21 K ^TMP("IBJTTC",$J)
     22 I '$G(DFN)!'$G(IBIFN) S VALMQUIT="" G INITQ
     23 D BLD
     24INITQ Q
     25 ;
     26HELP ; -- help code
     27 S X="?" D DISP^XQORM1 W !!
     28 Q
     29 ;
     30EXIT ; -- exit code
     31 K ^TMP("IBJTTC",$J)
     32 D CLEAR^VALM1
     33 Q
     34 ;
     35BLD ;
     36 N X,IBCNT,IBI,IBX,IBD,IBRCT5,IBLN,IBSTR,IBK,IBJ,DIWL,DIWR,DIWF,COM
     37 ;
     38 S VALMCNT=0,IBLN=0
     39 ;
     40 ; Bill Comments (430,98)
     41 K COM,^UTILITY($J,"W") D BCOM^RCJIBFN2(IBIFN) I $D(COM)>10 D
     42 . S IBSTR="",IBD="AR BILL COMMENTS:" S IBSTR=$$SETLN(IBD,IBSTR,25,54),IBLN=$$SET(IBSTR,IBLN)
     43 . ;
     44 . S IBJ="" F  S IBJ=$O(COM(IBJ)) Q:'IBJ  S X=$G(COM(IBJ)) I X'="" S DIWL=1,DIWR=54,DIWF=""  D ^DIWP
     45 . ;
     46 . I $D(^UTILITY($J,"W")) S (IBK,IBCNT)=0 F  S IBK=$O(^UTILITY($J,"W",1,IBK)) Q:'IBK  D
     47 .. S IBD=$G(^UTILITY($J,"W",1,IBK,0)) S IBSTR=$$SETLN(IBD,IBSTR,25,54),IBLN=$$SET(IBSTR,IBLN),IBSTR=""
     48 . K ^UTILITY($J,"W")
     49 ;
     50 ; AR profile of comment transactions  (433: 5.02, 41, 86)
     51 K ^TMP("RCJIB",$J),^UTILITY($J,"W") D TRN^RCJIBFN2(IBIFN)
     52 I $D(^TMP("RCJIB",$J)) S IBI="" F  S IBI=$O(^TMP("RCJIB",$J,IBI)) Q:'IBI  D
     53 . S IBX=$G(^TMP("RCJIB",$J,IBI)) I $$STNO^RCJIBFN2(+$P(IBX,U,3))'["COMMENT" Q
     54 . S IBRCT5=$$N5^RCJIBFN1(IBI)
     55 . S IBSTR="",IBLN=$$SET(IBSTR,IBLN)
     56 . S IBD=$P(IBX,U,1) S IBSTR=$$SETLN(IBD,IBSTR,2,8)
     57 . S IBD=$$DATE(+$P(IBX,U,2)) S IBSTR=$$SETLN(IBD,IBSTR,14,8)
     58 . S IBD=$P(IBRCT5,U,1) S IBSTR=$$SETLN(IBD,IBSTR,25,30)
     59 . S IBD="FOLLOW-UP DT: "_$$DATE(+$P(IBRCT5,U,2)) S IBSTR=$$SETLN(IBD,IBSTR,57,22)
     60 . S IBLN=$$SET(IBSTR,IBLN),IBSTR=""
     61 . ;
     62 . ;   -- transaction comments (86)
     63 . S X=$P($G(^TMP("RCJIB",$J,IBI)),U,6) I X'="" S DIWL=1,DIWR=54,DIWF=""  D ^DIWP
     64 . ;
     65 . ;   -- comments  (86 & 41)
     66 . K COM D N7^RCJIBFN1(IBI) I $D(COM)>2 D
     67 .. S IBJ="" F  S IBJ=$O(COM(IBJ)) Q:'IBJ  S X=$G(COM(IBJ)) I X'="" S DIWL=1,DIWR=54,DIWF=""  D ^DIWP
     68 . ;
     69 . I $D(^UTILITY($J,"W")) S (IBK,IBCNT)=0 F  S IBK=$O(^UTILITY($J,"W",1,IBK)) Q:'IBK  D
     70 .. S IBD=$G(^UTILITY($J,"W",1,IBK,0)) S IBSTR=$$SETLN(IBD,IBSTR,25,54),IBLN=$$SET(IBSTR,IBLN),IBSTR=""
     71 . K ^UTILITY($J,"W")
     72 K ^TMP("RCJIB",$J),^UTILITY($J,"W")
     73 ;
     74 I IBLN=0 S IBLN=$$SET("",IBLN),IBLN=$$SET("No Comment Transactions Exist For This Account.",IBLN)
     75 S VALMCNT=IBLN
     76 Q
     77 ;
     78DATE(X) ; date in external format
     79 N Y S Y="" I +X S Y=$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3)
     80 Q Y
     81 ;
     82SETLN(STR,IBX,COL,WD) ;
     83 S IBX=$$SETSTR^VALM1(STR,IBX,COL,WD)
     84 Q IBX
     85 ;
     86SET(STR,LN) ; set up TMP array with screen data
     87 S LN=LN+1 D SET^VALM10(LN,STR)
     88SETQ Q LN

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBRFN3.m

    r613 r623  
    1 IBRFN3  ;ALB/ARH - PASS BILL/CLAIM TO AR ;3/18/96
    2         ;;2.0;INTEGRATED BILLING;**61,133,210,309,389**;21-MAR-94;Build 6
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5         ;  Returns information on the bill passed in,  all data returned in external format, for AR's RC project
    6         ;
    7         ;  If the bill can not be found then returns ARRAY=0  (should be called with ARRAY passed by reference)
    8         ;  Otherwise ARRAY=1 and the following array elements may be defined
    9         ;  these array elements will only be defined is there is data to return
    10         ;  those elements that have multiple entries will be in the form ARRAY("SUB",X) where X=1:1:...
    11         ;
    12         ;  ARRAY("BN") = BILL NUMBER
    13         ;  ARRAY("SR") = SENSITIVE RECORD? (Y or N)
    14         ;  ARRAY("STF") = STATEMENT COVERS FROM DATE - first date covered by bill
    15         ;  ARRAY("STT") = STATEMENT COVERS TO DATE - last date covered by bill
    16         ;  ARRAY("TCG") = TOTAL CHARGES^OFFSET AMT (PRIOR PAYMENTS)^OFFSET DESC
    17         ;  ARRAY("TOC") = BILL TYPE (INPATIENT OR OUTPATIENT)
    18         ;  ARRAY("TCF") = BILL FORM TYPE
    19         ;  ARRAY("DFP") = DATE FIRST PRINTED
    20         ;  ARRAY("TAX") = FEDERAL TAX NUMBER - for facility, a site parameter
    21         ;
    22         ;  ARRAY("PIN") = DEBTOR INSURANCE NAME ^ HOSPITAL PROVIDER NUMBER ^ GROUP NAME ^ GROUP NUMBER ^
    23         ;                 NAME OF INSURED ^ SUBSCRIBER ID ^ RELATIONSHIP TO INSURED
    24         ;
    25         ;  ARRAY("PIN","MMA") = DEBTOR MAILING STREET ADDRESS [LINE 1] ^
    26         ;                       MAILING STREET ADDRESS [LINE 2] ^ MAILING STREET ADDRESS [LINE 3] ^ CITY ^
    27         ;                       STATE (ABBREVIATED) ^ ZIP ^ PHONE NUMBER
    28         ;
    29         ;  ARRAY("RVC") = NUMBER OF REVENUE CODES ON BILL
    30         ;  ARRAY("RVC",X) = REVENUE CODE ^ REVENUE CODE DESCRIPTION ^ CHARGE (PER UNIT) ^ UNITS ^
    31         ;                   TOTAL CHARGE FOR REV CODE
    32         ;
    33         ;  ARRAY("OPV") = NUMBER OF OUTPATIENT VISIT DATES ON BILL
    34         ;  ARRAY("OPV",X) = OUTPATIENT VISIT DATE
    35         ;
    36         ;  ARRAY("PRC") = NUMBER OF PROCEDURES ON BILL
    37         ;  ARRAY("PRC",X) = PROCEDURE CODE ^ PROCEDURE DESCRIPTION ^ PROCEDURE DATE ^
    38         ;                   PLACE OF SERVICE CODE ^ PLACE OF SERVICE ^ TYPE OF SERVICE CODE ^ TYPE OF SERVICE
    39         ;
    40         ;  ARRAY("DXS") = NUMBER OF DIAGNOSIS ON BILL
    41         ;  ARRAY("DXS,X) = DIAGNOSIS CODE ^ DIAGNOSIS
    42         ;
    43         ;  ARRAY("RXF") = NUMBER OF PRESCRIPTION REFILLS ON BILL
    44         ;  ARRAY("RXF",X) = PRESCRIPTION # ^ REFILL DATE ^ DRUG NAME ^ DAYS SUPPLY ^ QUANTITY ^ NDC #
    45         ;
    46         ;  ARRAY("PRD") = NUMBER OF PROSTHETIC ITEMS ON BILL
    47         ;  ARRAY("PRD",X) = PROSTHETIC DEVICE ^ DELIVERY DATE
    48         ;
    49         ;  IF CONDITION RELATED TO EMPLOYMENT:  ARRAY("CRE") = "EMPLOYMENT"
    50         ;  IF CONDITION RELATED TO AN AUTO ACCIDENT:  ARRAY("CRA") = "AUTO ACCIDENT" ^ STATE (ABBREVIATION)
    51         ;  IF CONDITION RELATED TO AN OTHER ACCIDENT:  ARRAY("CRO") = "OTHER ACCIDENT"
    52         ;
    53 BILL(IBIFN,ARRAY)       ; returns array of information on a specific bill, based on RC requirements
    54         ;
    55         N IBI,IBJ,IBK,IBX,IBY,IBTMP,IBD0,IBDU,IBDU1,IBDI1,IBDS,IBDATE
    56         K ARRAY S ARRAY=1 I '$G(IBIFN)!($G(^DGCR(399,+$G(IBIFN),0))="") S ARRAY=0 Q
    57         F IBI=0,"U","U1","S" S @("IBD"_IBI)=$G(^DGCR(399,IBIFN,IBI))
    58         S IBX=$P(IBD0,U,21),IBX=$S(IBX="P":"I1",IBX="S":"I2",IBX="T":"I3",1:" ")
    59         S IBDI1=$G(^DGCR(399,IBIFN,IBX))
    60         ;
    61         S ARRAY("TCG")=$P(IBDU1,U,1,3)
    62         S ARRAY("BN")=$P(IBD0,U,1)
    63         S ARRAY("SR")=$S($P(IBDU,U,5)=1:"Y",1:"N")
    64         S ARRAY("STF")=$P(IBDU,U,1)
    65         S ARRAY("STT")=$P(IBDU,U,2)
    66         S ARRAY("TOC")=$S($P(IBD0,U,5)<3:"INPATIENT",1:"OUTPATIENT")
    67         S ARRAY("TCF")=$$FTN^IBCU3($$FT^IBCU3(IBIFN))
    68         S ARRAY("DFP")=$P(IBDS,U,12)
    69         S ARRAY("TAX")=$P($G(^IBE(350.9,1,1)),U,5)
    70         ;
    71 INS     ; insurance information
    72         S IBX=$G(^DGCR(399,+IBIFN,"M"))
    73         S ARRAY("PIN")=$P(IBX,U,4)_U_$P($G(^DIC(36,+IBDI1,0)),U,11)_U_$P(IBDI1,U,15)_U_$P(IBDI1,U,3)_U_$P(IBDI1,U,17)_U_$P(IBDI1,U,2)_U_$$RTI($P(IBDI1,U,16))
    74         S ARRAY("PIN","MMA")=$P(IBX,U,5)_U_$P(IBX,U,6)_U_$P($G(^DGCR(399,+IBIFN,"M1")),U,1)_U_$P(IBX,U,7)_U_$$STATE($P(IBX,U,8))
    75         S ARRAY("PIN","MMA")=ARRAY("PIN","MMA")_U_$$ZIP($P(IBX,U,9))_U_$P($G(^DIC(36,+IBDI1,.13)),U,1)
    76         ;
    77 RC      ; revenue codes
    78         S (IBI,IBJ)=0,ARRAY("RVC")=IBJ F  S IBI=$O(^DGCR(399,IBIFN,"RC",IBI)) Q:'IBI  D
    79         . S IBX=$G(^DGCR(399,IBIFN,"RC",IBI,0)) Q:IBX=""  S IBY=$G(^DGCR(399.2,+IBX,0))
    80         . S IBJ=IBJ+1,ARRAY("RVC")=IBJ
    81         . S ARRAY("RVC",IBJ)=$P(IBY,U,1)_U_$P(IBY,U,2)_U_$P(IBX,U,2)_U_$P(IBX,U,3)_U_$P(IBX,U,4)
    82         ;
    83 OPV     ; outpatient visit dates
    84         S (IBI,IBJ)=0,ARRAY("OPV")=IBJ F  S IBI=$O(^DGCR(399,IBIFN,"OP",IBI)) Q:'IBI  D
    85         . S IBX=$G(^DGCR(399,IBIFN,"OP",IBI,0)) Q:'IBX
    86         . S IBJ=IBJ+1,ARRAY("OPV")=IBJ
    87         . S ARRAY("OPV",IBJ)=+IBX
    88         ;
    89 PRC     ; procedure codes
    90         S (IBI,IBJ)=0,ARRAY("PRC")=IBJ F  S IBI=$O(^DGCR(399,IBIFN,"CP",IBI)) Q:'IBI  D
    91         . S IBX=$G(^DGCR(399,IBIFN,"CP",IBI,0)),IBY=""
    92         . S IBDATE=$P(IBX,U,2) I 'IBDATE S IBDATE=$$BDATE^IBACSV(IBIFN)
    93         . S IBY=$P($$PRCD^IBCEF1($P(IBX,U),1,IBDATE),U,2,3)
    94         . Q:$P(IBY,U)=""
    95         . S IBJ=IBJ+1,ARRAY("PRC")=IBJ
    96         . S ARRAY("PRC",IBJ)=IBY_U_$P(IBX,U,2)
    97         . S IBY=$G(^IBE(353.1,+$P(IBX,U,9),0)),ARRAY("PRC",IBJ)=ARRAY("PRC",IBJ)_U_$P(IBY,U)_U_$P(IBY,U,3)
    98         . S IBY=$G(^IBE(353.2,+$P(IBX,U,10),0)),ARRAY("PRC",IBJ)=ARRAY("PRC",IBJ)_U_$P(IBY,U)_U_$P(IBY,U,3)
    99         ;
    100 DX      ; diagnosis codes
    101         K IBTMP D SET^IBCSC4D(IBIFN,"",.IBTMP)
    102         S IBDATE=$$BDATE^IBACSV(IBIFN)
    103         S (IBI,IBJ)=0,ARRAY("DXS")=IBJ F  S IBI=$O(IBTMP(IBI)) Q:'IBI  D
    104         . S IBX=IBTMP(IBI),IBY=$$ICD9^IBACSV(+IBX,IBDATE) Q:IBY=""
    105         . S IBJ=IBJ+1,ARRAY("DXS")=IBJ
    106         . S ARRAY("DXS",IBJ)=$P(IBY,U)_U_$P(IBY,U,3)
    107         ;
    108 RX      ; prescription refills
    109         K IBTMP D SET^IBCSC5A(IBIFN,.IBTMP)
    110         S (IBI,IBJ)=0,ARRAY("RXF")=IBJ F  S IBI=$O(IBTMP(IBI)) Q:'IBI  D
    111         . S IBK=0 F  S IBK=$O(IBTMP(IBI,IBK)) Q:'IBK  D
    112         .. S IBX=IBTMP(IBI,IBK) D ZERO^IBRXUTL(+$P(IBX,U,2)) S IBY=$G(^TMP($J,"IBDRUG",+$P(IBX,U,2),.01))
    113         .. S IBJ=IBJ+1,ARRAY("RXF")=IBJ
    114         .. S ARRAY("RXF",IBJ)=IBI_U_IBK_U_IBY_U_$P(IBX,U,3)_U_$P(IBX,U,4)_U_$P(IBX,U,5)
    115         .. K ^TMP($J,"IBDRUG")
    116         .. Q
    117         ;
    118 PD      ; prosthetic items
    119         K IBTMP D SET^IBCSC5B(IBIFN,.IBTMP)
    120         S (IBI,IBJ)=0,ARRAY("PRD")=IBJ F  S IBI=$O(IBTMP(IBI)) Q:'IBI  D
    121         . S IBK=0 F  S IBK=$O(IBTMP(IBI,IBK)) Q:'IBK  D
    122         .. S IBX=IBTMP(IBI,IBK)
    123         .. S IBJ=IBJ+1,ARRAY("PRD")=IBJ
    124         .. S ARRAY("PRD",IBJ)=$$PINB^IBCSC5B(+IBX)_U_IBI
    125         ;
    126 CC      ; condition related to employment, auto accident (place), other accident
    127         S IBI=0 F  S IBI=$O(^DGCR(399,IBIFN,"CC",IBI)) Q:'IBI  I $G(^(IBI,0))="02" S ARRAY("CRE")="EMPLOYMENT"
    128         S IBI=0 F  S IBI=$O(^DGCR(399,IBIFN,"OC",IBI)) Q:'IBI  S IBX=$G(^(IBI,0)) I +IBX D
    129         . S IBY=$G(^DGCR(399.1,+IBX,0)) Q:IBY=""
    130         . I $P(IBY,U,9)=1 S ARRAY("CRE")="EMPLOYMENT"
    131         . I $P(IBY,U,9)=2 S ARRAY("CRA")="AUTO ACCIDENT"_U_$$STATE($P(IBX,U,3))
    132         . I $P(IBY,U,9)=3 S ARRAY("CRO")="OTHER ACCIDENT"
    133         Q
    134         ;
    135 STATE(X)        ; returns 2 letter abbreviation for state
    136         Q $P($G(^DIC(5,+X,0)),U,2)
    137 ZIP(X)  ; returns zip in external form
    138         S X=$E(X,1,5)_$S($E(X,6,9)]"":"-"_$E(X,6,9),1:"")
    139         Q X
    140 RTI(X)  ; returns external form of relationship to insured
    141         I X'="" S X=$S(X="01":"PATIENT",X="02":"SPOUSE",X="03":"NATURAL CHILD",X="08":"EMPLOYEE",X="09":"UNKNOWN",X="11":"ORGAN DONOR",X="15":"INJURED PLANTIFF",X="18":"PARENT",1:"")
    142         Q X
    143         ;IBRFN3
     1IBRFN3 ;ALB/ARH - PASS BILL/CLAIM TO AR ;3/18/96
     2 ;;2.0;INTEGRATED BILLING;**61,133,210,309**;21-MAR-94
     3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
     4 ;
     5 ;  Returns information on the bill passed in,  all data returned in external format, for AR's RC project
     6 ;
     7 ;  If the bill can not be found then returns ARRAY=0  (should be called with ARRAY passed by reference)
     8 ;  Otherwise ARRAY=1 and the following array elements may be defined
     9 ;  these array elements will only be defined is there is data to return
     10 ;  those elements that have multiple entries will be in the form ARRAY("SUB",X) where X=1:1:...
     11 ;
     12 ;  ARRAY("BN") = BILL NUMBER
     13 ;  ARRAY("SR") = SENSITIVE RECORD? (Y or N)
     14 ;  ARRAY("STF") = STATEMENT COVERS FROM DATE - first date covered by bill
     15 ;  ARRAY("STT") = STATEMENT COVERS TO DATE - last date covered by bill
     16 ;  ARRAY("TCG") = TOTAL CHARGES^OFFSET AMT (PRIOR PAYMENTS)^OFFSET DESC
     17 ;  ARRAY("TOC") = BILL TYPE (INPATIENT OR OUTPATIENT)
     18 ;  ARRAY("TCF") = BILL FORM TYPE
     19 ;  ARRAY("DFP") = DATE FIRST PRINTED
     20 ;  ARRAY("TAX") = FEDERAL TAX NUMBER - for facility, a site parameter
     21 ;
     22 ;  ARRAY("PIN") = DEBTOR INSURANCE NAME ^ HOSPITAL PROVIDER NUMBER ^ GROUP NAME ^ GROUP NUMBER ^
     23 ;                 NAME OF INSURED ^ SUBSCRIBER ID ^ RELATIONSHIP TO INSURED
     24 ;
     25 ;  ARRAY("PIN","MMA") = DEBTOR MAILING STREET ADDRESS [LINE 1] ^
     26 ;                       MAILING STREET ADDRESS [LINE 2] ^ MAILING STREET ADDRESS [LINE 3] ^ CITY ^
     27 ;                       STATE (ABBREVIATED) ^ ZIP ^ PHONE NUMBER
     28 ;
     29 ;  ARRAY("RVC") = NUMBER OF REVENUE CODES ON BILL
     30 ;  ARRAY("RVC",X) = REVENUE CODE ^ REVENUE CODE DESCRIPTION ^ CHARGE (PER UNIT) ^ UNITS ^
     31 ;                   TOTAL CHARGE FOR REV CODE
     32 ;
     33 ;  ARRAY("OPV") = NUMBER OF OUTPATIENT VISIT DATES ON BILL
     34 ;  ARRAY("OPV",X) = OUTPATIENT VISIT DATE
     35 ;
     36 ;  ARRAY("PRC") = NUMBER OF PROCEDURES ON BILL
     37 ;  ARRAY("PRC",X) = PROCEDURE CODE ^ PROCEDURE DESCRIPTION ^ PROCEDURE DATE ^
     38 ;                   PLACE OF SERVICE CODE ^ PLACE OF SERVICE ^ TYPE OF SERVICE CODE ^ TYPE OF SERVICE
     39 ;
     40 ;  ARRAY("DXS") = NUMBER OF DIAGNOSIS ON BILL
     41 ;  ARRAY("DXS,X) = DIAGNOSIS CODE ^ DIAGNOSIS
     42 ;
     43 ;  ARRAY("RXF") = NUMBER OF PRESCRIPTION REFILLS ON BILL
     44 ;  ARRAY("RXF",X) = PRESCRIPTION # ^ REFILL DATE ^ DRUG NAME ^ DAYS SUPPLY ^ QUANTITY ^ NDC #
     45 ;
     46 ;  ARRAY("PRD") = NUMBER OF PROSTHETIC ITEMS ON BILL
     47 ;  ARRAY("PRD",X) = PROSTHETIC DEVICE ^ DELIVERY DATE
     48 ;
     49 ;  IF CONDITION RELATED TO EMPLOYMENT:  ARRAY("CRE") = "EMPLOYMENT"
     50 ;  IF CONDITION RELATED TO AN AUTO ACCIDENT:  ARRAY("CRA") = "AUTO ACCIDENT" ^ STATE (ABBREVIATION)
     51 ;  IF CONDITION RELATED TO AN OTHER ACCIDENT:  ARRAY("CRO") = "OTHER ACCIDENT"
     52 ;
     53BILL(IBIFN,ARRAY) ; returns array of information on a specific bill, based on RC requirements
     54 ;
     55 N IBI,IBJ,IBK,IBX,IBY,IBTMP,IBD0,IBDU,IBDU1,IBDI1,IBDS,IBDATE
     56 K ARRAY S ARRAY=1 I '$G(IBIFN)!($G(^DGCR(399,+$G(IBIFN),0))="") S ARRAY=0 Q
     57 F IBI=0,"U","U1","S" S @("IBD"_IBI)=$G(^DGCR(399,IBIFN,IBI))
     58 S IBX=$P(IBD0,U,21),IBX=$S(IBX="P":"I1",IBX="S":"I2",IBX="T":"I3",1:" ")
     59 S IBDI1=$G(^DGCR(399,IBIFN,IBX))
     60 ;
     61 S ARRAY("TCG")=$P(IBDU1,U,1,3)
     62 S ARRAY("BN")=$P(IBD0,U,1)
     63 S ARRAY("SR")=$S($P(IBDU,U,5)=1:"Y",1:"N")
     64 S ARRAY("STF")=$P(IBDU,U,1)
     65 S ARRAY("STT")=$P(IBDU,U,2)
     66 S ARRAY("TOC")=$S($P(IBD0,U,5)<3:"INPATIENT",1:"OUTPATIENT")
     67 S ARRAY("TCF")=$$FTN^IBCU3($$FT^IBCU3(IBIFN))
     68 S ARRAY("DFP")=$P(IBDS,U,12)
     69 S ARRAY("TAX")=$P($G(^IBE(350.9,1,1)),U,5)
     70 ;
     71INS ; insurance information
     72 S IBX=$G(^DGCR(399,+IBIFN,"M"))
     73 S ARRAY("PIN")=$P(IBX,U,4)_U_$P($G(^DIC(36,+IBDI1,0)),U,11)_U_$P(IBDI1,U,15)_U_$P(IBDI1,U,3)_U_$P(IBDI1,U,17)_U_$P(IBDI1,U,2)_U_$$RTI($P(IBDI1,U,16))
     74 S ARRAY("PIN","MMA")=$P(IBX,U,5)_U_$P(IBX,U,6)_U_$P($G(^DGCR(399,+IBIFN,"M1")),U,1)_U_$P(IBX,U,7)_U_$$STATE($P(IBX,U,8))
     75 S ARRAY("PIN","MMA")=ARRAY("PIN","MMA")_U_$$ZIP($P(IBX,U,9))_U_$P($G(^DIC(36,+IBDI1,.13)),U,1)
     76 ;
     77RC ; revenue codes
     78 S (IBI,IBJ)=0,ARRAY("RVC")=IBJ F  S IBI=$O(^DGCR(399,IBIFN,"RC",IBI)) Q:'IBI  D
     79 . S IBX=$G(^DGCR(399,IBIFN,"RC",IBI,0)) Q:IBX=""  S IBY=$G(^DGCR(399.2,+IBX,0))
     80 . S IBJ=IBJ+1,ARRAY("RVC")=IBJ
     81 . S ARRAY("RVC",IBJ)=$P(IBY,U,1)_U_$P(IBY,U,2)_U_$P(IBX,U,2)_U_$P(IBX,U,3)_U_$P(IBX,U,4)
     82 ;
     83OPV ; outpatient visit dates
     84 S (IBI,IBJ)=0,ARRAY("OPV")=IBJ F  S IBI=$O(^DGCR(399,IBIFN,"OP",IBI)) Q:'IBI  D
     85 . S IBX=$G(^DGCR(399,IBIFN,"OP",IBI,0)) Q:'IBX
     86 . S IBJ=IBJ+1,ARRAY("OPV")=IBJ
     87 . S ARRAY("OPV",IBJ)=+IBX
     88 ;
     89PRC ; procedure codes
     90 S (IBI,IBJ)=0,ARRAY("PRC")=IBJ F  S IBI=$O(^DGCR(399,IBIFN,"CP",IBI)) Q:'IBI  D
     91 . S IBX=$G(^DGCR(399,IBIFN,"CP",IBI,0)),IBY=""
     92 . S IBDATE=$P(IBX,U,2) I 'IBDATE S IBDATE=$$BDATE^IBACSV(IBIFN)
     93 . S IBY=$P($$PRCD^IBCEF1($P(IBX,U),1,IBDATE),U,2,3)
     94 . Q:$P(IBY,U)=""
     95 . S IBJ=IBJ+1,ARRAY("PRC")=IBJ
     96 . S ARRAY("PRC",IBJ)=IBY_U_$P(IBX,U,2)
     97 . S IBY=$G(^IBE(353.1,+$P(IBX,U,9),0)),ARRAY("PRC",IBJ)=ARRAY("PRC",IBJ)_U_$P(IBY,U)_U_$P(IBY,U,3)
     98 . S IBY=$G(^IBE(353.2,+$P(IBX,U,10),0)),ARRAY("PRC",IBJ)=ARRAY("PRC",IBJ)_U_$P(IBY,U)_U_$P(IBY,U,3)
     99 ;
     100DX ; diagnosis codes
     101 K IBTMP D SET^IBCSC4D(IBIFN,"",.IBTMP)
     102 S IBDATE=$$BDATE^IBACSV(IBIFN)
     103 S (IBI,IBJ)=0,ARRAY("DXS")=IBJ F  S IBI=$O(IBTMP(IBI)) Q:'IBI  D
     104 . S IBX=IBTMP(IBI),IBY=$$ICD9^IBACSV(+IBX,IBDATE) Q:IBY=""
     105 . S IBJ=IBJ+1,ARRAY("DXS")=IBJ
     106 . S ARRAY("DXS",IBJ)=$P(IBY,U)_U_$P(IBY,U,3)
     107 ;
     108RX ; prescription refills
     109 K IBTMP D SET^IBCSC5A(IBIFN,.IBTMP)
     110 S (IBI,IBJ)=0,ARRAY("RXF")=IBJ F  S IBI=$O(IBTMP(IBI)) Q:'IBI  D
     111 . S IBK=0 F  S IBK=$O(IBTMP(IBI,IBK)) Q:'IBK  D
     112 .. S IBX=IBTMP(IBI,IBK) D ZERO^IBRXUTL(+$P(IBX,U,2)) S IBY=$G(^TMP($J,"IBDRUG",+$P(IBX,U,2),.01))
     113 .. S IBJ=IBJ+1,ARRAY("RXF")=IBJ
     114 .. S ARRAY("RXF",IBJ)=IBI_U_IBK_U_IBY_U_$P(IBX,U,3)_U_$P(IBX,U,4)_U_$P(IBX,U,5)
     115 .. K ^TMP($J,"IBDRUG")
     116 .. Q
     117 ;
     118PD ; prosthetic items
     119 K IBTMP D SET^IBCSC5B(IBIFN,.IBTMP)
     120 S (IBI,IBJ)=0,ARRAY("PRD")=IBJ F  S IBI=$O(IBTMP(IBI)) Q:'IBI  D
     121 . S IBK=0 F  S IBK=$O(IBTMP(IBI,IBK)) Q:'IBK  D
     122 .. S IBX=IBTMP(IBI,IBK)
     123 .. S IBJ=IBJ+1,ARRAY("PRD")=IBJ
     124 .. S ARRAY("PRD",IBJ)=$P($$PIN^IBCSC5B(IBK),U,2)_U_IBI
     125 ;
     126CC ; condition related to employment, auto accident (place), other accident
     127 S IBI=0 F  S IBI=$O(^DGCR(399,IBIFN,"CC",IBI)) Q:'IBI  I $G(^(IBI,0))="02" S ARRAY("CRE")="EMPLOYMENT"
     128 S IBI=0 F  S IBI=$O(^DGCR(399,IBIFN,"OC",IBI)) Q:'IBI  S IBX=$G(^(IBI,0)) I +IBX D
     129 . S IBY=$G(^DGCR(399.1,+IBX,0)) Q:IBY=""
     130 . I $P(IBY,U,9)=1 S ARRAY("CRE")="EMPLOYMENT"
     131 . I $P(IBY,U,9)=2 S ARRAY("CRA")="AUTO ACCIDENT"_U_$$STATE($P(IBX,U,3))
     132 . I $P(IBY,U,9)=3 S ARRAY("CRO")="OTHER ACCIDENT"
     133 Q
     134 ;
     135STATE(X) ; returns 2 letter abbreviation for state
     136 Q $P($G(^DIC(5,+X,0)),U,2)
     137ZIP(X) ; returns zip in external form
     138 S X=$E(X,1,5)_$S($E(X,6,9)]"":"-"_$E(X,6,9),1:"")
     139 Q X
     140RTI(X) ; returns external form of relationship to insured
     141 I X'="" S X=$S(X="01":"PATIENT",X="02":"SPOUSE",X="03":"NATURAL CHILD",X="08":"EMPLOYEE",X="09":"UNKNOWN",X="11":"ORGAN DONOR",X="15":"INJURED PLANTIFF",X="18":"PARENT",1:"")
     142 Q X
     143 ;IBRFN3

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBRFN4.m

    r613 r623  
    1 IBRFN4  ;ALB/TMK - Supported functions for AR/IB DATA EXTRACT ;15-FEB-2005
    2         ;;2.0;INTEGRATED BILLING;**301,305,389**;21-MAR-94;Build 6
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5 IBAREXT(IBIFN,IBD)      ; Returns data for claim IBIFN for IB/AR Extract
    6         ; Data returned (pieces):
    7         ; 1-MEDICARE Status (0=not MRA secondary, 1=MRA secondary)
    8         ; 2-Last MRA requested date "S";7 (7 - INTERNAL)
    9         ; 3-Last Electronic extract date  "TX";2 (21 - INTERNAL)
    10         ; 4-Printed via EDI  "TX";7  (26 - EXTERNAL)
    11         ; 5-Force Claim to Print  "TX";8  (27 - EXTERNAL)
    12         ; 6-Claim MRA Status  "TX";5  (24 - EXTERNAL)
    13         ; 7-MRA recorded date  "TX";3  (22 - INTERNAL)
    14         ; 8-Bill cancelled date  "S";17  (17 - INTERNAL)
    15         ; 9-form type  0;19   (.19 - EXTERNAL)
    16         ; 10-Current Payer  $$CURR^IBCEF2(IBIFN) returns IEN;NAME (file 36)
    17         ; 11-DRG 0;8==> file 45 (9 - EXTERNAL)
    18         ; 12-ECME #  "M1";8 (460 - EXTERNAL)
    19         ; 13-NON-VA Facility
    20         ; 14-#Days Site Not Responsible for MRA ($$DAYS(IBIFN))
    21         ; 15-National VA id number for Ins Verification (365.12;.02 - INTERNAL)
    22         ; 16-Payer name (file 365.12;.01)
    23         ; 17-Offset Amount (202-INTERNAL)
    24         ;
    25         ; IBD("PRD",seq #)=prosthetic item name^date^bill ien
    26         ; IBD("IN")= TYPE OF PLAN NAME ^ GROUP NUMBER ^ RELATIONSHIP TO INSURED
    27         ;   ^ SOURCE OF INFO ^ EDI ID NUMBER - INST ^ EDI ID NUMBER - PROF
    28         ;   ^ INSURANCE REIMBURSE
    29         ; IBD("IN","MMA")= MAILING STREET ADDRESS [LINE 1] ^
    30         ;   ^ MAILING STREET ADDRESS [LINE 2] ^ CITY ^ STATE NAME  ^  ZIP
    31         ;
    32         N IB,IBI,IBJ,IBK,IBX,IBNODE,IBTMP,IBIN,Z
    33         F IBNODE=0,"S","TX","M","U1" S IB(IBNODE)=$G(^DGCR(399,IBIFN,IBNODE))
    34         S IBD=$S($$MRASEC^IBCEF4(IBIFN):1,1:0)
    35         S $P(IBD,U,2)=$P(IB("S"),U,7),$P(IBD,U,3)=$P(IB("TX"),U,2)
    36         S $P(IBD,U,4)=$$GET1^DIQ(399,IBIFN_",",26,"E"),$P(IBD,U,5)=$$GET1^DIQ(399,IBIFN_",",27,"E")
    37         S $P(IBD,U,6)=$$GET1^DIQ(399,IBIFN_",",24,"E"),$P(IBD,U,7)=$P(IB("TX"),U,3)
    38         S $P(IBD,U,8)=$P(IB("S"),U,17),$P(IBD,U,9)=$$GET1^DIQ(399,IBIFN_",",.19,"E")
    39         S Z=$$CURR^IBCEF2(IBIFN),$P(IBD,U,10)=Z_$S(Z:";"_$P($G(^DIC(36,Z,0)),U),1:"")
    40         S Z=$P($G(^DIC(36,+Z,3)),U,10),$P(IBD,U,15)=$P($G(^IBE(365.12,+Z,0)),U,2),$P(IBD,U,16)=$P($G(^(0)),U)
    41         S Z=$P(IB(0),U,8),$P(IBD,U,11)=$S(Z:$$GET1^DIQ(45,Z_",",9,"E"),1:"")
    42         S $P(IBD,U,12)=$$GET1^DIQ(399,IBIFN_",",460,"E")
    43         S Z=$P($G(^DGCR(399,IBIFN,"U2")),U,10),$P(IBD,U,13)=$S(Z:$P($G(^IBA(355.93,Z,0)),U,1),1:"")
    44         ;
    45         S $P(IBD,U,14)=$$DAYS(IBIFN)
    46         S $P(IBD,U,17)=$P(IB("U1"),U,2)
    47         ;
    48         K IBTMP D SET^IBCSC5B(IBIFN,.IBTMP)
    49         S (IBI,IBJ)=0 F  S IBI=$O(IBTMP(IBI)) Q:'IBI  D
    50         . S IBK=0 F  S IBK=$O(IBTMP(IBI,IBK)) Q:'IBK  D
    51         .. S IBX=IBTMP(IBI,IBK)
    52         .. S IBJ=IBJ+1
    53         .. S IBD("PRD",IBJ)=$$PINB^IBCSC5B(+IBX)_U_IBI_U_+IBTMP
    54         ;
    55         S Z=" ",IBD("IN")="",DFN=+$P(IB(0),U,2)
    56         F  S Z=$O(^DPT(DFN,.312,Z),-1) Q:Z=""  D  Q:Z=""
    57         . S IBIN=$G(^DPT(DFN,.312,Z,0))
    58         . I +IB("M")=+IBIN D
    59         .. N IBQ,IBP
    60         .. S IBP=+$P(IBIN,U,18),IBQ=$G(^IBA(355.3,+IBP,0))
    61         .. S IBD("IN")=$S($P(IBQ,U,9):$$GET1^DIQ(355.3,IBP_",",.09,"E"),1:"")_U_$P(IBQ,U,4)_U_$P(IBIN,U,6)_U_$P($G(^DPT(DFN,.312,Z,1)),U,9)
    62         .. S Z=""
    63         ;
    64         S Z=$G(^DIC(36,+IB("M"),3))
    65         S $P(IBD("IN"),U,5)=$P(Z,U,4),$P(IBD("IN"),U,6)=$P(Z,U,2)
    66         S $P(IBD("IN"),U,7)=$$GET1^DIQ(36,+IB("M")_",",1,"I")
    67         S Z=$G(^DIC(36,+IB("M"),.11))
    68         S IBD("IN","MMA")=$P(Z,U,1)_U_$P(Z,U,2)_U_$P(Z,U,4)_U_$S($P(Z,U,5):$P($G(^DIC(5,$P(Z,U,5),0)),U,1),1:"")_U_$P(Z,U,6)
    69         ;
    70         Q IBD
    71         ;
    72 IBACT(IBIFN,IBARRY)     ; Returns IB actions for bill ien IBIFN
    73         ;IBARRY should be passed by reference and returns:
    74         ;
    75         ; IBARRY(seq)=AR bill #^reference #^external STATUS^IB ACTION TYPE NAME
    76         ;             ^UNITS^TOTAL CHARGE^DT BILLD FROM^DT BILLD TO^AR BILL IEN
    77         ;             ^DT ENTRY ADDED^PATIENT SSN^EVENT DATE^RESULTING FROM
    78         ;             ^INSTITUTION IEN
    79         ;
    80         N IBNA,IB,IB0,DFN,IBCT,Z
    81         S IBNA=$$BN1^PRCAFN(IBIFN),IB="",IBCT=0
    82         F  S IB=$O(^IB("ABIL",IBNA,IB)) Q:IB=""  D
    83         . S IBCT=IBCT+1
    84         . S IB0=$G(^IB(IB,0))
    85         . I $G(DFN)="" S DFN=$P(IB0,U,2)
    86         . ;
    87         . S IBARRY=IBNA_U_$P(IB0,U,1)_U_$$GET1^DIQ(350,IB_",",.05,"E")
    88         . S Z=$P(IB0,U,3)
    89         . S IBARRY=IBARRY_U_$S(Z'="":$P($G(^IBE(350.1,Z,0)),U,1),1:"")
    90         . S IBARRY=IBARRY_U_$P(IB0,U,6) ; UNITS
    91         . S IBARRY=IBARRY_U_$P(IB0,U,7) ; TOTAL CHARGE
    92         . S IBARRY=IBARRY_U_$P(IB0,U,14) ; DT BILLD FROM
    93         . S IBARRY=IBARRY_U_$P(IB0,U,15) ; DT BILLD TO
    94         . S IBARRY=IBARRY_U_$P(IB0,U,11) ; AR BILL #
    95         . S IBARRY=IBARRY_U_$P($P($G(^IB(IB,1)),U,2),".",1) ; DT ENTRY ADDED
    96         . S IBARRY=IBARRY_U_$P(^DPT(DFN,0),U,9) ; SSN
    97         . S IBARRY=IBARRY_U_$P(IB0,U,17) ; EVENT DT
    98         . S IBARRY=IBARRY_U_$P(IB0,U,4) ;RESULTING FROM
    99         . S IBARRY=IBARRY_U_$P(IB0,U,13) ; Institution
    100         . S IBARRY(IBCT)=IBARRY,IBARRY=""
    101         Q
    102         ;
    103 PREREG(IBBDT,IBEDT)     ;Returns Pre-registration data
    104         N IBDATA
    105         S IBDATA=$$IBAR^IBJDIPR(IBBDT,IBEDT)
    106         Q IBDATA
    107         ;
    108 BUFFER(IBBDT,IBEDT)     ;Returns Buffer data
    109         N IBDATA
    110         S IBDATA=$$IBAR^IBCNBOA(IBBDT,IBEDT)
    111         Q IBDATA
    112         ;
    113 DAYS(IBIFN)     ; Returns # days site not responsible for MRA
    114         N X,X1,X2,D0
    115         S X="" ;No. of days
    116         G:'$P(IBD,U,2) DAYSQ
    117         S X2=$P(IBD,U,2) ;MRA Request Date
    118         S X1=$P(IBD,U,7) ;MRA Recorded Date
    119         G:'$$MRASEC^IBCEF4(IBIFN) DAYSQ ; Not MEDICARE secondary
    120         I 'X1!(X1<X2) S X1=DT
    121         D ^%DTC
    122 DAYSQ   Q X
    123         ;
    124 REJ(IBIFN)      ; Returns 1 if any rejects found for MRA secondary claim or for
    125         ; any preceding claims it was cancelled/cloned from
    126         N X,Y,I,X1,X2,X3,D0,CURSEQ
    127         S Y=0 ;Y=REJECT FLAG
    128         G:'$$MRASEC^IBCEF4(IBIFN) REJQ ; Not MEDICARE secondary
    129         S CURSEQ=$$COBN^IBCEF(IBIFN),X1=+$P($G(^DGCR(399,IBIFN,0)),U,15)
    130         S D0=IBIFN
    131         F  D  Q:'D0!Y
    132         . ; claim copied from not cancelled and not MRA secondary claim
    133         . I X1,$P($G(^DGCR(399,X1,0)),U,13)'=7,X1'=IBIFN S D0="" Q
    134         . I X1,$P($G(^DGCR(399,X1,0)),U,19)'=$P($G(^DGCR(399,D0,0)),U,19) S D0="" Q
    135         . S I=0 F  S I=$O(^IBM(361,"B",D0,I)) Q:'I  D  Q:Y
    136         .. S X2=$G(^IBM(361,I,0))
    137         .. Q:$P(X2,U,3)'="R"!'$P(X2,U,11)  ;No reject or no transmit bill
    138         .. S X3=$TR($P($G(^IBA(364,+$P(X2,U,11),0)),U,8),"PST","123") ;status msg seq
    139         .. Q:X3'=(CURSEQ-1)
    140         .. S Y=1
    141         . I 'Y S D0=X1,X1=+$P($G(^DGCR(399,X1,0)),U,15) S:X1=D0 D0="" Q
    142 REJQ    Q Y
     1IBRFN4 ;ALB/TMK - Supported functions for AR/IB DATA EXTRACT ;15-FEB-2005
     2 ;;2.0;INTEGRATED BILLING;**301,305**;21-MAR-94
     3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
     4 ;
     5IBAREXT(IBIFN,IBD) ; Returns data for claim IBIFN for IB/AR Extract
     6 ; Data returned (pieces):
     7 ; 1-MEDICARE Status (0=not MRA secondary, 1=MRA secondary)
     8 ; 2-Last MRA requested date "S";7 (7 - INTERNAL)
     9 ; 3-Last Electronic extract date  "TX";2 (21 - INTERNAL)
     10 ; 4-Printed via EDI  "TX";7  (26 - EXTERNAL)
     11 ; 5-Force Claim to Print  "TX";8  (27 - EXTERNAL)
     12 ; 6-Claim MRA Status  "TX";5  (24 - EXTERNAL)
     13 ; 7-MRA recorded date  "TX";3  (22 - INTERNAL)
     14 ; 8-Bill cancelled date  "S";17  (17 - INTERNAL)
     15 ; 9-form type  0;19   (.19 - EXTERNAL)
     16 ; 10-Current Payer  $$CURR^IBCEF2(IBIFN) returns IEN;NAME (file 36)
     17 ; 11-DRG 0;8==> file 45 (9 - EXTERNAL)
     18 ; 12-ECME #  "M1";8 (460 - EXTERNAL)
     19 ; 13-NON-VA Facility
     20 ; 14-#Days Site Not Responsible for MRA ($$DAYS(IBIFN))
     21 ; 15-National VA id number for Ins Verification (365.12;.02 - INTERNAL)
     22 ; 16-Payer name (file 365.12;.01)
     23 ; 17-Offset Amount (202-INTERNAL)
     24 ;
     25 ; IBD("PRD",seq #)=prosthetic item name^date^bill ien
     26 ; IBD("IN")= TYPE OF PLAN NAME ^ GROUP NUMBER ^ RELATIONSHIP TO INSURED
     27 ;   ^ SOURCE OF INFO ^ EDI ID NUMBER - INST ^ EDI ID NUMBER - PROF
     28 ;   ^ INSURANCE REIMBURSE
     29 ; IBD("IN","MMA")= MAILING STREET ADDRESS [LINE 1] ^
     30 ;   ^ MAILING STREET ADDRESS [LINE 2] ^ CITY ^ STATE NAME  ^  ZIP
     31 ;
     32 N IB,IBI,IBJ,IBK,IBX,IBNODE,IBTMP,IBIN,Z
     33 F IBNODE=0,"S","TX","M","U1" S IB(IBNODE)=$G(^DGCR(399,IBIFN,IBNODE))
     34 S IBD=$S($$MRASEC^IBCEF4(IBIFN):1,1:0)
     35 S $P(IBD,U,2)=$P(IB("S"),U,7),$P(IBD,U,3)=$P(IB("TX"),U,2)
     36 S $P(IBD,U,4)=$$GET1^DIQ(399,IBIFN_",",26,"E"),$P(IBD,U,5)=$$GET1^DIQ(399,IBIFN_",",27,"E")
     37 S $P(IBD,U,6)=$$GET1^DIQ(399,IBIFN_",",24,"E"),$P(IBD,U,7)=$P(IB("TX"),U,3)
     38 S $P(IBD,U,8)=$P(IB("S"),U,17),$P(IBD,U,9)=$$GET1^DIQ(399,IBIFN_",",.19,"E")
     39 S Z=$$CURR^IBCEF2(IBIFN),$P(IBD,U,10)=Z_$S(Z:";"_$P($G(^DIC(36,Z,0)),U),1:"")
     40 S Z=$P($G(^DIC(36,+Z,3)),U,10),$P(IBD,U,15)=$P($G(^IBE(365.12,+Z,0)),U,2),$P(IBD,U,16)=$P($G(^(0)),U)
     41 S Z=$P(IB(0),U,8),$P(IBD,U,11)=$S(Z:$$GET1^DIQ(45,Z_",",9,"E"),1:"")
     42 S $P(IBD,U,12)=$$GET1^DIQ(399,IBIFN_",",460,"E")
     43 S Z=$P($G(^DGCR(399,IBIFN,"U2")),U,10),$P(IBD,U,13)=$S(Z:$P($G(^IBA(355.93,Z,0)),U,1),1:"")
     44 ;
     45 S $P(IBD,U,14)=$$DAYS(IBIFN)
     46 S $P(IBD,U,17)=$P(IB("U1"),U,2)
     47 ;
     48 K IBTMP D SET^IBCSC5B(IBIFN,.IBTMP)
     49 S (IBI,IBJ)=0 F  S IBI=$O(IBTMP(IBI)) Q:'IBI  D
     50 . S IBK=0 F  S IBK=$O(IBTMP(IBI,IBK)) Q:'IBK  D
     51 .. S IBX=IBTMP(IBI,IBK)
     52 .. S IBJ=IBJ+1
     53 .. S IBD("PRD",IBJ)=$P($$PIN^IBCSC5B(IBK),U,2)_U_IBI_U_+IBTMP
     54 ;
     55 S Z=" ",IBD("IN")="",DFN=+$P(IB(0),U,2)
     56 F  S Z=$O(^DPT(DFN,.312,Z),-1) Q:Z=""  D  Q:Z=""
     57 . S IBIN=$G(^DPT(DFN,.312,Z,0))
     58 . I +IB("M")=+IBIN D
     59 .. N IBQ,IBP
     60 .. S IBP=+$P(IBIN,U,18),IBQ=$G(^IBA(355.3,+IBP,0))
     61 .. S IBD("IN")=$S($P(IBQ,U,9):$$GET1^DIQ(355.3,IBP_",",.09,"E"),1:"")_U_$P(IBQ,U,4)_U_$P(IBIN,U,6)_U_$P($G(^DPT(DFN,.312,Z,1)),U,9)
     62 .. S Z=""
     63 ;
     64 S Z=$G(^DIC(36,+IB("M"),3))
     65 S $P(IBD("IN"),U,5)=$P(Z,U,4),$P(IBD("IN"),U,6)=$P(Z,U,2)
     66 S $P(IBD("IN"),U,7)=$$GET1^DIQ(36,+IB("M")_",",1,"I")
     67 S Z=$G(^DIC(36,+IB("M"),.11))
     68 S IBD("IN","MMA")=$P(Z,U,1)_U_$P(Z,U,2)_U_$P(Z,U,4)_U_$S($P(Z,U,5):$P($G(^DIC(5,$P(Z,U,5),0)),U,1),1:"")_U_$P(Z,U,6)
     69 ;
     70 Q IBD
     71 ;
     72IBACT(IBIFN,IBARRY) ; Returns IB actions for bill ien IBIFN
     73 ;IBARRY should be passed by reference and returns:
     74 ;
     75 ; IBARRY(seq)=AR bill #^reference #^external STATUS^IB ACTION TYPE NAME
     76 ;             ^UNITS^TOTAL CHARGE^DT BILLD FROM^DT BILLD TO^AR BILL IEN
     77 ;             ^DT ENTRY ADDED^PATIENT SSN^EVENT DATE^RESULTING FROM
     78 ;             ^INSTITUTION IEN
     79 ;
     80 N IBNA,IB,IB0,DFN,IBCT,Z
     81 S IBNA=$$BN1^PRCAFN(IBIFN),IB="",IBCT=0
     82 F  S IB=$O(^IB("ABIL",IBNA,IB)) Q:IB=""  D
     83 . S IBCT=IBCT+1
     84 . S IB0=$G(^IB(IB,0))
     85 . I $G(DFN)="" S DFN=$P(IB0,U,2)
     86 . ;
     87 . S IBARRY=IBNA_U_$P(IB0,U,1)_U_$$GET1^DIQ(350,IB_",",.05,"E")
     88 . S Z=$P(IB0,U,3)
     89 . S IBARRY=IBARRY_U_$S(Z'="":$P($G(^IBE(350.1,Z,0)),U,1),1:"")
     90 . S IBARRY=IBARRY_U_$P(IB0,U,6) ; UNITS
     91 . S IBARRY=IBARRY_U_$P(IB0,U,7) ; TOTAL CHARGE
     92 . S IBARRY=IBARRY_U_$P(IB0,U,14) ; DT BILLD FROM
     93 . S IBARRY=IBARRY_U_$P(IB0,U,15) ; DT BILLD TO
     94 . S IBARRY=IBARRY_U_$P(IB0,U,11) ; AR BILL #
     95 . S IBARRY=IBARRY_U_$P($P($G(^IB(IB,1)),U,2),".",1) ; DT ENTRY ADDED
     96 . S IBARRY=IBARRY_U_$P(^DPT(DFN,0),U,9) ; SSN
     97 . S IBARRY=IBARRY_U_$P(IB0,U,17) ; EVENT DT
     98 . S IBARRY=IBARRY_U_$P(IB0,U,4) ;RESULTING FROM
     99 . S IBARRY=IBARRY_U_$P(IB0,U,13) ; Institution
     100 . S IBARRY(IBCT)=IBARRY,IBARRY=""
     101 Q
     102 ;
     103PREREG(IBBDT,IBEDT) ;Returns Pre-registration data
     104 N IBDATA
     105 S IBDATA=$$IBAR^IBJDIPR(IBBDT,IBEDT)
     106 Q IBDATA
     107 ;
     108BUFFER(IBBDT,IBEDT) ;Returns Buffer data
     109 N IBDATA
     110 S IBDATA=$$IBAR^IBCNBOA(IBBDT,IBEDT)
     111 Q IBDATA
     112 ;
     113DAYS(IBIFN) ; Returns # days site not responsible for MRA
     114 N X,X1,X2,D0
     115 S X="" ;No. of days
     116 G:'$P(IBD,U,2) DAYSQ
     117 S X2=$P(IBD,U,2) ;MRA Request Date
     118 S X1=$P(IBD,U,7) ;MRA Recorded Date
     119 G:'$$MRASEC^IBCEF4(IBIFN) DAYSQ ; Not MEDICARE secondary
     120 I 'X1!(X1<X2) S X1=DT
     121 D ^%DTC
     122DAYSQ Q X
     123 ;
     124REJ(IBIFN) ; Returns 1 if any rejects found for MRA secondary claim or for
     125 ; any preceding claims it was cancelled/cloned from
     126 N X,Y,I,X1,X2,X3,D0,CURSEQ
     127 S Y=0 ;Y=REJECT FLAG
     128 G:'$$MRASEC^IBCEF4(IBIFN) REJQ ; Not MEDICARE secondary
     129 S CURSEQ=$$COBN^IBCEF(IBIFN),X1=+$P($G(^DGCR(399,IBIFN,0)),U,15)
     130 S D0=IBIFN
     131 F  D  Q:'D0!Y
     132 . ; claim copied from not cancelled and not MRA secondary claim
     133 . I X1,$P($G(^DGCR(399,X1,0)),U,13)'=7,X1'=IBIFN S D0="" Q
     134 . I X1,$P($G(^DGCR(399,X1,0)),U,19)'=$P($G(^DGCR(399,D0,0)),U,19) S D0="" Q
     135 . S I=0 F  S I=$O(^IBM(361,"B",D0,I)) Q:'I  D  Q:Y
     136 .. S X2=$G(^IBM(361,I,0))
     137 .. Q:$P(X2,U,3)'="R"!'$P(X2,U,11)  ;No reject or no transmit bill
     138 .. S X3=$TR($P($G(^IBA(364,+$P(X2,U,11),0)),U,8),"PST","123") ;status msg seq
     139 .. Q:X3'=(CURSEQ-1)
     140 .. S Y=1
     141 . I 'Y S D0=X1,X1=+$P($G(^DGCR(399,X1,0)),U,15) S:X1=D0 D0="" Q
     142REJQ Q Y

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBTOBI1.m

    r613 r623  
    1 IBTOBI1 ;ALB/AAS - CLAIMS TRACKING BILLING INFORMATION PRINT ;27-OCT-93
    2         ;;2.0;INTEGRATED BILLING;**276,377**;21-MAR-94;Build 23
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5 %       ;
    6         F IBTAG="INS","BI","SC","CLIN^IBTOBI4","IR^IBTOBI2","HR^IBTOBI3" D @IBTAG Q:IBQUIT
    7         Q
    8         ;
    9 INS     ; -- print ins. stuff
    10         N TAB,TAB2,IBALLIN,IBDT,IBINS,IBCNT,I,X,IBI,PHON,PHON2,PHON3,P,IBI
    11         S TAB=5,TAB2=45,IBALLIN=1
    12         S IBDT=$P(IBTRND,"^",6)
    13         I '$G(IBDT) S IBDT=DT
    14         W !,"  Insurance Information "
    15         ;
    16         D ALL^IBCNS1(DFN,"IBINS",1,IBDT)
    17         I $G(IBINS(0))<1 W !,?TAB,"No Insurance Information",!!! G INSQ
    18         S IBI=0,IBCNT=0 F  S IBI=$O(IBINS(IBI)) Q:'IBI!(IBQUIT)  S IBINS=IBINS(IBI,0) D  Q:IBQUIT
    19         .S IBCNT=IBCNT+1
    20         .I ($Y+8)>IOSL D HDR^IBTOBI Q:IBQUIT
    21         .I IBCNT>1 W !
    22         .W !?TAB,"     Ins. Co "_IBCNT_": ",$E($P($G(^DIC(36,+IBINS,0)),"^"),1,23)
    23         .S X=$G(^DIC(36,+IBINS,.13))
    24         .S PHON=$S($P(X,"^",3)'="":$P(X,"^",3),1:$P(X,"^"))
    25         .S PHON2=$S($P(X,"^",2)'="":$P(X,"^",2),1:$P(X,"^"))
    26         .S P=$S($P(IBETYP,"^",3)=1:5,$P(IBETYP,"^",3)=2:6,$P(IBETYP,"^",3)=3:11,1:1)
    27         .S PHON3=$S($P(X,"^",P)'="":$P(X,"^",P),1:$P(X,"^"))
    28         .W ?TAB2,"Pre-Cert Phone: ",PHON
    29         .W !?TAB,"        Subsc.: ",$P(IBINS,"^",17)
    30         .W ?TAB2,"          Type: ",$E($P($G(^IBE(355.1,+$P($G(^IBA(355.3,+$P(IBINS,"^",18),0)),"^",9),0)),"^"),1,18)
    31         .W !?TAB,"     Subsc. ID: ",$P(IBINS,"^",2)
    32         .W ?TAB2,"         Group: ",$$GRP^IBCNS($P(IBINS,"^",18))
    33         .W !?TAB,"     Coord Ben: ",$E($$EXPAND^IBTRE(2.312,.2,$P(IBINS,"^",20)),1,18)
    34         .W ?TAB2," Billing Phone: ",PHON2
    35         .W !,?TAB,"Filing Time Fr: ",$$EXPAND^IBTRE(36,.12,$P($G(^DIC(36,+IBINS,0)),"^",12))
    36         .W ?TAB2,"  Claims Phone: ",PHON3
    37         .S X=$P($G(IBINS(IBI,1)),"^",8) I X'="" W !,"     Policy Comment: " W:($L(X)+23)>IOM ! W " ",X
    38         .D COMM(+$P(IBINS,"^",18))
    39         .Q:IBQUIT
    40         .W !?30,"-----------------------------------"
    41         W:'IBQUIT !?4,$TR($J(" ",IOM-8)," ","-"),!
    42 INSQ    Q
    43         ;
    44 BI      ; -- print billing information
    45         Q:$D(IBCTHDR)
    46         I ($Y+8)>IOSL D HDR^IBTOBI Q:IBQUIT
    47 BI1     W !,"  Billing Information "
    48         N IBDGCR,IBDGCRU1,IBDGCRU,IBAMNT,IBD,I,IBIFN,IBLN,IBECME
    49         S IBIFN=+$P(IBTRND,"^",11)
    50         S IBDGCR=$G(^DGCR(399,IBIFN,0)),IBDGCRU1=$G(^("U1")),IBDGCRU=$G(^("U"))
    51         S IBECME=$P($P($G(^DGCR(399,IBIFN,"M1")),U,8),";")
    52         S IBAMNT=$$BILLD^IBTRED1(IBTRN)
    53         S IBLN=0
    54         S IBLN=IBLN+1,IBD(IBLN,1)="  Initial Bill: "_$P(IBDGCR,U,1)
    55         I IBECME D
    56         . S IBD(IBLN,1)=IBD(IBLN,1)_"e"
    57         . S IBLN=IBLN+1,IBD(IBLN,1)="   ECME Number: "_IBECME
    58         S IBLN=IBLN+1,IBD(IBLN,1)="   Bill Status: "_$E($$EXPAND^IBTRE(399,.13,$P(IBDGCR,U,13)),1,14)
    59         S IBLN=IBLN+1,IBD(IBLN,1)=" Total Charges: $ "_$J($P(IBAMNT,"^"),8)
    60         S IBLN=IBLN+1,IBD(IBLN,1)="   Amount Paid: $ "_$J($P(IBAMNT,"^",2),8)
    61         ;
    62         I $P(IBTRND,U,19) D
    63         . S IBLN=IBLN+1,IBD(IBLN,1)="Reason Not Billable: "_$$EXPAND^IBTRE(356,.19,$P(IBTRND,U,19))
    64         . S IBLN=IBLN+1,IBD(IBLN,1)="Additional Comment: "_$P(IBTRND1,U,8)
    65         . Q
    66         ;
    67         I '$P(IBTRND,U,19),$L($P(IBTRND1,U,8))>0 S IBLN=IBLN+1,IBD(IBLN,1)="Additional Comment: "_$P(IBTRND1,U,8)
    68         ;
    69         S IBD(1,2)="Estimated Recv (Pri): $ "_$J($P(IBTRND,"^",21),8)
    70         S IBD(2,2)="Estimated Recv (Sec): $ "_$J($P(IBTRND,"^",22),8)
    71         S IBD(3,2)="Estimated Recv (ter): $ "_$J($P(IBTRND,"^",23),8)
    72         S IBD(4,2)="  Means Test Charges: $ "_$J($P(IBTRND,"^",28),8)
    73         ;
    74         S I=0 F  S I=$O(IBD(I)) Q:'I  W !,$G(IBD(I,1)),?39,$E($G(IBD(I,2)),1,36)
    75         W:'IBQUIT !,?4,$TR($J(" ",IOM-8)," ","-")
    76         Q
    77         ;
    78 SC      ; -- print SC information
    79         I ($Y+7)>IOSL D HDR^IBTOBI Q:IBQUIT
    80         N VAEL,TAB,IBTRCSC
    81         D ELIG^VADPT
    82         W !!,"  Eligibility Information"
    83         W !,"       Primary Eligibility: "_$P(VAEL(1),"^",2)
    84         W !,"         Means Test Status: "_$P(VAEL(9),"^",2)
    85         W !," Service Connected Percent: "_$S(+VAEL(3):+$P(VAEL(3),"^",2)_"%",1:"")
    86         I 'VAEL(3) W "Patient Not Service Connected",!! G SCQ
    87         S TAB=5,IBTRCSC=1 D SC^IBTOAT2
    88 SCQ     W:'IBQUIT !?4,$TR($J(" ",IOM-8)," ","-"),!
    89         Q
    90         ;
    91 COMM(DA)        ; -- print comments from GROUP plans.
    92         Q:IBQUIT
    93         W !,"Group Plan Comments: "
    94         Q:'$D(^IBA(355.3,DA,11))
    95         K ^UTILITY($J,"W")
    96         S DIWL=10,DIWR=IOM-12,DIWF="W"
    97         S IBJ=0 F  S IBJ=$O(^IBA(355.3,DA,11,IBJ)) Q:'IBJ  S X=^(IBJ,0) D ^DIWP I IOSL<($Y+3) Q:IBQUIT  D HDR^IBTOBI
    98         Q:IBQUIT
    99         D ^DIWW
    100         K ^UTILITY($J,"W")
    101         Q
     1IBTOBI1 ;ALB/AAS - CLAIMS TRACKING BILLING INFORMATION PRINT ;27-OCT-93
     2 ;;2.0;INTEGRATED BILLING;**276**;21-MAR-94
     3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
     4 ;
     5% ;
     6 F IBTAG="INS","BI","SC","CLIN^IBTOBI4","IR^IBTOBI2","HR^IBTOBI3" D @IBTAG Q:IBQUIT
     7 Q
     8 ;
     9INS ; -- print ins. stuff
     10 N TAB,TAB2,IBALLIN,IBDT,IBINS,IBCNT,I,X,IBI,PHON,PHON2,PHON3,P,IBI
     11 S TAB=5,TAB2=45,IBALLIN=1
     12 S IBDT=$P(IBTRND,"^",6)
     13 I '$G(IBDT) S IBDT=DT
     14 W !,"  Insurance Information "
     15 ;
     16 D ALL^IBCNS1(DFN,"IBINS",1,IBDT)
     17 I $G(IBINS(0))<1 W !,?TAB,"No Insurance Information",!!! G INSQ
     18 S IBI=0,IBCNT=0 F  S IBI=$O(IBINS(IBI)) Q:'IBI!(IBQUIT)  S IBINS=IBINS(IBI,0) D  Q:IBQUIT
     19 .S IBCNT=IBCNT+1
     20 .I ($Y+8)>IOSL D HDR^IBTOBI Q:IBQUIT
     21 .I IBCNT>1 W !
     22 .W !?TAB,"     Ins. Co "_IBCNT_": ",$E($P($G(^DIC(36,+IBINS,0)),"^"),1,23)
     23 .S X=$G(^DIC(36,+IBINS,.13))
     24 .S PHON=$S($P(X,"^",3)'="":$P(X,"^",3),1:$P(X,"^"))
     25 .S PHON2=$S($P(X,"^",2)'="":$P(X,"^",2),1:$P(X,"^"))
     26 .S P=$S($P(IBETYP,"^",3)=1:5,$P(IBETYP,"^",3)=2:6,$P(IBETYP,"^",3)=3:11,1:1)
     27 .S PHON3=$S($P(X,"^",P)'="":$P(X,"^",P),1:$P(X,"^"))
     28 .W ?TAB2,"Pre-Cert Phone: ",PHON
     29 .W !?TAB,"        Subsc.: ",$P(IBINS,"^",17)
     30 .W ?TAB2,"          Type: ",$E($P($G(^IBE(355.1,+$P($G(^IBA(355.3,+$P(IBINS,"^",18),0)),"^",9),0)),"^"),1,18)
     31 .W !?TAB,"     Subsc. ID: ",$P(IBINS,"^",2)
     32 .W ?TAB2,"         Group: ",$$GRP^IBCNS($P(IBINS,"^",18))
     33 .W !?TAB,"     Coord Ben: ",$E($$EXPAND^IBTRE(2.312,.2,$P(IBINS,"^",20)),1,18)
     34 .W ?TAB2," Billing Phone: ",PHON2
     35 .W !,?TAB,"Filing Time Fr: ",$$EXPAND^IBTRE(36,.12,$P($G(^DIC(36,+IBINS,0)),"^",12))
     36 .W ?TAB2,"  Claims Phone: ",PHON3
     37 .S X=$P($G(IBINS(IBI,1)),"^",8) I X'="" W !,"     Policy Comment: " W:($L(X)+23)>IOM ! W " ",X
     38 .D COMM(+$P(IBINS,"^",18))
     39 .Q:IBQUIT
     40 .W !?30,"-----------------------------------"
     41 W:'IBQUIT !?4,$TR($J(" ",IOM-8)," ","-"),!
     42INSQ Q
     43 ;
     44BI ; -- print billing information
     45 Q:$D(IBCTHDR)
     46 I ($Y+8)>IOSL D HDR^IBTOBI Q:IBQUIT
     47BI1 W !,"  Billing Information "
     48 N IBDGCR,IBDGCRU1,IBDGCRU,IBAMNT,IBD,I,IBIFN,IBADD,IBECME
     49 S IBIFN=+$P(IBTRND,"^",11)
     50 S IBDGCR=$G(^DGCR(399,IBIFN,0)),IBDGCRU1=$G(^("U1")),IBDGCRU=$G(^("U"))
     51 S IBECME=$P($P($G(^DGCR(399,IBIFN,"M1")),U,8),";")
     52 S IBAMNT=$$BILLD^IBTRED1(IBTRN)
     53 S IBADD=0
     54 S IBD(1,1)="  Initial Bill: "_$P(IBDGCR,"^")
     55 I IBECME D
     56 . S IBADD=1
     57 . S IBD(1,1)=IBD(1,1)_"e"
     58 . S IBD(2,1)="   ECME Number: "_IBECME
     59 S IBD(2+IBADD,1)="   Bill Status: "_$E($$EXPAND^IBTRE(399,.13,$P(IBDGCR,"^",13)),1,14)
     60 S IBD(3+IBADD,1)=" Total Charges: $ "_$J($P(IBAMNT,"^"),8)
     61 S IBD(4+IBADD,1)="   Amount Paid: $ "_$J($P(IBAMNT,"^",2),8)
     62 ;
     63 I $P(IBTRND,"^",19) S IBD(5,1)="Reason Not Billable: "_$$EXPAND^IBTRE(356,.19,$P(IBTRND,"^",19)),IBD(6,1)="Additional Comment: "_$P(IBTRND1,"^",8)
     64 ;
     65 S IBD(1,2)="Estimated Recv (Pri): $ "_$J($P(IBTRND,"^",21),8)
     66 S IBD(2,2)="Estimated Recv (Sec): $ "_$J($P(IBTRND,"^",22),8)
     67 S IBD(3,2)="Estimated Recv (ter): $ "_$J($P(IBTRND,"^",23),8)
     68 S IBD(4,2)="  Means Test Charges: $ "_$J($P(IBTRND,"^",28),8)
     69 I $L($P($G(^IBT(356,IBTRN,1)),U,8))>0 S IBD(5,1)="Additional Comment: "_$P($G(^IBT(356,IBTRN,1)),U,8)
     70 S I=0 F  S I=$O(IBD(I)) Q:'I  W !,$G(IBD(I,1)),?39,$E($G(IBD(I,2)),1,36)
     71 W:'IBQUIT !,?4,$TR($J(" ",IOM-8)," ","-")
     72 Q
     73 ;
     74SC ; -- print SC information
     75 I ($Y+7)>IOSL D HDR^IBTOBI Q:IBQUIT
     76 N VAEL,TAB,IBTRCSC
     77 D ELIG^VADPT
     78 W !!,"  Eligibility Information"
     79 W !,"       Primary Eligibility: "_$P(VAEL(1),"^",2)
     80 W !,"         Means Test Status: "_$P(VAEL(9),"^",2)
     81 W !," Service Connected Percent: "_$S(+VAEL(3):+$P(VAEL(3),"^",2)_"%",1:"")
     82 I 'VAEL(3) W "Patient Not Service Connected",!! G SCQ
     83 S TAB=5,IBTRCSC=1 D SC^IBTOAT2
     84SCQ W:'IBQUIT !?4,$TR($J(" ",IOM-8)," ","-"),!
     85 Q
     86 ;
     87COMM(DA) ; -- print comments from GROUP plans.
     88 Q:IBQUIT
     89 W !,"Group Plan Comments: "
     90 Q:'$D(^IBA(355.3,DA,11))
     91 K ^UTILITY($J,"W")
     92 S DIWL=10,DIWR=IOM-12,DIWF="W"
     93 S IBJ=0 F  S IBJ=$O(^IBA(355.3,DA,11,IBJ)) Q:'IBJ  S X=^(IBJ,0) D ^DIWP I IOSL<($Y+3) Q:IBQUIT  D HDR^IBTOBI
     94 Q:IBQUIT
     95 D ^DIWW
     96 K ^UTILITY($J,"W")
     97 Q

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBTOBI4.m

    r613 r623  
    1 IBTOBI4 ;ALB/AAS - CLAIMS TRACKING BILLING INFORMATION PRINT ;27-OCT-93
    2         ;;2.0;INTEGRATED BILLING;**91,125,51,210,266,389**;21-MAR-94;Build 6
    3         ;
    4 CLIN    ; -- output clinical information
    5         N IBOE,DGPM
    6         Q:$D(IBCTHDR)
    7         ;
    8         I $P(IBETYP,"^",3)=1 S DGPM=$P(^IBT(356,+IBTRN,0),"^",5) I 'DGPM Q
    9         I $P(IBETYP,"^",3)=2 S IBOE=$P(^IBT(356,+IBTRN,0),"^",4)
    10         F IBTAG="DIAG","PROC","PROV" D @IBTAG Q:IBQUIT
    11         Q
    12         ;
    13 DIAG    ; -- print diagnosis information
    14         I '$G(DGPM),('$G(IBOE)) Q
    15         Q:$P(IBETYP,"^",3)>2
    16         I ($Y+9)>IOSL D HDR^IBTOBI Q:IBQUIT
    17 DIAG1   W !,"  Diagnosis Information "
    18         N IBXY,SDDXY,ICDVDT
    19         I $G(DGPM) D SET^IBTRE3(+IBTRN) W:'$D(IBXY) !?6,"Nothing on File" D:$D(IBXY) LIST^IBTRE3(.IBXY)
    20         I $G(IBOE) D SET^SDCO4(IBOE) W:'$D(SDDXY) !?6,"Nothing on File" I $D(SDDXY) S ICDVDT=$$TRNDATE^IBACSV(+IBTRN) D LIST^SDCO4(.SDDXY)
    21         ;
    22         D:$G(DGPM) DRG
    23         W:'IBQUIT !?4,$TR($J(" ",IOM-8)," ","-"),!
    24         Q
    25         ;
    26 PROC    ; -- print procedure information
    27         Q:$P(IBETYP,"^",3)>2
    28         I ($Y+9)>IOSL D HDR^IBTOBI Q:IBQUIT
    29 PROC1   W !,"  Procedure Information "
    30         ;
    31         N IBXY,IBCNT,IBVAL,IBCBK S IBCNT=0
    32         I $G(DGPM) D SET^IBTRE4(+IBTRN) W:'$D(IBXY) !?6,"Nothing on File" D:$D(IBXY) LIST^IBTRE4(.IBXY)
    33         I '$G(DGPM) D  W:'$D(IBXY) !?6,"Nothing on File" D:$D(IBXY) LIST(.IBXY)
    34         .S IBDT=$P($P(IBTRND,"^",6),".")
    35         .;
    36         .S IBVAL("DFN")=DFN,IBVAL("BDT")=IBDT-.000001,IBVAL("EDT")=IBDT\1_".99"
    37         .; Only want to extract procedures from parent encounters to avoid dups
    38         .S IBCBK="I '$P(Y0,U,6) D GETPROC^IBTOBI4(Y,Y0,.IBCNT,.IBXY)"
    39         .D SCAN^IBSDU("PATIENT/DATE",.IBVAL,"",IBCBK) K ^TMP("DIERR",$J)
    40         ;
    41         W:'IBQUIT !?4,$TR($J(" ",IOM-8)," ","-"),!
    42         Q
    43         ;
    44 GETPROC(IBOE,IBOE0,IBCNT,IBXY)  ; output:  IBXY(cnt) = CPT IFN ^ DT/TM ^ Mod,Mod ^ Encounter Provider (#1204)
    45         N I2,IBCPT,IBCPTS,IBZERR,IBM,IBMODS
    46         D GETCPT^SDOE(IBOE,"IBCPTS","IBZERR")
    47         Q:'$O(IBCPTS(0))  ;No procedures for this encounter
    48         S I2=0
    49         F  S I2=$O(IBCPTS(I2)) Q:'I2  F Z=1:1:$P(IBCPTS(I2),U,16) D
    50         . S IBMODS="",IBM=0
    51         . F  S IBM=$O(IBCPTS(I2,1,IBM)) Q:'IBM  S IBMODS=$S(IBMODS="":"",1:",")_$G(IBCPTS(I2,1,IBM,0))
    52         . S IBCNT=IBCNT+1,IBXY(IBCNT)=$P(IBCPTS(I2),U)_U_+IBOE0_U_IBMODS_U_$P($G(IBCPTS(I2,12)),U,4)
    53         Q
    54         ;
    55 PROV    ; -- print provider information
    56         I '$G(DGPM),('$G(IBOE)) Q
    57         Q:$P(IBETYP,"^",3)>2
    58         I ($Y+9)>IOSL D HDR^IBTOBI Q:IBQUIT
    59 PROV1   W !,"  Provider Information "
    60         N IBXY,SDPRY
    61         I $G(DGPM) D SET^IBTRE5(+IBTRN) W:'$D(IBXY) !?6,"Nothing on File" D:$D(IBXY) LIST^IBTRE5(.IBXY)
    62         I $G(IBOE) D SET^SDCO3(IBOE) W:'$D(SDPRY) !?6,"Nothing on File" D:$D(SDPRY) LIST^SDCO3(.SDPRY)
    63         W:'IBQUIT !?4,$TR($J(" ",IOM-8)," ","-"),!
    64         Q
    65         ;
    66 LIST(IBXY)      ; -- list procedures array
    67         ; Input  -- IBXY     Diagnosis Array Subscripted by a Number
    68         ; Output -- List Diagnosis Array
    69         N I,IBXD,IBMODS,J,IBM,IBDATE
    70         W !
    71         S I=0 F  S I=$O(IBXY(I)) Q:'I  D
    72         . S IBDATE=$P(IBXY(I),U,2)
    73         . S IBXD=$$PRCD^IBCEF1(+IBXY(I)_";ICPT(",1,IBDATE)
    74         . W !?2,I,"  ",$P(IBXD,U,2),?15,$E($P(IBXD,U,3),1,40),?60,$$DAT1^IBOUTL(IBDATE,"2P")
    75         . S IBMODS=$$MODLST^IBEFUNC2($P(IBXY(I),U,3),1,.IBMODS,IBDATE)
    76         . I IBMODS'="" F J=1:1:$L(IBMODS,",") W !,?15,$P(IBMODS,",",J),?20,$P($G(IBMODS(1)),",",J)
    77         Q
    78         ;
    79 DRG     ; -- print drgs.
    80         I '$G(DGPM) Q
    81         Q:$P(IBETYP,"^",3)>1
    82         I ($Y+9)>IOSL D HDR^IBTOBI Q:IBQUIT
    83 DRG1    W !!,"  Associated Interim DRG Information "
    84         N IBX,IBDTE,IBDRG
    85         I $G(DGPM) D
    86         .I '$O(^IBT(356.93,"AMVD",DGPM,0)) W !?6,"Nothing on File" Q
    87         .S IBDTE=0 F  S IBDTE=$O(^IBT(356.93,"AMVD",DGPM,IBDTE)) Q:'IBDTE  S IBDRG=0 F  S IBDRG=$O(^IBT(356.93,"AMVD",DGPM,IBDTE,IBDRG)) Q:'IBDRG  D
    88         ..S IBX=$G(^IBT(356.93,IBDRG,0)) Q:IBX=""
    89         ..W !?5,$$DAT1^IBOUTL($P(IBX,"^",3)),?16,+IBX," - ",$$DRGTD^IBACSV(+IBX,$P(IBX,"^",3))
    90         ..W !?21," Estimate ALOS: "_$J($P(IBX,"^",4),4,1)
    91         ..W ?45," Days Remaining: "_$J($P(IBX,"^",5),2)
    92         Q
    93         ;
    94 4       ; -- Visit region for prosthetics
    95         N IBDA,IBRMPR S IBDA=$P(IBTRND,"^",9) D PRODATA^IBTUTL1(IBDA)
    96         S IBD(2,1)="          Item: "_$P($$PIN^IBCSC5B(+IBDA),U,2)
    97         S IBD(3,1)="   Description: "_$G(IBRMPR(660,+IBDA,24,"E"))
    98         S IBD(4,1)="      Quantity: "_$J($G(IBRMPR(660,+IBDA,5,"E")),4)
    99         S IBD(5,1)="    Total Cost: $"_$G(IBRMPR(660,+IBDA,14,"E"))
    100         S IBD(6,1)="   Transaction: "_$G(IBRMPR(660,+IBDA,2,"E"))
    101         S IBD(7,1)="        Vendor: "_$G(IBRMPR(660,+IBDA,7,"E"))
    102         S IBD(8,1)="        Source: "_$G(IBRMPR(660,+IBDA,12,"E"))
    103         S IBD(9,1)=" Delivery Date: "_$G(IBRMPR(660,+IBDA,10,"E"))
    104         S IBD(10,1)="       Remarks: "_$G(IBRMPR(660,+IBDA,16,"E"))
    105         S IBD(11,1)=" Return Status: "_$G(IBRMPR(660,+IBDA,17,"E"))
    106         Q
     1IBTOBI4 ;ALB/AAS - CLAIMS TRACKING BILLING INFORMATION PRINT ;27-OCT-93
     2 ;;2.0;INTEGRATED BILLING;**91,125,51,210,266**;21-MAR-94
     3 ;
     4CLIN ; -- output clinical information
     5 N IBOE,DGPM
     6 Q:$D(IBCTHDR)
     7 ;
     8 I $P(IBETYP,"^",3)=1 S DGPM=$P(^IBT(356,+IBTRN,0),"^",5) I 'DGPM Q
     9 I $P(IBETYP,"^",3)=2 S IBOE=$P(^IBT(356,+IBTRN,0),"^",4)
     10 F IBTAG="DIAG","PROC","PROV" D @IBTAG Q:IBQUIT
     11 Q
     12 ;
     13DIAG ; -- print diagnosis information
     14 I '$G(DGPM),('$G(IBOE)) Q
     15 Q:$P(IBETYP,"^",3)>2
     16 I ($Y+9)>IOSL D HDR^IBTOBI Q:IBQUIT
     17DIAG1 W !,"  Diagnosis Information "
     18 N IBXY,SDDXY,ICDVDT
     19 I $G(DGPM) D SET^IBTRE3(+IBTRN) W:'$D(IBXY) !?6,"Nothing on File" D:$D(IBXY) LIST^IBTRE3(.IBXY)
     20 I $G(IBOE) D SET^SDCO4(IBOE) W:'$D(SDDXY) !?6,"Nothing on File" I $D(SDDXY) S ICDVDT=$$TRNDATE^IBACSV(+IBTRN) D LIST^SDCO4(.SDDXY)
     21 ;
     22 D:$G(DGPM) DRG
     23 W:'IBQUIT !?4,$TR($J(" ",IOM-8)," ","-"),!
     24 Q
     25 ;
     26PROC ; -- print procedure information
     27 Q:$P(IBETYP,"^",3)>2
     28 I ($Y+9)>IOSL D HDR^IBTOBI Q:IBQUIT
     29PROC1 W !,"  Procedure Information "
     30 ;
     31 N IBXY,IBCNT,IBVAL,IBCBK S IBCNT=0
     32 I $G(DGPM) D SET^IBTRE4(+IBTRN) W:'$D(IBXY) !?6,"Nothing on File" D:$D(IBXY) LIST^IBTRE4(.IBXY)
     33 I '$G(DGPM) D  W:'$D(IBXY) !?6,"Nothing on File" D:$D(IBXY) LIST(.IBXY)
     34 .S IBDT=$P($P(IBTRND,"^",6),".")
     35 .;
     36 .S IBVAL("DFN")=DFN,IBVAL("BDT")=IBDT-.000001,IBVAL("EDT")=IBDT\1_".99"
     37 .; Only want to extract procedures from parent encounters to avoid dups
     38 .S IBCBK="I '$P(Y0,U,6) D GETPROC^IBTOBI4(Y,Y0,.IBCNT,.IBXY)"
     39 .D SCAN^IBSDU("PATIENT/DATE",.IBVAL,"",IBCBK) K ^TMP("DIERR",$J)
     40 ;
     41 W:'IBQUIT !?4,$TR($J(" ",IOM-8)," ","-"),!
     42 Q
     43 ;
     44GETPROC(IBOE,IBOE0,IBCNT,IBXY) ; output:  IBXY(cnt) = CPT IFN ^ DT/TM ^ Mod,Mod ^ Encounter Provider (#1204)
     45 N I2,IBCPT,IBCPTS,IBZERR,IBM,IBMODS
     46 D GETCPT^SDOE(IBOE,"IBCPTS","IBZERR")
     47 Q:'$O(IBCPTS(0))  ;No procedures for this encounter
     48 S I2=0
     49 F  S I2=$O(IBCPTS(I2)) Q:'I2  F Z=1:1:$P(IBCPTS(I2),U,16) D
     50 . S IBMODS="",IBM=0
     51 . F  S IBM=$O(IBCPTS(I2,1,IBM)) Q:'IBM  S IBMODS=$S(IBMODS="":"",1:",")_$G(IBCPTS(I2,1,IBM,0))
     52 . S IBCNT=IBCNT+1,IBXY(IBCNT)=$P(IBCPTS(I2),U)_U_+IBOE0_U_IBMODS_U_$P($G(IBCPTS(I2,12)),U,4)
     53 Q
     54 ;
     55PROV ; -- print provider information
     56 I '$G(DGPM),('$G(IBOE)) Q
     57 Q:$P(IBETYP,"^",3)>2
     58 I ($Y+9)>IOSL D HDR^IBTOBI Q:IBQUIT
     59PROV1 W !,"  Provider Information "
     60 N IBXY,SDPRY
     61 I $G(DGPM) D SET^IBTRE5(+IBTRN) W:'$D(IBXY) !?6,"Nothing on File" D:$D(IBXY) LIST^IBTRE5(.IBXY)
     62 I $G(IBOE) D SET^SDCO3(IBOE) W:'$D(SDPRY) !?6,"Nothing on File" D:$D(SDPRY) LIST^SDCO3(.SDPRY)
     63 W:'IBQUIT !?4,$TR($J(" ",IOM-8)," ","-"),!
     64 Q
     65 ;
     66LIST(IBXY) ; -- list procedures array
     67 ; Input  -- IBXY     Diagnosis Array Subscripted by a Number
     68 ; Output -- List Diagnosis Array
     69 N I,IBXD,IBMODS,J,IBM,IBDATE
     70 W !
     71 S I=0 F  S I=$O(IBXY(I)) Q:'I  D
     72 . S IBDATE=$P(IBXY(I),U,2)
     73 . S IBXD=$$PRCD^IBCEF1(+IBXY(I)_";ICPT(",1,IBDATE)
     74 . W !?2,I,"  ",$P(IBXD,U,2),?15,$E($P(IBXD,U,3),1,40),?60,$$DAT1^IBOUTL(IBDATE,"2P")
     75 . S IBMODS=$$MODLST^IBEFUNC2($P(IBXY(I),U,3),1,.IBMODS,IBDATE)
     76 . I IBMODS'="" F J=1:1:$L(IBMODS,",") W !,?15,$P(IBMODS,",",J),?20,$P($G(IBMODS(1)),",",J)
     77 Q
     78 ;
     79DRG ; -- print drgs.
     80 I '$G(DGPM) Q
     81 Q:$P(IBETYP,"^",3)>1
     82 I ($Y+9)>IOSL D HDR^IBTOBI Q:IBQUIT
     83DRG1 W !!,"  Associated Interim DRG Information "
     84 N IBX,IBDTE,IBDRG
     85 I $G(DGPM) D
     86 .I '$O(^IBT(356.93,"AMVD",DGPM,0)) W !?6,"Nothing on File" Q
     87 .S IBDTE=0 F  S IBDTE=$O(^IBT(356.93,"AMVD",DGPM,IBDTE)) Q:'IBDTE  S IBDRG=0 F  S IBDRG=$O(^IBT(356.93,"AMVD",DGPM,IBDTE,IBDRG)) Q:'IBDRG  D
     88 ..S IBX=$G(^IBT(356.93,IBDRG,0)) Q:IBX=""
     89 ..W !?5,$$DAT1^IBOUTL($P(IBX,"^",3)),?16,+IBX," - ",$$DRGTD^IBACSV(+IBX,$P(IBX,"^",3))
     90 ..W !?21," Estimate ALOS: "_$J($P(IBX,"^",4),4,1)
     91 ..W ?45," Days Remaining: "_$J($P(IBX,"^",5),2)
     92 Q
     93 ;
     944 ; -- Visit region for prosthetics
     95 N IBDA,IBRMPR S IBDA=$P(IBTRND,"^",9) D PRODATA^IBTUTL1(IBDA)
     96 S IBD(2,1)="          Item: "_$G(IBRMPR(660,+IBDA,4,"E"))
     97 S IBD(3,1)="   Description: "_$G(IBRMPR(660,+IBDA,24,"E"))
     98 S IBD(4,1)="      Quantity: "_$J($G(IBRMPR(660,+IBDA,5,"E")),4)
     99 S IBD(5,1)="    Total Cost: $"_$G(IBRMPR(660,+IBDA,14,"E"))
     100 S IBD(6,1)="   Transaction: "_$G(IBRMPR(660,+IBDA,2,"E"))
     101 S IBD(7,1)="        Vendor: "_$G(IBRMPR(660,+IBDA,7,"E"))
     102 S IBD(8,1)="        Source: "_$G(IBRMPR(660,+IBDA,12,"E"))
     103 S IBD(9,1)=" Delivery Date: "_$G(IBRMPR(660,+IBDA,10,"E"))
     104 S IBD(10,1)="       Remarks: "_$G(IBRMPR(660,+IBDA,16,"E"))
     105 S IBD(11,1)=" Return Status: "_$G(IBRMPR(660,+IBDA,17,"E"))
     106 Q

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBTRED01.m

    r613 r623  
    1 IBTRED01        ;ALB/AAS - EXPAND/EDIT CLAIMS TRACKING ENTRY - CONT; 01-JUL-1993
    2         ;;2.0;INTEGRATED BILLING;**389**;21-MAR-94;Build 6
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5 %       I '$G(IBTRN)!($G(IORVON)="") G ^IBTRED
    6         D UR,REVIEW,SC
    7         Q
    8 REVIEW  ; -- List Reviews done
    9         N OFFSET,START,IBTRV,IDT,IBTRVD,IBTRTP
    10         S START=24,OFFSET=2,IBLCNT=0
    11         D SET^IBCNSP(START,OFFSET," Hospital Reviews Entered ",IORVON,IORVOFF)
    12         S IDT="" F  S IDT=$O(^IBT(356.1,"ATIDT",IBTRN,IDT)) Q:'IDT  S IBTRV="" F  S IBTRV=$O(^IBT(356.1,"ATIDT",IBTRN,IDT,IBTRV)) Q:'IBTRV  D
    13         .S IBLCNT=$G(IBLCNT)+1
    14         .S IBTRVD=$G(^IBT(356.1,IBTRV,0))
    15         .S IBTRTP=$P($G(^IBE(356.11,+$P(IBTRVD,"^",22),0)),"^")
    16         .;D SET^IBCNSP(START+IBLCNT,OFFSET,$J(IBLCNT,2)_".  "_$E(IBTRTP_"                        ",1,28)_"  on  "_$E($$DAT1^IBOUTL($P(IBTRVD,"^"),"2P")_"  ",1,8)_"  Status: "_$$EXPAND^IBTRE(356.1,.21,$P(IBTRVD,"^",21)))
    17         .S IBTEXT=$E(IBTRTP_"  Status: "_$$EXPAND^IBTRE(356.1,.21,$P(IBTRVD,"^",21))_"                                ",1,50)
    18         .D SET^IBCNSP(START+IBLCNT,OFFSET,$J(IBLCNT,2)_".  "_IBTEXT_"  on  "_$$DAT1^IBOUTL($P(IBTRVD,"^"),"2P"))
    19         .Q
    20         D COMM
    21         Q
    22 COMM    ; -- List Communication Entries
    23         N OFFSET,START,IDT,IBTRCD,IBCNT
    24         S START=26+$G(IBLCNT),OFFSET=2
    25         D SET^IBCNSP(START,OFFSET," Insurance Reviews Entered ",IORVON,IORVOFF)
    26         S IDT="" F  S IDT=$O(^IBT(356.2,"ATIDT",IBTRN,IDT)) Q:'IDT  S IBTRC="" F  S IBTRC=$O(^IBT(356.2,"ATIDT",IBTRN,IDT,IBTRC)) Q:'IBTRC  D
    27         .S IBLCNT=$G(IBLCNT)+1,IBCNT=$G(IBCNT)+1
    28         .S IBTRCD=$G(^IBT(356.2,IBTRC,0))
    29         .S IBTEXT=$E($$EXPAND^IBTRE(356.2,.04,$P(IBTRCD,"^",4))_" Contact  "_$$EXPAND^IBTRE(356.2,.11,$P(IBTRCD,"^",11))_"                                         ",1,50)
    30         .D SET^IBCNSP(START+IBCNT,OFFSET,$J(IBCNT,2)_".  "_IBTEXT_"  on  "_$$DAT1^IBOUTL(+IBTRCD,"2P"))
    31         .Q
    32         Q
    33         ;
    34 SC      ; -- Show eligibility/sc conditions
    35         N OFFSET,START,IDT,IBTRCD,IBCNT,I1,I2,I3
    36         S START=28+$G(IBLCNT),OFFSET=2
    37 SC1     D SET^IBCNSP(START,OFFSET," Service Connected Conditions: ",IORVON,IORVOFF)
    38         D ELIG^VADPT
    39         S IBLCNT=$G(IBLCNT)+1,IBCNT=$G(IBCNT)+1,I3=0
    40         ;
    41         D SET^IBCNSP(START+IBCNT,OFFSET,"Service Connected: "_$S('$G(VAEL(3)):"NO",1:$P(VAEL(3),"^",2)_"%"))
    42         ;
    43         F I=0:0 S I=$O(^DPT(DFN,.372,I)) Q:'I  D
    44         .S I1=^DPT(DFN,.372,I,0)
    45         .Q:'$P(I1,"^",3)
    46         .S I2=$G(^DIC(31,+I1,0))
    47         .S:$P(I2,"^",4)'="" I2=$P(I2,"^",4)
    48         .S I2=$P(I2,"^")
    49         .S IBLCNT=$G(IBLCNT)+1,IBCNT=$G(IBCNT)+1
    50         .D SET^IBCNSP(START+IBCNT,OFFSET,$J(IBCNT-1,2)_".  "_$E(I2_"                                               ",1,45)_$J($P(I1,"^",2),3)_"%")
    51         .S I3=I3+1
    52         .Q
    53         I 'I3 S IBLCNT=$G(IBLCNT)+1,IBCNT=$G(IBCNT)+1 D SET^IBCNSP(START+IBCNT,OFFSET,$S('$O(^DPT(DFN,.372,0)):"NONE STATED",1:"NO SC DISABILITIES LISTED")) S I3=1
    54 SCQ     Q
    55         ;
    56 UR      ; -- ur information region
    57         N OFFSET,START
    58         S START=7,OFFSET=51
    59         D SET^IBCNSP(START,OFFSET," Review Information ",IORVON,IORVOFF)
    60         D SET^IBCNSP(START+1,OFFSET,"  Insurance Claim: "_$$EXPAND^IBTRE(356,.24,$P(IBTRND,"^",24)))
    61         D SET^IBCNSP(START+2,OFFSET,"   Follow-up Type: "_$$EXPAND^IBTRE(356,1.07,$P(IBTRND1,"^",7)))
    62         D SET^IBCNSP(START+3,OFFSET,"    Random Sample: "_$$EXPAND^IBTRE(356,.25,$P(IBTRND,"^",25)))
    63         D SET^IBCNSP(START+4,OFFSET,"Special Condition: "_$$EXPAND^IBTRE(356,.26,$P(IBTRND,"^",26)))
    64         D SET^IBCNSP(START+5,OFFSET,"   Local Addition: "_$$EXPAND^IBTRE(356,.27,$P(IBTRND,"^",27)))
    65         D SET^IBCNSP(START+6,OFFSET,"    Ins. Reviewer: "_$$EXPAND^IBTRE(356,1.06,$P(IBTRND1,"^",6)))
    66         D SET^IBCNSP(START+7,OFFSET,"Hospital Reviewer: "_$$EXPAND^IBTRE(356,1.05,$P(IBTRND1,"^",5)))
    67         Q
    68         ;
    69 4       ; -- Visit region for prosthetics
    70         N IBDA,IBRMPR S IBDA=$P(IBTRND,"^",9) D PRODATA^IBTUTL1(IBDA)
    71         D SET^IBCNSP(START+2,OFFSET,"          Item: "_$P($$PIN^IBCSC5B(+IBDA),U,2))
    72         D SET^IBCNSP(START+3,OFFSET,"   Description: "_$G(IBRMPR(660,+IBDA,24,"E")))
    73         D SET^IBCNSP(START+4,OFFSET,"      Quantity: "_$J($G(IBRMPR(660,+IBDA,5,"E")),$L($G(IBRMPR(660,+IBDA,14,"E")))))
    74         D SET^IBCNSP(START+5,OFFSET,"    Total Cost: $"_$G(IBRMPR(660,+IBDA,14,"E")))
    75         D SET^IBCNSP(START+6,OFFSET,"   Transaction: "_$G(IBRMPR(660,+IBDA,2,"E")))
    76         D SET^IBCNSP(START+7,OFFSET,"        Vendor: "_$G(IBRMPR(660,+IBDA,7,"E")))
    77         D SET^IBCNSP(START+8,OFFSET,"        Source: "_$G(IBRMPR(660,+IBDA,12,"E")))
    78         D SET^IBCNSP(START+9,OFFSET," Delivery Date: "_$G(IBRMPR(660,+IBDA,10,"E")))
    79         D SET^IBCNSP(START+10,OFFSET,"       Remarks: "_$G(IBRMPR(660,+IBDA,16,"E")))
    80         D SET^IBCNSP(START+11,OFFSET," Return Status: "_$G(IBRMPR(660,+IBDA,17,"E")))
    81         Q
     1IBTRED01 ;ALB/AAS - EXPAND/EDIT CLAIMS TRACKING ENTRY - CONT; 01-JUL-1993
     2 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
     3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
     4 ;
     5% I '$G(IBTRN)!($G(IORVON)="") G ^IBTRED
     6 D UR,REVIEW,SC
     7 Q
     8REVIEW ; -- List Reviews done
     9 N OFFSET,START,IBTRV,IDT,IBTRVD,IBTRTP
     10 S START=24,OFFSET=2,IBLCNT=0
     11 D SET^IBCNSP(START,OFFSET," Hospital Reviews Entered ",IORVON,IORVOFF)
     12 S IDT="" F  S IDT=$O(^IBT(356.1,"ATIDT",IBTRN,IDT)) Q:'IDT  S IBTRV="" F  S IBTRV=$O(^IBT(356.1,"ATIDT",IBTRN,IDT,IBTRV)) Q:'IBTRV  D
     13 .S IBLCNT=$G(IBLCNT)+1
     14 .S IBTRVD=$G(^IBT(356.1,IBTRV,0))
     15 .S IBTRTP=$P($G(^IBE(356.11,+$P(IBTRVD,"^",22),0)),"^")
     16 .;D SET^IBCNSP(START+IBLCNT,OFFSET,$J(IBLCNT,2)_".  "_$E(IBTRTP_"                        ",1,28)_"  on  "_$E($$DAT1^IBOUTL($P(IBTRVD,"^"),"2P")_"  ",1,8)_"  Status: "_$$EXPAND^IBTRE(356.1,.21,$P(IBTRVD,"^",21)))
     17 .S IBTEXT=$E(IBTRTP_"  Status: "_$$EXPAND^IBTRE(356.1,.21,$P(IBTRVD,"^",21))_"                                ",1,50)
     18 .D SET^IBCNSP(START+IBLCNT,OFFSET,$J(IBLCNT,2)_".  "_IBTEXT_"  on  "_$$DAT1^IBOUTL($P(IBTRVD,"^"),"2P"))
     19 .Q
     20 D COMM
     21 Q
     22COMM ; -- List Communication Entries
     23 N OFFSET,START,IDT,IBTRCD,IBCNT
     24 S START=26+$G(IBLCNT),OFFSET=2
     25 D SET^IBCNSP(START,OFFSET," Insurance Reviews Entered ",IORVON,IORVOFF)
     26 S IDT="" F  S IDT=$O(^IBT(356.2,"ATIDT",IBTRN,IDT)) Q:'IDT  S IBTRC="" F  S IBTRC=$O(^IBT(356.2,"ATIDT",IBTRN,IDT,IBTRC)) Q:'IBTRC  D
     27 .S IBLCNT=$G(IBLCNT)+1,IBCNT=$G(IBCNT)+1
     28 .S IBTRCD=$G(^IBT(356.2,IBTRC,0))
     29 .S IBTEXT=$E($$EXPAND^IBTRE(356.2,.04,$P(IBTRCD,"^",4))_" Contact  "_$$EXPAND^IBTRE(356.2,.11,$P(IBTRCD,"^",11))_"                                         ",1,50)
     30 .D SET^IBCNSP(START+IBCNT,OFFSET,$J(IBCNT,2)_".  "_IBTEXT_"  on  "_$$DAT1^IBOUTL(+IBTRCD,"2P"))
     31 .Q
     32 Q
     33 ;
     34SC ; -- Show eligibility/sc conditions
     35 N OFFSET,START,IDT,IBTRCD,IBCNT,I1,I2,I3
     36 S START=28+$G(IBLCNT),OFFSET=2
     37SC1 D SET^IBCNSP(START,OFFSET," Service Connected Conditions: ",IORVON,IORVOFF)
     38 D ELIG^VADPT
     39 S IBLCNT=$G(IBLCNT)+1,IBCNT=$G(IBCNT)+1,I3=0
     40 ;
     41 D SET^IBCNSP(START+IBCNT,OFFSET,"Service Connected: "_$S('$G(VAEL(3)):"NO",1:$P(VAEL(3),"^",2)_"%"))
     42 ;
     43 F I=0:0 S I=$O(^DPT(DFN,.372,I)) Q:'I  D
     44 .S I1=^DPT(DFN,.372,I,0)
     45 .Q:'$P(I1,"^",3)
     46 .S I2=$G(^DIC(31,+I1,0))
     47 .S:$P(I2,"^",4)'="" I2=$P(I2,"^",4)
     48 .S I2=$P(I2,"^")
     49 .S IBLCNT=$G(IBLCNT)+1,IBCNT=$G(IBCNT)+1
     50 .D SET^IBCNSP(START+IBCNT,OFFSET,$J(IBCNT-1,2)_".  "_$E(I2_"                                               ",1,45)_$J($P(I1,"^",2),3)_"%")
     51 .S I3=I3+1
     52 .Q
     53 I 'I3 S IBLCNT=$G(IBLCNT)+1,IBCNT=$G(IBCNT)+1 D SET^IBCNSP(START+IBCNT,OFFSET,$S('$O(^DPT(DFN,.372,0)):"NONE STATED",1:"NO SC DISABILITIES LISTED")) S I3=1
     54SCQ Q
     55 ;
     56UR ; -- ur information region
     57 N OFFSET,START
     58 S START=7,OFFSET=51
     59 D SET^IBCNSP(START,OFFSET," Review Information ",IORVON,IORVOFF)
     60 D SET^IBCNSP(START+1,OFFSET,"  Insurance Claim: "_$$EXPAND^IBTRE(356,.24,$P(IBTRND,"^",24)))
     61 D SET^IBCNSP(START+2,OFFSET,"   Follow-up Type: "_$$EXPAND^IBTRE(356,1.07,$P(IBTRND1,"^",7)))
     62 D SET^IBCNSP(START+3,OFFSET,"    Random Sample: "_$$EXPAND^IBTRE(356,.25,$P(IBTRND,"^",25)))
     63 D SET^IBCNSP(START+4,OFFSET,"Special Condition: "_$$EXPAND^IBTRE(356,.26,$P(IBTRND,"^",26)))
     64 D SET^IBCNSP(START+5,OFFSET,"   Local Addition: "_$$EXPAND^IBTRE(356,.27,$P(IBTRND,"^",27)))
     65 D SET^IBCNSP(START+6,OFFSET,"    Ins. Reviewer: "_$$EXPAND^IBTRE(356,1.06,$P(IBTRND1,"^",6)))
     66 D SET^IBCNSP(START+7,OFFSET,"Hospital Reviewer: "_$$EXPAND^IBTRE(356,1.05,$P(IBTRND1,"^",5)))
     67 Q
     68 ;
     694 ; -- Visit region for prosthetics
     70 N IBDA,IBRMPR S IBDA=$P(IBTRND,"^",9) D PRODATA^IBTUTL1(IBDA)
     71 D SET^IBCNSP(START+2,OFFSET,"          Item: "_$G(IBRMPR(660,+IBDA,4,"E")))
     72 D SET^IBCNSP(START+3,OFFSET,"   Description: "_$G(IBRMPR(660,+IBDA,24,"E")))
     73 D SET^IBCNSP(START+4,OFFSET,"      Quantity: "_$J($G(IBRMPR(660,+IBDA,5,"E")),$L($G(IBRMPR(660,+IBDA,14,"E")))))
     74 D SET^IBCNSP(START+5,OFFSET,"    Total Cost: $"_$G(IBRMPR(660,+IBDA,14,"E")))
     75 D SET^IBCNSP(START+6,OFFSET,"   Transaction: "_$G(IBRMPR(660,+IBDA,2,"E")))
     76 D SET^IBCNSP(START+7,OFFSET,"        Vendor: "_$G(IBRMPR(660,+IBDA,7,"E")))
     77 D SET^IBCNSP(START+8,OFFSET,"        Source: "_$G(IBRMPR(660,+IBDA,12,"E")))
     78 D SET^IBCNSP(START+9,OFFSET," Delivery Date: "_$G(IBRMPR(660,+IBDA,10,"E")))
     79 D SET^IBCNSP(START+10,OFFSET,"       Remarks: "_$G(IBRMPR(660,+IBDA,16,"E")))
     80 D SET^IBCNSP(START+11,OFFSET," Return Status: "_$G(IBRMPR(660,+IBDA,17,"E")))
     81 Q

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBTRKR5.m

    r613 r623  
    1 IBTRKR5 ;ALB/AAS - CLAIMS TRACKING - ADD/TRACK PROSTHETICS ;13-JAN-94
    2         ;;2.0;INTEGRATED BILLING;**13,260,312,339,389**;21-MAR-94;Build 6
    3         ;;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5 %       ; -- entry point for nightly background job
    6         N IBTSBDT,IBTSEDT
    7         S IBTSBDT=$$FMADD^XLFDT(DT,-30)-.1
    8         S IBTSEDT=$$FMADD^XLFDT(DT,-3)+.9
    9         D EN1
    10         Q
    11         ;
    12 EN      ; -- entry point to ask date range
    13         N IBSWINFO S IBSWINFO=$$SWSTAT^IBBAPI()                   ;IB*2.0*312
    14         N IBBDT,IBEDT,IBTSBDT,IBTSEDT,IBTALK
    15         S IBTALK=1
    16         I '$P($G(^IBE(350.9,1,6)),"^",4) W !!,"I'm sorry, Tracking of Prosthetics is currently turned off." G ENQ
    17         W !!!,"Select the Date Range of Prosthetics to Add to Claims Tracking.",!
    18         D DATE^IBOUTL
    19         I IBBDT<1!(IBEDT<1) G ENQ
    20         S IBTSBDT=IBBDT,IBTSEDT=IBEDT
    21         ;
    22         ; -- check selected dates                                 ;IB*2.0*312
    23         ; Do NOT PROCESS on VistA if Start or End>=Switch Eff Dt  ;CCR-930
    24         I +IBSWINFO,((IBTSBDT+1)>$P(IBSWINFO,"^",2))!((IBTSEDT+1)>$P(IBSWINFO,"^",2)) D  G EN
    25         .W !!,"The Begin OR End Date CANNOT be on or after the PFSS Effective date"
    26         .W ": ",$$FMTE^XLFDT($P(IBSWINFO,"^",2))
    27         ;
    28         S IBTRKR=$G(^IBE(350.9,1,6))
    29         ; start date can't be before parameters
    30         I +IBTRKR,IBTSBDT<+IBTRKR S IBTSBDT=IBTRKR W !!,"Begin date is before Claims Tracking Start Date, changed to ",$$DAT1^IBOUTL(IBTSBDT)
    31         ; -- end date into future
    32         I IBTSEDT>$$FMADD^XLFDT(DT,-3) W !!,"I'll automatically change the end date to 3 days prior to the date queued to run."
    33         ;
    34         W !!!,"I'm going to automatically queue this off and send you a"
    35         W !,"mail message when complete.",!
    36         S ZTIO="",ZTRTN="EN1^IBTRKR5",ZTSAVE("IB*")="",ZTDESC="IB - Add Prosthetics to Claims Tracking"
    37         D ^%ZTLOAD I $G(ZTSK) K ZTSK W !,"Request Queued"
    38 ENQ     K ZTSK,ZTIO,ZTSAVE,ZTDESC,ZTRTN
    39         D HOME^%ZIS
    40         Q
    41         ;
    42 EN1     ; -- add prostethics to claims tracking file
    43         N I,J,X,Y,IBTRKR,IBDT,DFN,IBDATA,IBCNT,IBCNT1,IBCNT2,IBDTS
    44         N IBSWINFO S IBSWINFO=$$SWSTAT^IBBAPI()                   ;IB*2.0*312
    45         ;
    46         ; -- check parameters
    47         S IBTRKR=$G(^IBE(350.9,1,6))
    48         G:'$P(IBTRKR,"^",5) EN1Q ; quit if prothetics tracking off
    49         I +IBTRKR,IBTSBDT<+IBTRKR S IBTSBDT=IBTRKR ; start date can't be before parameters
    50         ;
    51         ; -- users can queue into future, make sure dates not after date run
    52         I IBTSEDT>$$FMADD^XLFDT(DT,-3) S IBMESS="(Selected end date of "_$$DAT1^IBOUTL(IBTSEDT)_" automatically changed to "_$$DAT1^IBOUTL($$FMADD^XLFDT(DT,-3))_".)",IBTSEDT=$$FMADD^XLFDT(DT,-3)
    53         ;
    54         ;S IBPRTYP=$O(^IBE(356.6,"AC",3,0)) ; this is the event type pointer for prosthetics
    55         ;
    56         ; -- cnt= total count, cnt1=count added nsc, cnt2=count of pending
    57         S (IBCNT,IBCNT1,IBCNT2)=0
    58         S (IBDTS,IBDT)=IBTSBDT-.0001
    59         ;
    60         ; loop twice, once for shipmnet date (new search), and once for
    61         ; delivery date (old search) for backward compatibility.
    62         F  S IBDT=$O(^RMPR(660,"AF",IBDT)) Q:'IBDT!(IBDT>IBTSEDT)  D
    63            .; Do NOT PROCESS on VistA if IBDT>=Switch Eff Date    ;CCR-930
    64            .I +IBSWINFO,(IBDT+1)>$P(IBSWINFO,"^",2) Q             ;IB*2.0*312
    65            .S IBDA=0 F  S IBDA=$O(^RMPR(660,"AF",IBDT,IBDA)) Q:'IBDA  D PRCHK
    66         ;
    67         ; reset date and do old check
    68         S IBDT=IBDTS
    69         F  S IBDT=$O(^RMPR(660,"CT",IBDT)) Q:'IBDT!(IBDT>IBTSEDT)  D
    70            .; Do NOT PROCESS on VistA if IBDT>=Switch Eff Date    ;CCR-930
    71            .I +IBSWINFO,(IBDT+1)>$P(IBSWINFO,"^",2) Q             ;IB*2.0*312
    72            .S IBDA="" F  S IBDA=$O(^RMPR(660,"CT",IBDT,IBDA)) Q:'IBDA  D PRCHK
    73         ;
    74         I $G(IBTALK) D BULL ;^IBTRKR51
    75 EN1Q    I $D(ZTQUEUED) S ZTREQ="@"
    76         Q
    77         ;
    78 PRCHK   ; -- check and add item
    79         N IBE,IBP,IBDX,IBRMARK,IBARR,IBT
    80         S IBCNT=IBCNT+1,IBRMARK=""
    81         I '$D(ZTQUEUED),($G(IBTALK)) W "."
    82         ;
    83         S IBDATA=$G(^RMPR(660,+IBDA,0)) Q:IBDATA=""
    84         S DFN=$P(IBDATA,"^",2) Q:'DFN
    85         D CL^SDCO21(DFN,IBDT,"",.IBARR)
    86         ;
    87         ; -- checks copied from rmprbil v2.0 /feb 2, 1994
    88         Q:'$D(^RMPR(660,+IBDA,"AM"))
    89         Q:$P(^RMPR(660,+IBDA,0),U,9)=""!($P(^(0),U,12)="")!($P(^(0),U,14)="V")!($P(^(0),U,2)="")!($P(^(0),U,15)="*")
    90         ;Q:($P(^RMPR(660,+IBDA,"AM"),U,3)=2)!($P(^("AM"),U,3)=3)
    91         ;
    92         ;
    93         I $O(^IBT(356,"APRO",IBDA,0)) G PRCHKQ ; already in claims tracking
    94         ;
    95         ; -- see if tracking only insured and pt is insured
    96         I $P(IBTRKR,"^",5)=1,'$$INSURED^IBCNS1(DFN,IBDT) G PRCHKQ ; patient not insure
    97         ;
    98         ; -- if clasifications required, check exemptions
    99         I '$D(IBARR) G CLQ
    100         S IBE=0 F IBP=1:1:4 S IBDX(IBP)=$G(^RMPR(660,+IBDA,"BA"_IBP)) I IBDX(IBP) S IBE=1
    101         I 'IBE S IBRMARK="NEEDS SC DETERMINATION" G CLQ ; no ICD node in RMPR, use old method of determining status
    102         S IBE=0 F  S IBE=$O(IBARR(IBE)) Q:'IBE!($L($G(IBRMARK)))  F IBP=1:1:4 Q:$L($G(IBRMARK))  I IBDX(IBP) S IBRMARK=$S($P(IBDX(IBP),"^",IBE+1):$P($T(CLTXT+IBE),";",3),$P(IBDX(IBP),"^",IBE+1)=0:"",1:"NEEDS SC DETERMINATION")
    103         ;
    104         ;
    105 CLQ     ; -- ok to add to tracking module
    106         D PRO^IBTUTL1(DFN,IBDT,IBDA,$G(IBRMARK)) I '$D(ZTQUEUED),$G(IBTALK) W "+"
    107         I $G(IBRMARK)'="" S IBCNT2=IBCNT2+1
    108         I $G(IBRMARK)="" S IBCNT1=IBCNT1+1
    109         K VAEL,VA,IBDATA,DFN,X,Y
    110 PRCHKQ  Q
    111         ;
    112 BULL    ; -- send bulletin
    113         ;
    114         S XMSUB="Prosthetic Items added to Claims Tracking Complete"
    115         S IBT(1)="The process to automatically add Prosthetic Items has successfully completed."
    116         S IBT(1.1)=""
    117         S IBT(2)="                      Start Date: "_$$DAT1^IBOUTL(IBTSBDT)
    118         S IBT(3)="                        End Date: "_$$DAT1^IBOUTL(IBTSEDT)
    119         I $D(IBMESS) S IBT(3.1)=IBMESS
    120         S IBT(4)=""
    121         S IBT(5)=" Total Prosthetics Items checked: "_$G(IBCNT)
    122         S IBT(6)="Total NSC Prosthetic Items Added: "_$G(IBCNT1)
    123         S IBT(7)=" Total SC Prosthetic Items Added: "_$G(IBCNT2)
    124         S IBT(8)=""
    125         S IBT(9)="*The items added as SC require determination and editing to be billed"
    126         D SEND^IBTRKR31
    127 BULLQ   Q
    128         ;
    129 CLTXT   ; classification text for reason not billable
    130         ;;AGENT ORANGE
    131         ;;IONIZING RADIATION
    132         ;;SC TREATMENT
    133         ;;SOUTHWEST ASIA
    134         ;;MILITARY SEXUAL TRAUMA
    135         ;;HEAD/NECK CANCER
    136         ;;COMBAT VETERAN
     1IBTRKR5 ;ALB/AAS - CLAIMS TRACKING - ADD/TRACK PROSTHETICS ;13-JAN-94
     2 ;;2.0;INTEGRATED BILLING;**13,260,312,339**;21-MAR-94;Build 2
     3 ;;Per VHA Directive 2004-038, this routine should not be modified.
     4 ;
     5% ; -- entry point for nightly background job
     6 N IBTSBDT,IBTSEDT
     7 S IBTSBDT=$$FMADD^XLFDT(DT,-30)-.1
     8 S IBTSEDT=$$FMADD^XLFDT(DT,-3)+.9
     9 D EN1
     10 Q
     11 ;
     12EN ; -- entry point to ask date range
     13 N IBSWINFO S IBSWINFO=$$SWSTAT^IBBAPI()                   ;IB*2.0*312
     14 N IBBDT,IBEDT,IBTSBDT,IBTSEDT,IBTALK
     15 S IBTALK=1
     16 I '$P($G(^IBE(350.9,1,6)),"^",4) W !!,"I'm sorry, Tracking of Prosthetics is currently turned off." G ENQ
     17 W !!!,"Select the Date Range of Prosthetics to Add to Claims Tracking.",!
     18 D DATE^IBOUTL
     19 I IBBDT<1!(IBEDT<1) G ENQ
     20 S IBTSBDT=IBBDT,IBTSEDT=IBEDT
     21 ;
     22 ; -- check selected dates                                 ;IB*2.0*312
     23 ; Do NOT PROCESS on VistA if Start or End>=Switch Eff Dt  ;CCR-930
     24 I +IBSWINFO,((IBTSBDT+1)>$P(IBSWINFO,"^",2))!((IBTSEDT+1)>$P(IBSWINFO,"^",2)) D  G EN
     25  .W !!,"The Begin OR End Date CANNOT be on or after the PFSS Effective date"
     26  .W ": ",$$FMTE^XLFDT($P(IBSWINFO,"^",2))
     27 ;
     28 S IBTRKR=$G(^IBE(350.9,1,6))
     29 ; start date can't be before parameters
     30 I +IBTRKR,IBTSBDT<+IBTRKR S IBTSBDT=IBTRKR W !!,"Begin date is before Claims Tracking Start Date, changed to ",$$DAT1^IBOUTL(IBTSBDT)
     31 ; -- end date into future
     32 I IBTSEDT>$$FMADD^XLFDT(DT,-3) W !!,"I'll automatically change the end date to 3 days prior to the date queued to run."
     33 ;
     34 W !!!,"I'm going to automatically queue this off and send you a"
     35 W !,"mail message when complete.",!
     36 S ZTIO="",ZTRTN="EN1^IBTRKR5",ZTSAVE("IB*")="",ZTDESC="IB - Add Prosthetics to Claims Tracking"
     37 D ^%ZTLOAD I $G(ZTSK) K ZTSK W !,"Request Queued"
     38ENQ K ZTSK,ZTIO,ZTSAVE,ZTDESC,ZTRTN
     39 D HOME^%ZIS
     40 Q
     41 ;
     42EN1 ; -- add prostethics to claims tracking file
     43 N I,J,X,Y,IBTRKR,IBDT,DFN,IBDATA,IBCNT,IBCNT1,IBCNT2,IBDTS
     44 N IBSWINFO S IBSWINFO=$$SWSTAT^IBBAPI()                   ;IB*2.0*312
     45 ;
     46 ; -- check parameters
     47 S IBTRKR=$G(^IBE(350.9,1,6))
     48 G:'$P(IBTRKR,"^",5) EN1Q ; quit if prothetics tracking off
     49 I +IBTRKR,IBTSBDT<+IBTRKR S IBTSBDT=IBTRKR ; start date can't be before parameters
     50 ;
     51 ; -- users can queue into future, make sure dates not after date run
     52 I IBTSEDT>$$FMADD^XLFDT(DT,-3) S IBMESS="(Selected end date of "_$$DAT1^IBOUTL(IBTSEDT)_" automatically changed to "_$$DAT1^IBOUTL($$FMADD^XLFDT(DT,-3))_".)",IBTSEDT=$$FMADD^XLFDT(DT,-3)
     53 ;
     54 ;S IBPRTYP=$O(^IBE(356.6,"AC",3,0)) ; this is the event type pointer for prosthetics
     55 ;
     56 ; -- cnt= total count, cnt1=count added nsc, cnt2=count of pending
     57 S (IBCNT,IBCNT1,IBCNT2)=0
     58 S (IBDTS,IBDT)=IBTSBDT-.0001
     59 ;
     60 ; loop twice, once for shipmnet date (new search), and once for
     61 ; delivery date (old search) for backward compatibility.
     62 F  S IBDT=$O(^RMPR(660,"AF",IBDT)) Q:'IBDT!(IBDT>IBTSEDT)  D
     63    .; Do NOT PROCESS on VistA if IBDT>=Switch Eff Date    ;CCR-930
     64    .I +IBSWINFO,(IBDT+1)>$P(IBSWINFO,"^",2) Q             ;IB*2.0*312
     65    .S IBDA=0 F  S IBDA=$O(^RMPR(660,"AF",IBDT,IBDA)) Q:'IBDA  D PRCHK
     66 ;
     67 ; reset date and do old check
     68 S IBDT=IBDTS
     69 F  S IBDT=$O(^RMPR(660,"CT",IBDT)) Q:'IBDT!(IBDT>IBTSEDT)  D
     70    .; Do NOT PROCESS on VistA if IBDT>=Switch Eff Date    ;CCR-930
     71    .I +IBSWINFO,(IBDT+1)>$P(IBSWINFO,"^",2) Q             ;IB*2.0*312
     72    .S IBDA="" F  S IBDA=$O(^RMPR(660,"CT",IBDT,IBDA)) Q:'IBDA  D PRCHK
     73 ;
     74 I $G(IBTALK) D BULL ;^IBTRKR51
     75EN1Q I $D(ZTQUEUED) S ZTREQ="@"
     76 Q
     77 ;
     78PRCHK ; -- check and add item
     79 N IBE,IBP,IBDX,IBRMARK,IBARR,IBT
     80 S IBCNT=IBCNT+1,IBRMARK=""
     81 I '$D(ZTQUEUED),($G(IBTALK)) W "."
     82 ;
     83 S IBDATA=$G(^RMPR(660,+IBDA,0)) Q:IBDATA=""
     84 S DFN=$P(IBDATA,"^",2)
     85 D CL^SDCO21(DFN,IBDT,"",.IBARR)
     86 ;
     87 ; -- checks copied from rmprbil v2.0 /feb 2, 1994
     88 Q:'$D(^RMPR(660,+IBDA,"AM"))
     89 Q:$P(^RMPR(660,+IBDA,0),U,9)=""!($P(^(0),U,12)="")!($P(^(0),U,6)="")!($P(^(0),U,14)="V")!($P(^(0),U,2)="")!($P(^(0),U,15)="*")
     90 ;Q:($P(^RMPR(660,+IBDA,"AM"),U,3)=2)!($P(^("AM"),U,3)=3)
     91 ;
     92 ;
     93 I $O(^IBT(356,"APRO",IBDA,0)) G PRCHKQ ; already in claims tracking
     94 ;
     95 ; -- see if tracking only insured and pt is insured
     96 I $P(IBTRKR,"^",5)=1,'$$INSURED^IBCNS1(DFN,IBDT) G PRCHKQ ; patient not insure
     97 ;
     98 ; -- if clasifications required, check exemptions
     99 I '$D(IBARR) G CLQ
     100 S IBE=0 F IBP=1:1:4 S IBDX(IBP)=$G(^RMPR(660,+IBDA,"BA"_IBP)) I IBDX(IBP) S IBE=1
     101 I 'IBE S IBRMARK="NEEDS SC DETERMINATION" G CLQ ; no ICD node in RMPR, use old method of determining status
     102 S IBE=0 F  S IBE=$O(IBARR(IBE)) Q:'IBE!($L($G(IBRMARK)))  F IBP=1:1:4 Q:$L($G(IBRMARK))  I IBDX(IBP) S IBRMARK=$S($P(IBDX(IBP),"^",IBE+1):$P($T(CLTXT+IBE),";",3),$P(IBDX(IBP),"^",IBE+1)=0:"",1:"NEEDS SC DETERMINATION")
     103 ;
     104 ;
     105CLQ ; -- ok to add to tracking module
     106 D PRO^IBTUTL1(DFN,IBDT,IBDA,$G(IBRMARK)) I '$D(ZTQUEUED),$G(IBTALK) W "+"
     107 I $G(IBRMARK)'="" S IBCNT2=IBCNT2+1
     108 I $G(IBRMARK)="" S IBCNT1=IBCNT1+1
     109 K VAEL,VA,IBDATA,DFN,X,Y
     110PRCHKQ Q
     111 ;
     112BULL ; -- send bulletin
     113 ;
     114 S XMSUB="Prosthetic Items added to Claims Tracking Complete"
     115 S IBT(1)="The process to automatically add Prosthetic Items has successfully completed."
     116 S IBT(1.1)=""
     117 S IBT(2)="                      Start Date: "_$$DAT1^IBOUTL(IBTSBDT)
     118 S IBT(3)="                        End Date: "_$$DAT1^IBOUTL(IBTSEDT)
     119 I $D(IBMESS) S IBT(3.1)=IBMESS
     120 S IBT(4)=""
     121 S IBT(5)=" Total Prosthetics Items checked: "_$G(IBCNT)
     122 S IBT(6)="Total NSC Prosthetic Items Added: "_$G(IBCNT1)
     123 S IBT(7)=" Total SC Prosthetic Items Added: "_$G(IBCNT2)
     124 S IBT(8)=""
     125 S IBT(9)="*The items added as SC require determination and editing to be billed"
     126 D SEND^IBTRKR31
     127BULLQ Q
     128 ;
     129CLTXT ; classification text for reason not billable
     130 ;;AGENT ORANGE
     131 ;;IONIZING RADIATION
     132 ;;SC TREATMENT
     133 ;;SOUTHWEST ASIA
     134 ;;MILITARY SEXUAL TRAUMA
     135 ;;HEAD/NECK CANCER
     136 ;;COMBAT VETERAN

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXBCR2.m

    r613 r623  
    1 IBXBCR2 ; GENERATED FROM 'IB BILLING CLOCK HEADER' PRINT TEMPLATE (#242) ; 12/13/08 ; (FILE 351, MARGIN=80)
     1IBXBCR2 ; GENERATED FROM 'IB BILLING CLOCK HEADER' PRINT TEMPLATE (#242) ; 10/03/99 ; (FILE 351, MARGIN=80)
    22 G BEGIN
    33N W !
    … …  
    1414 I $D(DXS)<9 M DXS=^DIPT(242,"DXS")
    1515 S I(0)="^IBE(351,",J(0)=351
    16  S X=$G(^IBE(351,D0,0)) D N:$X>0 Q:'DN  W ?0 S Y=$P(X,U,2) S Y=$S(Y="":Y,$D(^DPT(Y,0))#2:$P(^(0),U),1:Y) W $E(Y,1,20)
     16 S X=$G(^IBE(351,D0,0)) D N:$X>0 Q:'DN  W ?0 S Y=$P(X,U,2) S Y=$S(Y="":Y,$D(^DPT(Y,0))#2:$P(^(0),U,1),1:Y) W $E(Y,1,20)
    1717 S I(100)="^DPT(",J(100)=2 S I(0,0)=D0 S DIP(1)=$S($D(^IBE(351,D0,0)):^(0),1:"") S X=$P(DIP(1),U,2),X=X S D(0)=+X S D0=D(0) I D0>0 D A1
    1818 G A1R
    … …  
    2020 D N:$X>24 Q:'DN  W ?24 X DXS(1,9) K DIP K:DN Y W $E(X,1,12)
    2121 S X=$G(^DPT(D0,0)) D N:$X>40 Q:'DN  W ?40 S Y=$P(X,U,3) S Y(0)=Y S X=Y(0) S:X X=$E(X,4,5)_"/"_$E(X,6,7)_"/"_(1700+$E(X,1,3)) S Y=X W $E(Y,1,12)
    22  S X=$G(^DPT(D0,"TYPE")) D N:$X>56 Q:'DN  W ?56 S Y=$P(X,U,1) S Y=$S(Y="":Y,$D(^DG(391,Y,0))#2:$P(^(0),U),1:Y) W $E(Y,1,22)
     22 S X=$G(^DPT(D0,"TYPE")) D N:$X>56 Q:'DN  W ?56 S Y=$P(X,U,1) S Y=$S(Y="":Y,$D(^DG(391,Y,0))#2:$P(^(0),U,1),1:Y) W $E(Y,1,22)
    2323 Q
    2424A1R ;

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC1.m

    r613 r623  
    1 IBXSC1 ; GENERATED FROM 'IB SCREEN1' INPUT TEMPLATE(#508), FILE 399;12/13/08
     1IBXSC1 ; GENERATED FROM 'IB SCREEN1' INPUT TEMPLATE(#508), FILE 399;12/27/07
    22 D DE G BEGIN
    33DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGCR(399,DA,""))=""

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC11.m

    r613 r623  
    1 IBXSC11 ; ;12/13/08
     1IBXSC11 ; ;12/27/07
    22 D DE G BEGIN
    33DE S DIE="^DPT(",DIC=DIE,DP=2,DL=2,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))=""
    44 I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,2) S:%]"" DE(8)=% S %=$P(%Z,U,3) S:%]"" DE(2)=% S %=$P(%Z,U,5) S:%]"" DE(9)=%
    5  I $D(^(.11)) S %Z=^(.11) S %=$P(%Z,U,1) S:%]"" DE(17)=%
    65 I $D(^(.36)) S %Z=^(.36) S %=$P(%Z,U,1) S:%]"" DE(13)=%
    76 I $D(^("VET")) S %Z=^("VET") S %=$P(%Z,U,1) S:%]"" DE(12)=%
    … …  
    179178X11 S:IBDR20'["14" Y="@15"
    180179 Q
    181 12 D:$D(DG)>9 F^DIE17,DE S DQ=12,DW="VET;1",DV="SXa",DU="",DLB="VETERAN (Y/N)?",DIFLD=1901
     18012 D:$D(DG)>9 F^DIE17,DE S DQ=12,DW="VET;1",DV="RSXa",DU="",DLB="VETERAN (Y/N)?",DIFLD=1901
    182181 S DE(DW)="C12^IBXSC11"
    183182 S DU="Y:YES;N:NO;"
    184183 G RE
    185184C12 G C12S:$D(DE(12))[0 K DB
    186  S X=DE(12),DIC=DIE
    187  S DFN=DA D EN^DGMTCOR K DGMTCOR
    188  S X=DE(12),DIC=DIE
    189  S DFN=DA D EN^DGRP7CC
    190  S X=DE(12),DIC=DIE
    191  ;
    192  S X=DE(12),DIC=DIE
    193  D AUTOUPD^DGENA2(DA)
    194  S X=DE(12),DIC=DIE
    195  I ($T(AVAFC^VAFCDD01)'="") S VAFCF="1901;" D AVAFC^VAFCDD01(DA)
    196  S X=DE(12),DIC=DIE
    197  D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
    198  S X=DE(12),DIIX=2_U_DIFLD D AUDIT^DIET
     185 D ^IBXSC13
    199186C12S S X="" G:DG(DQ)=X C12F1 K DB
    200  S X=DG(DQ),DIC=DIE
    201  S DFN=DA D EN^DGMTCOR K DGMTCOR
    202  S X=DG(DQ),DIC=DIE
    203  S DFN=DA D EN^DGRP7CC
    204  S X=DG(DQ),DIC=DIE
    205  X ^DD(2,1901,1,3,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.3)):^(.3),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X=DIV S X="N" X ^DD(2,1901,1,3,1.4)
    206  S X=DG(DQ),DIC=DIE
    207  D AUTOUPD^DGENA2(DA)
    208  S X=DG(DQ),DIC=DIE
    209  I ($T(AVAFC^VAFCDD01)'="") S VAFCF="1901;" D AVAFC^VAFCDD01(DA)
    210  S X=DG(DQ),DIC=DIE
    211  D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
    212  I $D(DE(12))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET
     187 D ^IBXSC14
    213188C12F1 Q
    214189X12 I $D(X) S:'$D(DPTX) DFN=DA D:'$D(^XUSEC("DG ELIGIBILITY",DUZ)) VAGE^DGLOCK:X="Y" I $D(X) D:$D(DFN) EV^DGLOCK
    … …  
    220195 G RE
    221196C13 G C13S:$D(DE(13))[0 K DB
    222  S X=DE(13),DIC=DIE
    223  ;
    224  S X=DE(13),DIC=DIE
    225  K DIV S DIV=X,D0=DA,DIV(0)=D0 X ^DD(2,.361,1,2,2.2) I DIV(1)>0 S DIK(0)=DA,DIK="^DPT(DIV(0),""E"",",DA(1)=DIV(0),DA=DIV(1) D ^DIK S DA=DIK(0) K DIK
    226  S X=DE(13),DIC=DIE
    227  X "I $S('$D(^DIC(8,+X,0)):0,$P(^(0),""^"",1)[""DOM"":0,'$D(^DPT(DA,.36)):1,'$D(^DIC(8,+^(.36),0)):1,$P(^(0),""^"",1)'[""DOM"":1,1:0) S DGXRF=.361 D ^DGDDC Q"
    228  S X=DE(13),DIC=DIE
    229  K ^DPT("AEL",DA,+X)
    230  S X=DE(13),DIC=DIE
    231  D AUTOUPD^DGENA2(DA)
    232  S X=DE(13),DIIX=2_U_DIFLD D AUDIT^DIET
     197 D ^IBXSC15
    233198C13S S X="" G:DG(DQ)=X C13F1 K DB
    234  D ^IBXSC13
     199 D ^IBXSC16
    235200C13F1 Q
    236201X13 S DFN=DA D EV^DGLOCK I $D(X) D ECD^DGLOCK1
    … …  
    244209X16 S:$$EDADDR^IBCSCE(+$G(DFN)) Y="@155"
    245210 Q
    246 17 D:$D(DG)>9 F^DIE17,DE S DQ=17,DW=".11;1",DV="Fa",DU="",DLB="STREET ADDRESS [LINE 1]",DIFLD=.111
    247  S DE(DW)="C17^IBXSC11",DE(DW,"INDEX")=1
    248  G RE
    249 C17 G C17S:$D(DE(17))[0 K DB
    250  D ^IBXSC14
    251 C17S S X="" G:DG(DQ)=X C17F1 K DB
    252  D ^IBXSC15
    253 C17F1 N X,X1,X2 S DIXR=230 D C17X1(U) K X2 M X2=X D C17X1("O") K X1 M X1=X
    254  D
    255  . D FC^DGFCPROT(.DA,2,.111,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q
    256  K X M X=X2 D
    257  . D FC^DGFCPROT(.DA,2,.111,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q
    258  G C17F2
    259 C17X1(DION) K X
    260  S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.111,DION),$P($G(^DPT(DA,.11)),U,1))
    261  S X=$G(X(1))
    262  Q
    263 C17F2 Q
    264 X17 K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>35!($L(X)<3) X
    265  I $D(X),X'?.ANP K X
    266  Q
    267  ;
    268 18 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=18 D X18 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
    269 X18 S:X="" Y=.114
    270  Q
    271 19 D:$D(DG)>9 F^DIE17 G ^IBXSC16
     21117 D:$D(DG)>9 F^DIE17 G ^IBXSC17

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC110.m

    r613 r623  
    1 IBXSC110 ; ;12/13/08
    2  S X=DG(DQ),DIC=DIE
    3  D SET^DGREGDD1(DA,.116,.11,6,$E(X,1,5))
    4  S X=DG(DQ),DIC=DIE
     1IBXSC110 ; ;12/27/07
     2 S X=DE(6),DIC=DIE
     3 S A1B2TAG="PAT" D ^A1B2XFR
     4 S X=DE(6),DIC=DIE
    55 D EVENT^IVMPLOG(DA)
    6  S X=DG(DQ),DIC=DIE
     6 S X=DE(6),DIC=DIE
    77 K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR
    8  S X=DG(DQ),DIC=DIE
     8 S X=DE(6),DIC=DIE
    99 S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX
    10  S X=DG(DQ),DIC=DIE
    11  I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".1112;" D AVAFC^VAFCDD01(DA)
    12  S X=DG(DQ),DIC=DIE
     10 S X=DE(6),DIC=DIE
     11 I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".114;" D AVAFC^VAFCDD01(DA)
     12 S X=DE(6),DIC=DIE
    1313 D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
    14  I $D(DE(6))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET
     14 S X=DE(6),DIIX=2_U_DIFLD D AUDIT^DIET

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC111.m

    r613 r623  
    1 IBXSC111 ; ;12/13/08
    2  S X=DE(7),DIC=DIE
     1IBXSC111 ; ;12/27/07
     2 S X=DG(DQ),DIC=DIE
    33 S A1B2TAG="PAT" D ^A1B2XFR
    4  S X=DE(7),DIC=DIE
     4 S X=DG(DQ),DIC=DIE
    55 D EVENT^IVMPLOG(DA)
    6  S X=DE(7),DIC=DIE
     6 S X=DG(DQ),DIC=DIE
     7 K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR
     8 S X=DG(DQ),DIC=DIE
    79 S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX
    8  S X=DE(7),DIC=DIE
    9  I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".117;" D AVAFC^VAFCDD01(DA)
    10  S X=DE(7),DIIX=2_U_DIFLD D AUDIT^DIET
     10 S X=DG(DQ),DIC=DIE
     11 I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".114;" D AVAFC^VAFCDD01(DA)
     12 S X=DG(DQ),DIC=DIE
     13 D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
     14 I $D(DE(6))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC112.m

    r613 r623  
    1 IBXSC112 ; ;12/13/08
    2  S X=DG(DQ),DIC=DIE
     1IBXSC112 ; ;12/27/07
     2 S X=DE(7),DIC=DIE
     3 K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:""),Y=$P(Y(1),U,7) X:$D(^DD(2,.117,2)) ^(2) S X=Y S DIU=X K Y S X=DIV S X="" X ^DD(2,.115,1,1,2.4)
     4 S X=DE(7),DIC=DIE
    35 S A1B2TAG="PAT" D ^A1B2XFR
    4  S X=DG(DQ),DIC=DIE
     6 S X=DE(7),DIC=DIE
    57 D EVENT^IVMPLOG(DA)
    6  S X=DG(DQ),DIC=DIE
     8 S X=DE(7),DIC=DIE
     9 K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR
     10 S X=DE(7),DIC=DIE
    711 S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX
    8  S X=DG(DQ),DIC=DIE
    9  I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".117;" D AVAFC^VAFCDD01(DA)
    10  I $D(DE(7))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET
     12 S X=DE(7),DIC=DIE
     13 I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".115;" D AVAFC^VAFCDD01(DA)
     14 S X=DE(7),DIC=DIE
     15 D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
     16 S X=DE(7),DIIX=2_U_DIFLD D AUDIT^DIET

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC113.m

    r613 r623  
    1 IBXSC113 ; ;12/13/08
    2  D DE G BEGIN
    3 DE S DIE="^DPT(",DIC=DIE,DP=2,DL=2,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))=""
    4  I $D(^(.121)) S %Z=^(.121) S %=$P(%Z,U,1) S:%]"" DE(8)=% S %=$P(%Z,U,2) S:%]"" DE(10)=% S %=$P(%Z,U,3) S:%]"" DE(12)=% S %=$P(%Z,U,4) S:%]"" DE(13)=% S %=$P(%Z,U,5) S:%]"" DE(14)=% S %=$P(%Z,U,7) S:%]"" DE(5)=% S %=$P(%Z,U,8) S:%]"" DE(7)=%
    5  I  S %=$P(%Z,U,9) S:%]"" DE(3)=% S %=$P(%Z,U,10) S:%]"" DE(16)=% S %=$P(%Z,U,12) S:%]"" DE(15)=%
    6  I $D(^(.13)) S %Z=^(.13) S %=$P(%Z,U,1) S:%]"" DE(1)=%
    7  K %Z Q
     1IBXSC113 ; ;12/27/07
     2 S X=DG(DQ),DIC=DIE
    83 ;
    9 W W !?DL+DL-2,DLB_": "
    10  Q
    11 O D W W Y W:$X>45 !?9
    12  I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2
    13  W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W "  (No Editing)" Q
    14 TR R X:DTIME E  S (DTOUT,X)=U W $C(7)
    15  Q
    16 A K DQ(DQ) S DQ=DQ+1
    17 B G @DQ
    18 RE G PR:$D(DE(DQ)) D W,TR
    19 N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A
    20 RD G QS:X?."?" I X["^" D D G ^DIE17
    21  I X="@" D D G Z^DIE2
    22  I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W "  "_X
    23 T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I  W:'$D(DB(DQ)) "  "_% G V
    24  K DDER G X
    25 P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0
    26  G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z
    27  I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X
    28 V D @("X"_DQ) K YS
    29 Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A
    30 X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17
    31  S X="?BAD"
    32 QS S DZ=X D D,QQ^DIEQ G B
    33 D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q
    34 Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N
    35 PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP
    36 R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R
    37  I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R
    38  X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=%
    39 RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17
    40 I I DV'["I",DV'["#" G RD
    41  D E^DIE0 G RD:$D(X),PR
    42  Q
    43 SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1
    44  I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1
    45  D ^DIR I 'DDER S %=Y(0),X=Y
    46  Q
    47 SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ))
    48  I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")=""
    49  E  K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")
    50  Q
    51 NKEY W:'$D(ZTQUEUED) "??  Required key field" S X="?BAD" G QS
    52 KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY")
    53 BEGIN S DNM="IBXSC113",DQ=1
    54 1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW=".13;1",DV="Fa",DU="",DLB="PHONE NUMBER [RESIDENCE]",DIFLD=.131
    55  S DE(DW)="C1^IBXSC113"
    56  G RE
    57 C1 G C1S:$D(DE(1))[0 K DB
    58  S X=DE(1),DIC=DIE
    59  D EVENT^IVMPLOG(DA)
    60  S X=DE(1),DIC=DIE
    61  S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX
    62  S X=DE(1),DIC=DIE
    63  I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".131;" D AVAFC^VAFCDD01(DA)
    64  S X=DE(1),DIC=DIE
    65  D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
    66  S X=DE(1),DIC=DIE
    67  X "N % S %=$E($TR(X,""ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz!@#$%^&*()-_=+[]{}<>,./?:;'\|""),1,30) K:%'="""" ^DPT(""AZVWVOE"",%,DA)"
    68  S X=DE(1),DIIX=2_U_DIFLD D AUDIT^DIET
    69 C1S S X="" G:DG(DQ)=X C1F1 K DB
     4 S X=DG(DQ),DIC=DIE
     5 S A1B2TAG="PAT" D ^A1B2XFR
    706 S X=DG(DQ),DIC=DIE
    717 D EVENT^IVMPLOG(DA)
    728 S X=DG(DQ),DIC=DIE
     9 K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR
     10 S X=DG(DQ),DIC=DIE
    7311 S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX
    7412 S X=DG(DQ),DIC=DIE
    75  I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".131;" D AVAFC^VAFCDD01(DA)
     13 I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".115;" D AVAFC^VAFCDD01(DA)
    7614 S X=DG(DQ),DIC=DIE
    7715 D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
    78  S X=DG(DQ),DIC=DIE
    79  X "N % S %=$E($TR(X,""ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz!@#$%^&*()-_=+[]{}<>,./?:;'\|""),1,30) S:%'="""" ^DPT(""AZVWVOE"",%,DA)="""""
    80  I $D(DE(1))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET
    81 C1F1 Q
    82 X1 K:$L(X)>20!($L(X)<4) X
    83  I $D(X),X'?.ANP K X
    84  Q
    85  ;
    86 2 S DQ=3 ;@155
    87 3 D:$D(DG)>9 F^DIE17,DE S DQ=3,DW=".121;9",DV="RSX",DU="",DLB="TEMPORARY ADDRESS ACTIVE?",DIFLD=.12105
    88  S DE(DW)="C3^IBXSC113",DE(DW,"INDEX")=1
    89  S DU="Y:YES;N:NO;"
    90  G RE
    91 C3 G C3S:$D(DE(3))[0 K DB
    92  S X=DE(3),DIC=DIE
    93  X "S DGXRF=.12105 D ^DGDDC Q"
    94 C3S S X="" G:DG(DQ)=X C3F1 K DB
    95  S X=DG(DQ),DIC=DIE
    96  ;
    97 C3F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
    98  F DIXR=600 S DIEZRXR(2,DIXR)=""
    99  Q
    100 X3 S DFN=DA I X="N" D TADD^DGLOCK
    101  Q
    102  ;
    103 4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
    104 X4 S:X="N" Y="@915" S:X="Y" DIE("NO^")=""
    105  Q
    106 5 D:$D(DG)>9 F^DIE17,DE S DQ=5,DW=".121;7",DV="DX",DU="",DLB="TEMPORARY ADDRESS START DATE",DIFLD=.1217
    107  S DE(DW)="C5^IBXSC113",DE(DW,"INDEX")=1
    108  G RE
    109 C5 G C5S:$D(DE(5))[0 K DB
    110  S X=DE(5),DIC=DIE
    111  ;
    112 C5S S X="" G:DG(DQ)=X C5F1 K DB
    113  S X=DG(DQ),DIC=DIE
    114  ;
    115 C5F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
    116  F DIXR=600 S DIEZRXR(2,DIXR)=""
    117  Q
    118 X5 S %DT="E" D ^%DT S X=Y K:Y<1 X I $D(X) S DFN=DA D TAD^DGLOCK
    119  Q
    120  ;
    121 6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 D X6 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
    122 X6 I X']"" W !?4,*7,"But I need a Start Date for this Temporary Address." S Y=.12105
    123  Q
    124 7 D:$D(DG)>9 F^DIE17,DE S DQ=7,DW=".121;8",DV="DX",DU="",DLB="TEMPORARY ADDRESS END DATE",DIFLD=.1218
    125  S DE(DW)="C7^IBXSC113",DE(DW,"INDEX")=1
    126  G RE
    127 C7 G C7S:$D(DE(7))[0 K DB
    128 C7S S X="" G:DG(DQ)=X C7F1 K DB
    129 C7F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
    130  F DIXR=600 S DIEZRXR(2,DIXR)=""
    131  Q
    132 X7 S %DT="E" D ^%DT S X=Y K:Y<1 X I $D(X) S DFN=DA D TAD^DGLOCK I $D(X),(X<$P(^DPT(DFN,.121),"^",7)) K X
    133  Q
    134  ;
    135 8 D:$D(DG)>9 F^DIE17,DE S DQ=8,DW=".121;1",DV="FX",DU="",DLB="TEMPORARY STREET [LINE 1]",DIFLD=.1211
    136  S DE(DW)="C8^IBXSC113",DE(DW,"INDEX")=1
    137  G RE
    138 C8 G C8S:$D(DE(8))[0 K DB
    139  S X=DE(8),DIC=DIE
    140  X "S DGXRF=.1211 D ^DGDDC Q"
    141 C8S S X="" G:DG(DQ)=X C8F1 K DB
    142  S X=DG(DQ),DIC=DIE
    143  ;
    144 C8F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
    145  F DIXR=600 S DIEZRXR(2,DIXR)=""
    146  Q
    147 X8 K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>30!($L(X)<2) X I $D(X) S DFN=DA D TAD^DGLOCK
    148  I $D(X),X'?.ANP K X
    149  Q
    150  ;
    151 9 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=9 D X9 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
    152 X9 I X']"" W !?4,*7,"But I need at least one line of a Temporary address." S Y=.12105
    153  Q
    154 10 D:$D(DG)>9 F^DIE17,DE S DQ=10,DW=".121;2",DV="FX",DU="",DLB="TEMPORARY STREET [LINE 2]",DIFLD=.1212
    155  S DE(DW)="C10^IBXSC113",DE(DW,"INDEX")=1
    156  G RE
    157 C10 G C10S:$D(DE(10))[0 K DB
    158  S X=DE(10),DIC=DIE
    159  X "S DGXRF=.1212 D ^DGDDC Q"
    160 C10S S X="" G:DG(DQ)=X C10F1 K DB
    161  S X=DG(DQ),DIC=DIE
    162  ;
    163 C10F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
    164  F DIXR=600 S DIEZRXR(2,DIXR)=""
    165  Q
    166 X10 K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>30!($L(X)<2) X I $D(X) S DFN=DA D TAD^DGLOCK
    167  I $D(X),X'?.ANP K X
    168  Q
    169  ;
    170 11 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=11 D X11 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
    171 X11 S:X']"" Y=.1214
    172  Q
    173 12 D:$D(DG)>9 F^DIE17,DE S DQ=12,DW=".121;3",DV="FX",DU="",DLB="TEMPORARY STREET [LINE 3]",DIFLD=.1213
    174  S DE(DW)="C12^IBXSC113",DE(DW,"INDEX")=1
    175  G RE
    176 C12 G C12S:$D(DE(12))[0 K DB
    177 C12S S X="" G:DG(DQ)=X C12F1 K DB
    178 C12F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
    179  F DIXR=600 S DIEZRXR(2,DIXR)=""
    180  Q
    181 X12 K:$L(X)>30!($L(X)<2) X I $D(X) S DFN=DA D TAD^DGLOCK
    182  I $D(X),X'?.ANP K X
    183  Q
    184  ;
    185 13 D:$D(DG)>9 F^DIE17,DE S DQ=13,DW=".121;4",DV="FX",DU="",DLB="TEMPORARY CITY",DIFLD=.1214
    186  S DE(DW)="C13^IBXSC113",DE(DW,"INDEX")=1
    187  G RE
    188 C13 G C13S:$D(DE(13))[0 K DB
    189 C13S S X="" G:DG(DQ)=X C13F1 K DB
    190 C13F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
    191  F DIXR=600 S DIEZRXR(2,DIXR)=""
    192  Q
    193 X13 K:$L(X)>30!($L(X)<2) X I $D(X) S DFN=DA D TAD^DGLOCK
    194  I $D(X),X'?.ANP K X
    195  Q
    196  ;
    197 14 D:$D(DG)>9 F^DIE17,DE S DQ=14,DW=".121;5",DV="P5'X",DU="",DLB="TEMPORARY STATE",DIFLD=.1215
    198  S DE(DW)="C14^IBXSC113",DE(DW,"INDEX")=1
    199  S DU="DIC(5,"
    200  G RE
    201 C14 G C14S:$D(DE(14))[0 K DB
    202 C14S S X="" G:DG(DQ)=X C14F1 K DB
    203 C14F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
    204  F DIXR=600 S DIEZRXR(2,DIXR)=""
    205  Q
    206 X14 S DFN=DA D TAD^DGLOCK Q
    207  Q
    208  ;
    209 15 D:$D(DG)>9 F^DIE17,DE S DQ=15,DW=".121;12",DV="FOX",DU="",DLB="TEMPORARY ZIP+4",DIFLD=.12112
    210  S DQ(15,2)="S Y(0)=Y D ZIPOUT^VAFADDR"
    211  S DE(DW)="C15^IBXSC113",DE(DW,"INDEX")=1
    212  G RE
    213 C15 G C15S:$D(DE(15))[0 K DB
    214  S X=DE(15),DIC=DIE
    215  D KILL^DGREGDD1(DA,.1216,.121,6,$E(X,1,5))
    216 C15S S X="" G:DG(DQ)=X C15F1 K DB
    217  S X=DG(DQ),DIC=DIE
    218  D SET^DGREGDD1(DA,.1216,.121,6,$E(X,1,5))
    219 C15F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
    220  F DIXR=600 S DIEZRXR(2,DIXR)=""
    221  Q
    222 X15 K:X[""""!($A(X)=45) X I $D(X) S DFN=DA D TAD^DGLOCK I $D(X) K:$L(X)>20!($L(X)<5) X I $D(X) D ZIPIN^VAFADDR
    223  I $D(X),X'?.ANP K X
    224  Q
    225  ;
    226 16 D:$D(DG)>9 F^DIE17,DE S DQ=16,DW=".121;10",DV="FX",DU="",DLB="TEMPORARY PHONE NUMBER",DIFLD=.1219
    227  S DE(DW)="C16^IBXSC113"
    228  G RE
    229 C16 G C16S:$D(DE(16))[0 K DB
    230  S X=DE(16),DIC=DIE
    231  D EVENT^IVMPLOG(DA)
    232 C16S S X="" G:DG(DQ)=X C16F1 K DB
    233  S X=DG(DQ),DIC=DIE
    234  D EVENT^IVMPLOG(DA)
    235 C16F1 Q
    236 X16 K:$L(X)>20!($L(X)<4) X I $D(X) S DFN=DA D TAD^DGLOCK
    237  I $D(X),X'?.ANP K X
    238  Q
    239  ;
    240 17 S DQ=18 ;@915
    241 18 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=18 D X18 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
    242 X18 K DIE("NO^")
    243  Q
    244 19 S DQ=20 ;@16
    245 20 G 1^DIE17
     16 I $D(DE(7))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC114.m

    r613 r623  
    1 IBXSC114 ; ;12/13/08
    2  ;;
    3 1 N X,X1,X2 S DIXR=600 D X1(U) K X2 M X2=X D X1("F") K X1 M X1=X
     1IBXSC114 ; ;12/27/07
     2 D DE G BEGIN
     3DE S DIE="^DPT(",DIC=DIE,DP=2,DL=2,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))=""
     4 I $D(^(.11)) S %Z=^(.11) S %=$P(%Z,U,7) S:%]"" DE(2)=% S %=$P(%Z,U,12) S:%]"" DE(1)=%
     5 I $D(^(.121)) S %Z=^(.121) S %=$P(%Z,U,7) S:%]"" DE(7)=% S %=$P(%Z,U,9) S:%]"" DE(5)=%
     6 I $D(^(.13)) S %Z=^(.13) S %=$P(%Z,U,1) S:%]"" DE(3)=%
     7 K %Z Q
     8 ;
     9W W !?DL+DL-2,DLB_": "
     10 Q
     11O D W W Y W:$X>45 !?9
     12 I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2
     13 W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W "  (No Editing)" Q
     14TR R X:DTIME E  S (DTOUT,X)=U W $C(7)
     15 Q
     16A K DQ(DQ) S DQ=DQ+1
     17B G @DQ
     18RE G PR:$D(DE(DQ)) D W,TR
     19N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A
     20RD G QS:X?."?" I X["^" D D G ^DIE17
     21 I X="@" D D G Z^DIE2
     22 I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W "  "_X
     23T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I  W:'$D(DB(DQ)) "  "_% G V
     24 K DDER G X
     25P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0
     26 G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z
     27 I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X
     28V D @("X"_DQ) K YS
     29Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A
     30X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17
     31 S X="?BAD"
     32QS S DZ=X D D,QQ^DIEQ G B
     33D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q
     34Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N
     35PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP
     36R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R
     37 I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R
     38 X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=%
     39RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17
     40I I DV'["I",DV'["#" G RD
     41 D E^DIE0 G RD:$D(X),PR
     42 Q
     43SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1
     44 I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1
     45 D ^DIR I 'DDER S %=Y(0),X=Y
     46 Q
     47SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ))
     48 I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")=""
     49 E  K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")
     50 Q
     51NKEY W:'$D(ZTQUEUED) "??  Required key field" S X="?BAD" G QS
     52KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY")
     53BEGIN S DNM="IBXSC114",DQ=1
     541 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW=".11;12",DV="FXOa",DU="",DLB="ZIP+4",DIFLD=.1112
     55 S DQ(1,2)="S Y(0)=Y D ZIPOUT^VAFADDR"
     56 S DE(DW)="C1^IBXSC114",DE(DW,"INDEX")=1
     57 G RE
     58C1 G C1S:$D(DE(1))[0 K DB
     59 S X=DE(1),DIC=DIE
     60 D KILL^DGREGDD1(DA,.116,.11,6,$E(X,1,5))
     61 S X=DE(1),DIC=DIE
     62 D EVENT^IVMPLOG(DA)
     63 S X=DE(1),DIC=DIE
     64 K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR
     65 S X=DE(1),DIC=DIE
     66 S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX
     67 S X=DE(1),DIC=DIE
     68 I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".1112;" D AVAFC^VAFCDD01(DA)
     69 S X=DE(1),DIC=DIE
     70 D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
     71 S X=DE(1),DIIX=2_U_DIFLD D AUDIT^DIET
     72C1S S X="" G:DG(DQ)=X C1F1 K DB
     73 S X=DG(DQ),DIC=DIE
     74 D SET^DGREGDD1(DA,.116,.11,6,$E(X,1,5))
     75 S X=DG(DQ),DIC=DIE
     76 D EVENT^IVMPLOG(DA)
     77 S X=DG(DQ),DIC=DIE
     78 K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR
     79 S X=DG(DQ),DIC=DIE
     80 S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX
     81 S X=DG(DQ),DIC=DIE
     82 I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".1112;" D AVAFC^VAFCDD01(DA)
     83 S X=DG(DQ),DIC=DIE
     84 D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
     85 I $D(DE(1))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET
     86C1F1 N X,X1,X2 S DIXR=185 D C1X1(U) K X2 M X2=X D C1X1("O") K X1 M X1=X
    487 D
    5  . D TEMP^DGDDDTTM
     88 . N DIEXARR M DIEXARR=X S DIEZCOND=1
     89 . I X1(1)'=X2(1)
     90 . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND
     91 . K EASDO2
     92 G C1F2
     93C1X1(DION) K X
     94 S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.1112,DION),$P($G(^DPT(DA,.11)),U,12))
     95 S:('$G(EASDO2)&($D(EASZIPLK))) X=$$ZIP^DGREGDD1(DA,X(1))
     96 S:$D(X)#2 X(2)=X
     97 S X=$G(X(1))
     98 Q
     99C1F2 S DIXR=231 D C1X2(U) K X2 M X2=X D C1X2("O") K X1 M X1=X
     100 D
     101 . D FC^DGFCPROT(.DA,2,.1112,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q
    6102 K X M X=X2 D
    7  . D TEMP^DGDDDTTM
    8  Q
    9 X1(DION) K X
    10  S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.1211,DION),$P($G(^DPT(DA,.121)),U,1))
    11  S X(2)=$G(@DIEZTMP@("V",2,DIIENS,.1212,DION),$P($G(^DPT(DA,.121)),U,2))
    12  S X(3)=$G(@DIEZTMP@("V",2,DIIENS,.1213,DION),$P($G(^DPT(DA,.121)),U,3))
    13  S X(4)=$G(@DIEZTMP@("V",2,DIIENS,.1214,DION),$P($G(^DPT(DA,.121)),U,4))
    14  S X(5)=$G(@DIEZTMP@("V",2,DIIENS,.1215,DION),$P($G(^DPT(DA,.121)),U,5))
    15  S X(6)=$G(@DIEZTMP@("V",2,DIIENS,.1216,DION),$P($G(^DPT(DA,.121)),U,6))
    16  S X(7)=$G(@DIEZTMP@("V",2,DIIENS,.1217,DION),$P($G(^DPT(DA,.121)),U,7))
    17  S X(8)=$G(@DIEZTMP@("V",2,DIIENS,.1218,DION),$P($G(^DPT(DA,.121)),U,8))
    18  S X(9)=$G(@DIEZTMP@("V",2,DIIENS,.12105,DION),$P($G(^DPT(DA,.121)),U,9))
    19  S X(10)=$G(@DIEZTMP@("V",2,DIIENS,.12112,DION),$P($G(^DPT(DA,.121)),U,12))
     103 . D FC^DGFCPROT(.DA,2,.1112,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q
     104 G C1F3
     105C1X2(DION) K X
     106 S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.1112,DION),$P($G(^DPT(DA,.11)),U,12))
    20107 S X=$G(X(1))
    21108 Q
     109C1F3 Q
     110X1 K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>20!($L(X)<5) X I $D(X) D ZIPIN^VAFADDR
     111 I $D(X),X'?.ANP K X
     112 Q
     113 ;
     1142 D:$D(DG)>9 F^DIE17,DE S DQ=2,DW=".11;7",DV="NJ3,0XOa",DU="",DLB="COUNTY",DIFLD=.117
     115 S DQ(2,2)="S Y(0)=Y Q:Y']""""  S Z0=$S($D(^DPT(D0,.11)):+$P(^(.11),""^"",5),1:"""") Q:'Z0  S Y=$P($S($D(^DIC(5,Z0,1,Y,0)):^(0),1:""""),""^"",3)"
     116 S DE(DW)="C2^IBXSC114"
     117 G RE
     118C2 G C2S:$D(DE(2))[0 K DB
     119 S X=DE(2),DIC=DIE
     120 S A1B2TAG="PAT" D ^A1B2XFR
     121 S X=DE(2),DIC=DIE
     122 D EVENT^IVMPLOG(DA)
     123 S X=DE(2),DIC=DIE
     124 S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX
     125 S X=DE(2),DIC=DIE
     126 I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".117;" D AVAFC^VAFCDD01(DA)
     127 S X=DE(2),DIIX=2_U_DIFLD D AUDIT^DIET
     128C2S S X="" G:DG(DQ)=X C2F1 K DB
     129 S X=DG(DQ),DIC=DIE
     130 S A1B2TAG="PAT" D ^A1B2XFR
     131 S X=DG(DQ),DIC=DIE
     132 D EVENT^IVMPLOG(DA)
     133 S X=DG(DQ),DIC=DIE
     134 S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX
     135 S X=DG(DQ),DIC=DIE
     136 I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".117;" D AVAFC^VAFCDD01(DA)
     137 I $D(DE(2))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET
     138C2F1 Q
     139X2 S Z0=$S($D(^DPT(D0,.11)):+$P(^(.11),"^",5),1:0) K:'Z0 X Q:'Z0!'$D(^DIC(5,Z0,1,0))  S DIC="^DIC(5,Z0,1,",DIC(0)="QEM" D ^DIC S X=+Y K:Y'>0 X K Z0,DIC
     140 Q
     141 ;
     1423 D:$D(DG)>9 F^DIE17,DE S DQ=3,DW=".13;1",DV="Fa",DU="",DLB="PHONE NUMBER [RESIDENCE]",DIFLD=.131
     143 S DE(DW)="C3^IBXSC114"
     144 G RE
     145C3 G C3S:$D(DE(3))[0 K DB
     146 S X=DE(3),DIC=DIE
     147 D EVENT^IVMPLOG(DA)
     148 S X=DE(3),DIC=DIE
     149 S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX
     150 S X=DE(3),DIC=DIE
     151 I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".131;" D AVAFC^VAFCDD01(DA)
     152 S X=DE(3),DIC=DIE
     153 D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
     154 S X=DE(3),DIC=DIE
     155 X "K ^DPT(""AZVWVOE"",$E($TR(X,""ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz!@#$%^&*()-_=+[]{}<>,./?:;'\|""),1,30),DA)"
     156 S X=DE(3),DIIX=2_U_DIFLD D AUDIT^DIET
     157C3S S X="" G:DG(DQ)=X C3F1 K DB
     158 S X=DG(DQ),DIC=DIE
     159 D EVENT^IVMPLOG(DA)
     160 S X=DG(DQ),DIC=DIE
     161 S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX
     162 S X=DG(DQ),DIC=DIE
     163 I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".131;" D AVAFC^VAFCDD01(DA)
     164 S X=DG(DQ),DIC=DIE
     165 D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
     166 S X=DG(DQ),DIC=DIE
     167 X "S ^DPT(""AZVWVOE"",$E($TR(X,""ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz!@#$%^&*()-_=+[]{}<>,./?:;'\|""),1,30),DA)="""""
     168 I $D(DE(3))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET
     169C3F1 Q
     170X3 K:$L(X)>20!($L(X)<4) X
     171 I $D(X),X'?.ANP K X
     172 Q
     173 ;
     1744 S DQ=5 ;@155
     1755 D:$D(DG)>9 F^DIE17,DE S DQ=5,DW=".121;9",DV="RSX",DU="",DLB="TEMPORARY ADDRESS ACTIVE?",DIFLD=.12105
     176 S DE(DW)="C5^IBXSC114",DE(DW,"INDEX")=1
     177 S DU="Y:YES;N:NO;"
     178 G RE
     179C5 G C5S:$D(DE(5))[0 K DB
     180 S X=DE(5),DIC=DIE
     181 X "S DGXRF=.12105 D ^DGDDC Q"
     182C5S S X="" G:DG(DQ)=X C5F1 K DB
     183 S X=DG(DQ),DIC=DIE
     184 ;
     185C5F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
     186 F DIXR=600 S DIEZRXR(2,DIXR)=""
     187 Q
     188X5 S DFN=DA I X="N" D TADD^DGLOCK
     189 Q
     190 ;
     1916 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 D X6 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
     192X6 S:X="N" Y="@915" S:X="Y" DIE("NO^")=""
     193 Q
     1947 D:$D(DG)>9 F^DIE17,DE S DQ=7,DW=".121;7",DV="DX",DU="",DLB="TEMPORARY ADDRESS START DATE",DIFLD=.1217
     195 S DE(DW)="C7^IBXSC114",DE(DW,"INDEX")=1
     196 G RE
     197C7 G C7S:$D(DE(7))[0 K DB
     198 D ^IBXSC115
     199C7S S X="" G:DG(DQ)=X C7F1 K DB
     200 D ^IBXSC116
     201C7F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
     202 F DIXR=600 S DIEZRXR(2,DIXR)=""
     203 Q
     204X7 S %DT="E" D ^%DT S X=Y K:Y<1 X I $D(X) S DFN=DA D TAD^DGLOCK
     205 Q
     206 ;
     2078 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
     208X8 I X']"" W !?4,*7,"But I need a Start Date for this Temporary Address." S Y=.12105
     209 Q
     2109 D:$D(DG)>9 F^DIE17 G ^IBXSC117

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC12.m

    r613 r623  
    1 IBXSC12 ; ;12/13/08
     1IBXSC12 ; ;12/27/07
    22 D DE G BEGIN
    33DE S DIE="^DPT(D0,.01,",DIC=DIE,DP=2.01,DL=3,DIEL=1,DU="" K DG,DE,DB Q:$O(^DPT(D0,.01,DA,""))=""

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC13.m

    r613 r623  
    1 IBXSC13 ; ;12/13/08
    2  S X=DG(DQ),DIC=DIE
    3  X "S DFN=DA D EN^DGMTR K DGREQF"
    4  S X=DG(DQ),DIC=DIE
    5  K DIV S DIV=X,D0=DA,DIV(0)=D0 X ^DD(2,.361,1,2,89.4) S Y(102)=$S($D(^DPT(D0,"E",D1,0)):^(0),1:"") S X=$S('$D(^DIC(8,+$P(Y(102),U,1),0)):"",1:$P(^(0),U,1)) S D0=I(0,0) S D1=I(1,0) S DIU=X K Y S X=DIV S X=DIV,X=X X ^DD(2,.361,1,2,1.4)
    6  S X=DG(DQ),DIC=DIE
     1IBXSC13 ; ;12/27/07
     2 S X=DE(12),DIC=DIE
     3 S DFN=DA D EN^DGMTCOR K DGMTCOR
     4 S X=DE(12),DIC=DIE
     5 S DFN=DA D EN^DGRP7CC
     6 S X=DE(12),DIC=DIE
    77 ;
    8  S X=DG(DQ),DIC=DIE
    9  S ^DPT("AEL",DA,+X)=""
    10  S X=DG(DQ),DIC=DIE
     8 S X=DE(12),DIC=DIE
    119 D AUTOUPD^DGENA2(DA)
    12  I $D(DE(13))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET
     10 S X=DE(12),DIC=DIE
     11 I ($T(AVAFC^VAFCDD01)'="") S VAFCF="1901;" D AVAFC^VAFCDD01(DA)
     12 S X=DE(12),DIC=DIE
     13 D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
     14 S X=DE(12),DIIX=2_U_DIFLD D AUDIT^DIET

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC14.m

    r613 r623  
    1 IBXSC14 ; ;12/13/08
    2  S X=DE(17),DIC=DIE
    3  X "S DGXRF=.111 D ^DGDDC Q"
    4  S X=DE(17),DIC=DIE
    5  S A1B2TAG="PAT" D ^A1B2XFR
    6  S X=DE(17),DIC=DIE
    7  D EVENT^IVMPLOG(DA)
    8  S X=DE(17),DIC=DIE
    9  K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR
    10  S X=DE(17),DIC=DIE
    11  S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX
    12  S X=DE(17),DIC=DIE
    13  I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".111;" D AVAFC^VAFCDD01(DA)
    14  S X=DE(17),DIC=DIE
     1IBXSC14 ; ;12/27/07
     2 S X=DG(DQ),DIC=DIE
     3 S DFN=DA D EN^DGMTCOR K DGMTCOR
     4 S X=DG(DQ),DIC=DIE
     5 S DFN=DA D EN^DGRP7CC
     6 S X=DG(DQ),DIC=DIE
     7 X ^DD(2,1901,1,3,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.3)):^(.3),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X=DIV S X="N" X ^DD(2,1901,1,3,1.4)
     8 S X=DG(DQ),DIC=DIE
     9 D AUTOUPD^DGENA2(DA)
     10 S X=DG(DQ),DIC=DIE
     11 I ($T(AVAFC^VAFCDD01)'="") S VAFCF="1901;" D AVAFC^VAFCDD01(DA)
     12 S X=DG(DQ),DIC=DIE
    1513 D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
    16  S X=DE(17),DIIX=2_U_DIFLD D AUDIT^DIET
     14 I $D(DE(12))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC15.m

    r613 r623  
    1 IBXSC15 ; ;12/13/08
    2  S X=DG(DQ),DIC=DIE
     1IBXSC15 ; ;12/27/07
     2 S X=DE(13),DIC=DIE
    33 ;
    4  S X=DG(DQ),DIC=DIE
    5  S A1B2TAG="PAT" D ^A1B2XFR
    6  S X=DG(DQ),DIC=DIE
    7  D EVENT^IVMPLOG(DA)
    8  S X=DG(DQ),DIC=DIE
    9  K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR
    10  S X=DG(DQ),DIC=DIE
    11  S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX
    12  S X=DG(DQ),DIC=DIE
    13  I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".111;" D AVAFC^VAFCDD01(DA)
    14  S X=DG(DQ),DIC=DIE
    15  D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
    16  I $D(DE(17))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET
     4 S X=DE(13),DIC=DIE
     5 K DIV S DIV=X,D0=DA,DIV(0)=D0 X ^DD(2,.361,1,2,2.2) I DIV(1)>0 S DIK(0)=DA,DIK="^DPT(DIV(0),""E"",",DA(1)=DIV(0),DA=DIV(1) D ^DIK S DA=DIK(0) K DIK
     6 S X=DE(13),DIC=DIE
     7 X "I $S('$D(^DIC(8,+X,0)):0,$P(^(0),""^"",1)[""DOM"":0,'$D(^DPT(DA,.36)):1,'$D(^DIC(8,+^(.36),0)):1,$P(^(0),""^"",1)'[""DOM"":1,1:0) S DGXRF=.361 D ^DGDDC Q"
     8 S X=DE(13),DIC=DIE
     9 K ^DPT("AEL",DA,+X)
     10 S X=DE(13),DIC=DIE
     11 D AUTOUPD^DGENA2(DA)
     12 S X=DE(13),DIIX=2_U_DIFLD D AUDIT^DIET

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC16.m

    r613 r623  
    1 IBXSC16 ; ;12/13/08
    2  D DE G BEGIN
    3 DE S DIE="^DPT(",DIC=DIE,DP=2,DL=2,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))=""
    4  I $D(^(.11)) S %Z=^(.11) S %=$P(%Z,U,2) S:%]"" DE(1)=% S %=$P(%Z,U,3) S:%]"" DE(3)=% S %=$P(%Z,U,4) S:%]"" DE(4)=% S %=$P(%Z,U,5) S:%]"" DE(5)=% S %=$P(%Z,U,7) S:%]"" DE(7)=% S %=$P(%Z,U,12) S:%]"" DE(6)=%
    5  K %Z Q
    6  ;
    7 W W !?DL+DL-2,DLB_": "
    8  Q
    9 O D W W Y W:$X>45 !?9
    10  I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2
    11  W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W "  (No Editing)" Q
    12 TR R X:DTIME E  S (DTOUT,X)=U W $C(7)
    13  Q
    14 A K DQ(DQ) S DQ=DQ+1
    15 B G @DQ
    16 RE G PR:$D(DE(DQ)) D W,TR
    17 N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A
    18 RD G QS:X?."?" I X["^" D D G ^DIE17
    19  I X="@" D D G Z^DIE2
    20  I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W "  "_X
    21 T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I  W:'$D(DB(DQ)) "  "_% G V
    22  K DDER G X
    23 P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0
    24  G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z
    25  I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X
    26 V D @("X"_DQ) K YS
    27 Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A
    28 X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17
    29  S X="?BAD"
    30 QS S DZ=X D D,QQ^DIEQ G B
    31 D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q
    32 Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N
    33 PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP
    34 R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R
    35  I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R
    36  X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=%
    37 RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17
    38 I I DV'["I",DV'["#" G RD
    39  D E^DIE0 G RD:$D(X),PR
    40  Q
    41 SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1
    42  I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1
    43  D ^DIR I 'DDER S %=Y(0),X=Y
    44  Q
    45 SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ))
    46  I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")=""
    47  E  K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")
    48  Q
    49 NKEY W:'$D(ZTQUEUED) "??  Required key field" S X="?BAD" G QS
    50 KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY")
    51 BEGIN S DNM="IBXSC16",DQ=1
    52 1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW=".11;2",DV="Fa",DU="",DLB="STREET ADDRESS [LINE 2]",DIFLD=.112
    53  S DE(DW)="C1^IBXSC16",DE(DW,"INDEX")=1
    54  G RE
    55 C1 G C1S:$D(DE(1))[0 K DB
    56  S X=DE(1),DIC=DIE
    57  X "S DGXRF=.112 D ^DGDDC Q"
    58  S X=DE(1),DIC=DIE
    59  S A1B2TAG="PAT" D ^A1B2XFR
    60  S X=DE(1),DIC=DIE
    61  D EVENT^IVMPLOG(DA)
    62  S X=DE(1),DIC=DIE
    63  K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR
    64  S X=DE(1),DIC=DIE
    65  S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX
    66  S X=DE(1),DIC=DIE
    67  I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".112;" D AVAFC^VAFCDD01(DA)
    68  S X=DE(1),DIC=DIE
    69  D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
    70  S X=DE(1),DIIX=2_U_DIFLD D AUDIT^DIET
    71 C1S S X="" G:DG(DQ)=X C1F1 K DB
     1IBXSC16 ; ;12/27/07
     2 S X=DG(DQ),DIC=DIE
     3 X "S DFN=DA D EN^DGMTR K DGREQF"
     4 S X=DG(DQ),DIC=DIE
     5 K DIV S DIV=X,D0=DA,DIV(0)=D0 X ^DD(2,.361,1,2,89.4) S Y(102)=$S($D(^DPT(D0,"E",D1,0)):^(0),1:"") S X=$S('$D(^DIC(8,+$P(Y(102),U,1),0)):"",1:$P(^(0),U,1)) S D0=I(0,0) S D1=I(1,0) S DIU=X K Y S X=DIV S X=DIV,X=X X ^DD(2,.361,1,2,1.4)
    726 S X=DG(DQ),DIC=DIE
    737 ;
    748 S X=DG(DQ),DIC=DIE
    75  S A1B2TAG="PAT" D ^A1B2XFR
     9 S ^DPT("AEL",DA,+X)=""
    7610 S X=DG(DQ),DIC=DIE
    77  D EVENT^IVMPLOG(DA)
    78  S X=DG(DQ),DIC=DIE
    79  K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR
    80  S X=DG(DQ),DIC=DIE
    81  S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX
    82  S X=DG(DQ),DIC=DIE
    83  I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".112;" D AVAFC^VAFCDD01(DA)
    84  S X=DG(DQ),DIC=DIE
    85  D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
    86  I $D(DE(1))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET
    87 C1F1 N X,X1,X2 S DIXR=232 D C1X1(U) K X2 M X2=X D C1X1("O") K X1 M X1=X
    88  D
    89  . D FC^DGFCPROT(.DA,2,.112,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q
    90  K X M X=X2 D
    91  . D FC^DGFCPROT(.DA,2,.112,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q
    92  G C1F2
    93 C1X1(DION) K X
    94  S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.112,DION),$P($G(^DPT(DA,.11)),U,2))
    95  S X=$G(X(1))
    96  Q
    97 C1F2 Q
    98 X1 K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>30!($L(X)<3) X D:$D(X) UP^DGHELP
    99  I $D(X),X'?.ANP K X
    100  Q
    101  ;
    102 2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
    103 X2 S:X="" Y=.114
    104  Q
    105 3 D:$D(DG)>9 F^DIE17,DE S DQ=3,DW=".11;3",DV="Fa",DU="",DLB="STREET ADDRESS [LINE 3]",DIFLD=.113
    106  S DE(DW)="C3^IBXSC16",DE(DW,"INDEX")=1
    107  G RE
    108 C3 G C3S:$D(DE(3))[0 K DB
    109  S X=DE(3),DIC=DIE
    110  S A1B2TAG="PAT" D ^A1B2XFR
    111  S X=DE(3),DIC=DIE
    112  D EVENT^IVMPLOG(DA)
    113  S X=DE(3),DIC=DIE
    114  K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR
    115  S X=DE(3),DIC=DIE
    116  S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX
    117  S X=DE(3),DIC=DIE
    118  I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".113;" D AVAFC^VAFCDD01(DA)
    119  S X=DE(3),DIC=DIE
    120  D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
    121  S X=DE(3),DIIX=2_U_DIFLD D AUDIT^DIET
    122 C3S S X="" G:DG(DQ)=X C3F1 K DB
    123  S X=DG(DQ),DIC=DIE
    124  S A1B2TAG="PAT" D ^A1B2XFR
    125  S X=DG(DQ),DIC=DIE
    126  D EVENT^IVMPLOG(DA)
    127  S X=DG(DQ),DIC=DIE
    128  K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR
    129  S X=DG(DQ),DIC=DIE
    130  S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX
    131  S X=DG(DQ),DIC=DIE
    132  I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".113;" D AVAFC^VAFCDD01(DA)
    133  S X=DG(DQ),DIC=DIE
    134  D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
    135  I $D(DE(3))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET
    136 C3F1 N X,X1,X2 S DIXR=233 D C3X1(U) K X2 M X2=X D C3X1("O") K X1 M X1=X
    137  D
    138  . D FC^DGFCPROT(.DA,2,.113,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q
    139  K X M X=X2 D
    140  . D FC^DGFCPROT(.DA,2,.113,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q
    141  G C3F2
    142 C3X1(DION) K X
    143  S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.113,DION),$P($G(^DPT(DA,.11)),U,3))
    144  S X=$G(X(1))
    145  Q
    146 C3F2 Q
    147 X3 K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>30!($L(X)<3) X
    148  I $D(X),X'?.ANP K X
    149  Q
    150  ;
    151 4 D:$D(DG)>9 F^DIE17,DE S DQ=4,DW=".11;4",DV="Fa",DU="",DLB="CITY",DIFLD=.114
    152  S DE(DW)="C4^IBXSC16",DE(DW,"INDEX")=1
    153  G RE
    154 C4 G C4S:$D(DE(4))[0 K DB
    155  S X=DE(4),DIC=DIE
    156  S A1B2TAG="PAT" D ^A1B2XFR
    157  S X=DE(4),DIC=DIE
    158  D EVENT^IVMPLOG(DA)
    159  S X=DE(4),DIC=DIE
    160  K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR
    161  S X=DE(4),DIC=DIE
    162  S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX
    163  S X=DE(4),DIC=DIE
    164  I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".114;" D AVAFC^VAFCDD01(DA)
    165  S X=DE(4),DIC=DIE
    166  D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
    167  S X=DE(4),DIIX=2_U_DIFLD D AUDIT^DIET
    168 C4S S X="" G:DG(DQ)=X C4F1 K DB
    169  S X=DG(DQ),DIC=DIE
    170  S A1B2TAG="PAT" D ^A1B2XFR
    171  S X=DG(DQ),DIC=DIE
    172  D EVENT^IVMPLOG(DA)
    173  S X=DG(DQ),DIC=DIE
    174  K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR
    175  S X=DG(DQ),DIC=DIE
    176  S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX
    177  S X=DG(DQ),DIC=DIE
    178  I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".114;" D AVAFC^VAFCDD01(DA)
    179  S X=DG(DQ),DIC=DIE
    180  D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
    181  I $D(DE(4))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET
    182 C4F1 N X,X1,X2 S DIXR=234 D C4X1(U) K X2 M X2=X D C4X1("O") K X1 M X1=X
    183  D
    184  . D FC^DGFCPROT(.DA,2,.114,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q
    185  K X M X=X2 D
    186  . D FC^DGFCPROT(.DA,2,.114,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q
    187  G C4F2
    188 C4X1(DION) K X
    189  S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.114,DION),$P($G(^DPT(DA,.11)),U,4))
    190  S X=$G(X(1))
    191  Q
    192 C4F2 Q
    193 X4 K:$L(X)>15!($L(X)<2) X
    194  I $D(X),X'?.ANP K X
    195  Q
    196  ;
    197 5 D:$D(DG)>9 F^DIE17,DE S DQ=5,DW=".11;5",DV="P5'a",DU="",DLB="STATE",DIFLD=.115
    198  S DE(DW)="C5^IBXSC16",DE(DW,"INDEX")=1
    199  S DU="DIC(5,"
    200  G RE
    201 C5 G C5S:$D(DE(5))[0 K DB
    202  D ^IBXSC17
    203 C5S S X="" G:DG(DQ)=X C5F1 K DB
    204  D ^IBXSC18
    205 C5F1 N X,X1,X2 S DIXR=235 D C5X1(U) K X2 M X2=X D C5X1("O") K X1 M X1=X
    206  D
    207  . D FC^DGFCPROT(.DA,2,.115,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q
    208  K X M X=X2 D
    209  . D FC^DGFCPROT(.DA,2,.115,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q
    210  G C5F2
    211 C5X1(DION) K X
    212  S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.115,DION),$P($G(^DPT(DA,.11)),U,5))
    213  S X=$G(X(1))
    214  Q
    215 C5F2 Q
    216 X5 Q
    217 6 D:$D(DG)>9 F^DIE17,DE S DQ=6,DW=".11;12",DV="FXOa",DU="",DLB="ZIP+4",DIFLD=.1112
    218  S DQ(6,2)="S Y(0)=Y D ZIPOUT^VAFADDR"
    219  S DE(DW)="C6^IBXSC16",DE(DW,"INDEX")=1
    220  G RE
    221 C6 G C6S:$D(DE(6))[0 K DB
    222  D ^IBXSC19
    223 C6S S X="" G:DG(DQ)=X C6F1 K DB
    224  D ^IBXSC110
    225 C6F1 N X,X1,X2 S DIXR=185 D C6X1(U) K X2 M X2=X D C6X1("O") K X1 M X1=X
    226  D
    227  . N DIEXARR M DIEXARR=X S DIEZCOND=1
    228  . I X1(1)'=X2(1)
    229  . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND
    230  . K EASDO2
    231  G C6F2
    232 C6X1(DION) K X
    233  S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.1112,DION),$P($G(^DPT(DA,.11)),U,12))
    234  S:('$G(EASDO2)&($D(EASZIPLK))) X=$$ZIP^DGREGDD1(DA,X(1))
    235  S:$D(X)#2 X(2)=X
    236  S X=$G(X(1))
    237  Q
    238 C6F2 S DIXR=231 D C6X2(U) K X2 M X2=X D C6X2("O") K X1 M X1=X
    239  D
    240  . D FC^DGFCPROT(.DA,2,.1112,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q
    241  K X M X=X2 D
    242  . D FC^DGFCPROT(.DA,2,.1112,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q
    243  G C6F3
    244 C6X2(DION) K X
    245  S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.1112,DION),$P($G(^DPT(DA,.11)),U,12))
    246  S X=$G(X(1))
    247  Q
    248 C6F3 Q
    249 X6 K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>20!($L(X)<5) X I $D(X) D ZIPIN^VAFADDR
    250  I $D(X),X'?.ANP K X
    251  Q
    252  ;
    253 7 D:$D(DG)>9 F^DIE17,DE S DQ=7,DW=".11;7",DV="NJ3,0XOa",DU="",DLB="COUNTY",DIFLD=.117
    254  S DQ(7,2)="S Y(0)=Y Q:Y']""""  S Z0=$S($D(^DPT(D0,.11)):+$P(^(.11),""^"",5),1:"""") Q:'Z0  S Y=$P($S($D(^DIC(5,Z0,1,Y,0)):^(0),1:""""),""^"",3)"
    255  S DE(DW)="C7^IBXSC16"
    256  G RE
    257 C7 G C7S:$D(DE(7))[0 K DB
    258  D ^IBXSC111
    259 C7S S X="" G:DG(DQ)=X C7F1 K DB
    260  D ^IBXSC112
    261 C7F1 Q
    262 X7 S Z0=$S($D(^DPT(D0,.11)):+$P(^(.11),"^",5),1:0) K:'Z0 X Q:'Z0!'$D(^DIC(5,Z0,1,0))  S DIC="^DIC(5,Z0,1,",DIC(0)="QEM" D ^DIC S X=+Y K:Y'>0 X K Z0,DIC
    263  Q
    264  ;
    265 8 D:$D(DG)>9 F^DIE17 G ^IBXSC113
     11 D AUTOUPD^DGENA2(DA)
     12 I $D(DE(13))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC17.m

    r613 r623  
    1 IBXSC17 ; ;12/13/08
    2  S X=DE(5),DIC=DIE
    3  K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:""),Y=$P(Y(1),U,7) X:$D(^DD(2,.117,2)) ^(2) S X=Y S DIU=X K Y S X=DIV S X="" X ^DD(2,.115,1,1,2.4)
    4  S X=DE(5),DIC=DIE
    5  S A1B2TAG="PAT" D ^A1B2XFR
    6  S X=DE(5),DIC=DIE
    7  D EVENT^IVMPLOG(DA)
    8  S X=DE(5),DIC=DIE
    9  K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR
    10  S X=DE(5),DIC=DIE
    11  S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX
    12  S X=DE(5),DIC=DIE
    13  I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".115;" D AVAFC^VAFCDD01(DA)
    14  S X=DE(5),DIC=DIE
    15  D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
    16  S X=DE(5),DIIX=2_U_DIFLD D AUDIT^DIET
     1IBXSC17 ; ;12/27/07
     2 D DE G BEGIN
     3DE S DIE="^DPT(",DIC=DIE,DP=2,DL=2,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))=""
     4 I $D(^(.11)) S %Z=^(.11) S %=$P(%Z,U,1) S:%]"" DE(1)=% S %=$P(%Z,U,2) S:%]"" DE(3)=% S %=$P(%Z,U,3) S:%]"" DE(5)=% S %=$P(%Z,U,4) S:%]"" DE(6)=% S %=$P(%Z,U,5) S:%]"" DE(7)=%
     5 K %Z Q
     6 ;
     7W W !?DL+DL-2,DLB_": "
     8 Q
     9O D W W Y W:$X>45 !?9
     10 I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2
     11 W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W "  (No Editing)" Q
     12TR R X:DTIME E  S (DTOUT,X)=U W $C(7)
     13 Q
     14A K DQ(DQ) S DQ=DQ+1
     15B G @DQ
     16RE G PR:$D(DE(DQ)) D W,TR
     17N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A
     18RD G QS:X?."?" I X["^" D D G ^DIE17
     19 I X="@" D D G Z^DIE2
     20 I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W "  "_X
     21T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I  W:'$D(DB(DQ)) "  "_% G V
     22 K DDER G X
     23P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0
     24 G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z
     25 I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X
     26V D @("X"_DQ) K YS
     27Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A
     28X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17
     29 S X="?BAD"
     30QS S DZ=X D D,QQ^DIEQ G B
     31D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q
     32Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N
     33PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP
     34R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R
     35 I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R
     36 X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=%
     37RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17
     38I I DV'["I",DV'["#" G RD
     39 D E^DIE0 G RD:$D(X),PR
     40 Q
     41SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1
     42 I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1
     43 D ^DIR I 'DDER S %=Y(0),X=Y
     44 Q
     45SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ))
     46 I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")=""
     47 E  K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")
     48 Q
     49NKEY W:'$D(ZTQUEUED) "??  Required key field" S X="?BAD" G QS
     50KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY")
     51BEGIN S DNM="IBXSC17",DQ=1
     521 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW=".11;1",DV="Fa",DU="",DLB="STREET ADDRESS [LINE 1]",DIFLD=.111
     53 S DE(DW)="C1^IBXSC17",DE(DW,"INDEX")=1
     54 G RE
     55C1 G C1S:$D(DE(1))[0 K DB
     56 S X=DE(1),DIC=DIE
     57 X "S DGXRF=.111 D ^DGDDC Q"
     58 S X=DE(1),DIC=DIE
     59 S A1B2TAG="PAT" D ^A1B2XFR
     60 S X=DE(1),DIC=DIE
     61 D EVENT^IVMPLOG(DA)
     62 S X=DE(1),DIC=DIE
     63 K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR
     64 S X=DE(1),DIC=DIE
     65 S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX
     66 S X=DE(1),DIC=DIE
     67 I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".111;" D AVAFC^VAFCDD01(DA)
     68 S X=DE(1),DIC=DIE
     69 D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
     70 S X=DE(1),DIIX=2_U_DIFLD D AUDIT^DIET
     71C1S S X="" G:DG(DQ)=X C1F1 K DB
     72 S X=DG(DQ),DIC=DIE
     73 ;
     74 S X=DG(DQ),DIC=DIE
     75 S A1B2TAG="PAT" D ^A1B2XFR
     76 S X=DG(DQ),DIC=DIE
     77 D EVENT^IVMPLOG(DA)
     78 S X=DG(DQ),DIC=DIE
     79 K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR
     80 S X=DG(DQ),DIC=DIE
     81 S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX
     82 S X=DG(DQ),DIC=DIE
     83 I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".111;" D AVAFC^VAFCDD01(DA)
     84 S X=DG(DQ),DIC=DIE
     85 D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
     86 I $D(DE(1))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET
     87C1F1 N X,X1,X2 S DIXR=230 D C1X1(U) K X2 M X2=X D C1X1("O") K X1 M X1=X
     88 D
     89 . D FC^DGFCPROT(.DA,2,.111,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q
     90 K X M X=X2 D
     91 . D FC^DGFCPROT(.DA,2,.111,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q
     92 G C1F2
     93C1X1(DION) K X
     94 S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.111,DION),$P($G(^DPT(DA,.11)),U,1))
     95 S X=$G(X(1))
     96 Q
     97C1F2 Q
     98X1 K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>35!($L(X)<3) X
     99 I $D(X),X'?.ANP K X
     100 Q
     101 ;
     1022 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
     103X2 S:X="" Y=.114
     104 Q
     1053 D:$D(DG)>9 F^DIE17,DE S DQ=3,DW=".11;2",DV="Fa",DU="",DLB="STREET ADDRESS [LINE 2]",DIFLD=.112
     106 S DE(DW)="C3^IBXSC17",DE(DW,"INDEX")=1
     107 G RE
     108C3 G C3S:$D(DE(3))[0 K DB
     109 S X=DE(3),DIC=DIE
     110 X "S DGXRF=.112 D ^DGDDC Q"
     111 S X=DE(3),DIC=DIE
     112 S A1B2TAG="PAT" D ^A1B2XFR
     113 S X=DE(3),DIC=DIE
     114 D EVENT^IVMPLOG(DA)
     115 S X=DE(3),DIC=DIE
     116 K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR
     117 S X=DE(3),DIC=DIE
     118 S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX
     119 S X=DE(3),DIC=DIE
     120 I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".112;" D AVAFC^VAFCDD01(DA)
     121 S X=DE(3),DIC=DIE
     122 D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
     123 S X=DE(3),DIIX=2_U_DIFLD D AUDIT^DIET
     124C3S S X="" G:DG(DQ)=X C3F1 K DB
     125 S X=DG(DQ),DIC=DIE
     126 ;
     127 S X=DG(DQ),DIC=DIE
     128 S A1B2TAG="PAT" D ^A1B2XFR
     129 S X=DG(DQ),DIC=DIE
     130 D EVENT^IVMPLOG(DA)
     131 S X=DG(DQ),DIC=DIE
     132 K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR
     133 S X=DG(DQ),DIC=DIE
     134 S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX
     135 S X=DG(DQ),DIC=DIE
     136 I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".112;" D AVAFC^VAFCDD01(DA)
     137 S X=DG(DQ),DIC=DIE
     138 D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
     139 I $D(DE(3))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET
     140C3F1 N X,X1,X2 S DIXR=232 D C3X1(U) K X2 M X2=X D C3X1("O") K X1 M X1=X
     141 D
     142 . D FC^DGFCPROT(.DA,2,.112,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q
     143 K X M X=X2 D
     144 . D FC^DGFCPROT(.DA,2,.112,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q
     145 G C3F2
     146C3X1(DION) K X
     147 S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.112,DION),$P($G(^DPT(DA,.11)),U,2))
     148 S X=$G(X(1))
     149 Q
     150C3F2 Q
     151X3 K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>30!($L(X)<3) X D:$D(X) UP^DGHELP
     152 I $D(X),X'?.ANP K X
     153 Q
     154 ;
     1554 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
     156X4 S:X="" Y=.114
     157 Q
     1585 D:$D(DG)>9 F^DIE17,DE S DQ=5,DW=".11;3",DV="Fa",DU="",DLB="STREET ADDRESS [LINE 3]",DIFLD=.113
     159 S DE(DW)="C5^IBXSC17",DE(DW,"INDEX")=1
     160 G RE
     161C5 G C5S:$D(DE(5))[0 K DB
     162 D ^IBXSC18
     163C5S S X="" G:DG(DQ)=X C5F1 K DB
     164 D ^IBXSC19
     165C5F1 N X,X1,X2 S DIXR=233 D C5X1(U) K X2 M X2=X D C5X1("O") K X1 M X1=X
     166 D
     167 . D FC^DGFCPROT(.DA,2,.113,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q
     168 K X M X=X2 D
     169 . D FC^DGFCPROT(.DA,2,.113,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q
     170 G C5F2
     171C5X1(DION) K X
     172 S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.113,DION),$P($G(^DPT(DA,.11)),U,3))
     173 S X=$G(X(1))
     174 Q
     175C5F2 Q
     176X5 K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>30!($L(X)<3) X
     177 I $D(X),X'?.ANP K X
     178 Q
     179 ;
     1806 D:$D(DG)>9 F^DIE17,DE S DQ=6,DW=".11;4",DV="Fa",DU="",DLB="CITY",DIFLD=.114
     181 S DE(DW)="C6^IBXSC17",DE(DW,"INDEX")=1
     182 G RE
     183C6 G C6S:$D(DE(6))[0 K DB
     184 D ^IBXSC110
     185C6S S X="" G:DG(DQ)=X C6F1 K DB
     186 D ^IBXSC111
     187C6F1 N X,X1,X2 S DIXR=234 D C6X1(U) K X2 M X2=X D C6X1("O") K X1 M X1=X
     188 D
     189 . D FC^DGFCPROT(.DA,2,.114,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q
     190 K X M X=X2 D
     191 . D FC^DGFCPROT(.DA,2,.114,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q
     192 G C6F2
     193C6X1(DION) K X
     194 S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.114,DION),$P($G(^DPT(DA,.11)),U,4))
     195 S X=$G(X(1))
     196 Q
     197C6F2 Q
     198X6 K:$L(X)>15!($L(X)<2) X
     199 I $D(X),X'?.ANP K X
     200 Q
     201 ;
     2027 D:$D(DG)>9 F^DIE17,DE S DQ=7,DW=".11;5",DV="P5'a",DU="",DLB="STATE",DIFLD=.115
     203 S DE(DW)="C7^IBXSC17",DE(DW,"INDEX")=1
     204 S DU="DIC(5,"
     205 G RE
     206C7 G C7S:$D(DE(7))[0 K DB
     207 D ^IBXSC112
     208C7S S X="" G:DG(DQ)=X C7F1 K DB
     209 D ^IBXSC113
     210C7F1 N X,X1,X2 S DIXR=235 D C7X1(U) K X2 M X2=X D C7X1("O") K X1 M X1=X
     211 D
     212 . D FC^DGFCPROT(.DA,2,.115,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q
     213 K X M X=X2 D
     214 . D FC^DGFCPROT(.DA,2,.115,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q
     215 G C7F2
     216C7X1(DION) K X
     217 S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.115,DION),$P($G(^DPT(DA,.11)),U,5))
     218 S X=$G(X(1))
     219 Q
     220C7F2 Q
     221X7 Q
     2228 D:$D(DG)>9 F^DIE17 G ^IBXSC114

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC18.m

    r613 r623  
    1 IBXSC18 ; ;12/13/08
    2  S X=DG(DQ),DIC=DIE
    3  ;
    4  S X=DG(DQ),DIC=DIE
     1IBXSC18 ; ;12/27/07
     2 S X=DE(5),DIC=DIE
    53 S A1B2TAG="PAT" D ^A1B2XFR
    6  S X=DG(DQ),DIC=DIE
     4 S X=DE(5),DIC=DIE
    75 D EVENT^IVMPLOG(DA)
    8  S X=DG(DQ),DIC=DIE
     6 S X=DE(5),DIC=DIE
    97 K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR
    10  S X=DG(DQ),DIC=DIE
     8 S X=DE(5),DIC=DIE
    119 S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX
    12  S X=DG(DQ),DIC=DIE
    13  I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".115;" D AVAFC^VAFCDD01(DA)
    14  S X=DG(DQ),DIC=DIE
     10 S X=DE(5),DIC=DIE
     11 I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".113;" D AVAFC^VAFCDD01(DA)
     12 S X=DE(5),DIC=DIE
    1513 D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
    16  I $D(DE(5))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET
     14 S X=DE(5),DIIX=2_U_DIFLD D AUDIT^DIET

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC19.m

    r613 r623  
    1 IBXSC19 ; ;12/13/08
    2  S X=DE(6),DIC=DIE
    3  D KILL^DGREGDD1(DA,.116,.11,6,$E(X,1,5))
    4  S X=DE(6),DIC=DIE
     1IBXSC19 ; ;12/27/07
     2 S X=DG(DQ),DIC=DIE
     3 S A1B2TAG="PAT" D ^A1B2XFR
     4 S X=DG(DQ),DIC=DIE
    55 D EVENT^IVMPLOG(DA)
    6  S X=DE(6),DIC=DIE
     6 S X=DG(DQ),DIC=DIE
    77 K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR
    8  S X=DE(6),DIC=DIE
     8 S X=DG(DQ),DIC=DIE
    99 S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX
    10  S X=DE(6),DIC=DIE
    11  I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".1112;" D AVAFC^VAFCDD01(DA)
    12  S X=DE(6),DIC=DIE
     10 S X=DG(DQ),DIC=DIE
     11 I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".113;" D AVAFC^VAFCDD01(DA)
     12 S X=DG(DQ),DIC=DIE
    1313 D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
    14  S X=DE(6),DIIX=2_U_DIFLD D AUDIT^DIET
     14 I $D(DE(5))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC3.m

    r613 r623  
    1 IBXSC3 ; GENERATED FROM 'IB SCREEN3' INPUT TEMPLATE(#574), FILE 399;12/13/08
     1IBXSC3 ; GENERATED FROM 'IB SCREEN3' INPUT TEMPLATE(#574), FILE 399;12/27/07
    22 D DE G BEGIN
    33DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGCR(399,DA,""))=""

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC31.m

    r613 r623  
    1 IBXSC31 ; ;12/13/08
     1IBXSC31 ; ;12/27/07
    22 S X=DE(22),DIC=DIE
    33 K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M")):^("M"),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X="" X ^DD(399,112,1,1,2.4)

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC32.m

    r613 r623  
    1 IBXSC32 ; ;12/13/08
     1IBXSC32 ; ;12/27/07
    22 S X=DG(DQ),DIC=DIE
    33 K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M")):^("M"),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y X ^DD(399,112,1,1,1.1) X ^DD(399,112,1,1,1.4)

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC33.m

    r613 r623  
    1 IBXSC33 ; ;12/13/08
     1IBXSC33 ; ;12/27/07
    22 D DE G BEGIN
    33DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGCR(399,DA,""))=""
    … …  
    155155X14 I '$$SUPPPT^IBCEP7B(DA,1) S Y="@3212"
    156156 Q
    157 15 D:$D(DG)>9 F^DIE17,DE S DQ=15,DW="M1;2",DV="FX",DU="",DLB="PRIMARY PROVIDER #",DIFLD=122
     15715 D:$D(DG)>9 F^DIE17,DE S DQ=15,DW="M1;2",DV="F",DU="",DLB="PRIMARY PROVIDER #",DIFLD=122
    158158 S DE(DW)="C15^IBXSC33"
    159159 S Y="@"
    … …  
    166166 ;
    167167C15F1 Q
    168 X15 K:$L(X)>13!($L(X)<3)!($TR(X," ")="") X
     168X15 K:$L(X)>13!($L(X)<3) X
    169169 I $D(X),X'?.ANP K X
    170170 Q

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC34.m

    r613 r623  
    1 IBXSC34 ; ;12/13/08
     1IBXSC34 ; ;12/27/07
    22 S X=DG(DQ),DIC=DIE
    33 K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"MP")):^("MP"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=$$BPP^IBCNS2(DA) X ^DD(399,.21,1,1,1.4)

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC35.m

    r613 r623  
    1 IBXSC35 ; ;12/13/08
     1IBXSC35 ; ;12/27/07
    22 S X=DE(15),DIC=DIE
    33 K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,2)="" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,10),X=X S DIU=X K Y S X="" X ^DD(399,122,1,1,2.4)

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC36.m

    r613 r623  
    1 IBXSC36 ; ;12/13/08
     1IBXSC36 ; ;12/27/07
    22 D DE G BEGIN
    33DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGCR(399,DA,""))=""
    … …  
    5050KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY")
    5151BEGIN S DNM="IBXSC36",DQ=1
    52 1 S DW="M1;2",DV="FX",DU="",DLB="PRIMARY PROVIDER #",DIFLD=122
     521 S DW="M1;2",DV="F",DU="",DLB="PRIMARY PROVIDER #",DIFLD=122
    5353 S DE(DW)="C1^IBXSC36"
    5454 S Y="@"
    … …  
    6262 ;
    6363C1F1 Q
    64 X1 K:$L(X)>13!($L(X)<3)!($TR(X," ")="") X
     64X1 K:$L(X)>13!($L(X)<3) X
    6565 I $D(X),X'?.ANP K X
    6666 Q
    … …  
    8282 Q
    83836 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 G A
    84 7 S DW="M1;2",DV="FX",DU="",DLB="PRIMARY PROVIDER #",DIFLD=122
     847 S DW="M1;2",DV="F",DU="",DLB="PRIMARY PROVIDER #",DIFLD=122
    8585 S DE(DW)="C7^IBXSC36"
    8686 S X="IBPSID" Q:X  Q:$NA(@X)[U  S X=$G(@X)
    … …  
    9494 ;
    9595C7F1 Q
    96 X7 K:$L(X)>13!($L(X)<3)!($TR(X," ")="") X
     96X7 K:$L(X)>13!($L(X)<3) X
    9797 I $D(X),X'?.ANP K X
    9898 Q
    … …  
    132132X18 I '$$SUPPPT^IBCEP7B(DA,2) S Y="@3222"
    133133 Q
    134 19 S DW="M1;3",DV="FX",DU="",DLB="SECONDARY PROVIDER #",DIFLD=123
     13419 S DW="M1;3",DV="F",DU="",DLB="SECONDARY PROVIDER #",DIFLD=123
    135135 S DE(DW)="C19^IBXSC36"
    136136 S Y="@"
    … …  
    144144 ;
    145145C19F1 Q
    146 X19 K:$L(X)>13!($L(X)<3)!($TR(X," ")="") X
     146X19 K:$L(X)>13!($L(X)<3) X
    147147 I $D(X),X'?.ANP K X
    148148 Q

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC37.m

    r613 r623  
    1 IBXSC37 ; ;12/13/08
     1IBXSC37 ; ;12/27/07
    22 D DE G BEGIN
    33DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGCR(399,DA,""))=""
    … …  
    5050KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY")
    5151BEGIN S DNM="IBXSC37",DQ=1
    52 1 S DW="M1;3",DV="FX",DU="",DLB="SECONDARY PROVIDER #",DIFLD=123
     521 S DW="M1;3",DV="F",DU="",DLB="SECONDARY PROVIDER #",DIFLD=123
    5353 S DE(DW)="C1^IBXSC37"
    5454 S Y="@"
    … …  
    6262 ;
    6363C1F1 Q
    64 X1 K:$L(X)>13!($L(X)<3)!($TR(X," ")="") X
     64X1 K:$L(X)>13!($L(X)<3) X
    6565 I $D(X),X'?.ANP K X
    6666 Q
    … …  
    8282 Q
    83836 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 G A
    84 7 S DW="M1;3",DV="FX",DU="",DLB="SECONDARY PROVIDER #",DIFLD=123
     847 S DW="M1;3",DV="F",DU="",DLB="SECONDARY PROVIDER #",DIFLD=123
    8585 S DE(DW)="C7^IBXSC37"
    8686 S X="IBPSID" Q:X  Q:$NA(@X)[U  S X=$G(@X)
    … …  
    9494 ;
    9595C7F1 Q
    96 X7 K:$L(X)>13!($L(X)<3)!($TR(X," ")="") X
     96X7 K:$L(X)>13!($L(X)<3) X
    9797 I $D(X),X'?.ANP K X
    9898 Q
    … …  
    132132X18 I '$$SUPPPT^IBCEP7B(DA,3) S Y="@3232"
    133133 Q
    134 19 S DW="M1;4",DV="FX",DU="",DLB="TERTIARY PROVIDER #",DIFLD=124
     13419 S DW="M1;4",DV="F",DU="",DLB="TERTIARY PROVIDER #",DIFLD=124
    135135 S DE(DW)="C19^IBXSC37"
    136136 S Y="@"
    … …  
    144144 ;
    145145C19F1 Q
    146 X19 K:$L(X)>13!($L(X)<3)!($TR(X," ")="") X
     146X19 K:$L(X)>13!($L(X)<3) X
    147147 I $D(X),X'?.ANP K X
    148148 Q

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC38.m

    r613 r623  
    1 IBXSC38 ; ;12/13/08
     1IBXSC38 ; ;12/27/07
    22 D DE G BEGIN
    33DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGCR(399,DA,""))=""
    … …  
    5151KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY")
    5252BEGIN S DNM="IBXSC38",DQ=1
    53 1 S DW="M1;4",DV="FX",DU="",DLB="TERTIARY PROVIDER #",DIFLD=124
     531 S DW="M1;4",DV="F",DU="",DLB="TERTIARY PROVIDER #",DIFLD=124
    5454 S DE(DW)="C1^IBXSC38"
    5555 S Y="@"
    … …  
    6363 ;
    6464C1F1 Q
    65 X1 K:$L(X)>13!($L(X)<3)!($TR(X," ")="") X
     65X1 K:$L(X)>13!($L(X)<3) X
    6666 I $D(X),X'?.ANP K X
    6767 Q
    … …  
    8383 Q
    84846 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 G A
    85 7 S DW="M1;4",DV="FX",DU="",DLB="TERTIARY PROVIDER #",DIFLD=124
     857 S DW="M1;4",DV="F",DU="",DLB="TERTIARY PROVIDER #",DIFLD=124
    8686 S DE(DW)="C7^IBXSC38"
    8787 S X="IBPSID" Q:X  Q:$NA(@X)[U  S X=$G(@X)
    … …  
    9595 ;
    9696C7F1 Q
    97 X7 K:$L(X)>13!($L(X)<3)!($TR(X," ")="") X
     97X7 K:$L(X)>13!($L(X)<3) X
    9898 I $D(X),X'?.ANP K X
    9999 Q

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC39.m

    r613 r623  
    1 IBXSC39 ; ;12/13/08
     1IBXSC39 ; ;12/27/07
    22 ;;
    331 N X,X1,X2 S DIXR=139 D X1(U) K X2 M X2=X D X1("F") K X1 M X1=X

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC4.m

    r613 r623  
    1 IBXSC4 ; GENERATED FROM 'IB SCREEN4' INPUT TEMPLATE(#510), FILE 399;12/13/08
     1IBXSC4 ; GENERATED FROM 'IB SCREEN4' INPUT TEMPLATE(#510), FILE 399;12/27/07
    22 D DE G BEGIN
    33DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGCR(399,DA,""))=""
    … …  
    164164 Q
    16516530 S D=0 K DE(1) ;47
    166  S DIFLD=47,DGO="^IBXSC44",DC="2^399.047PA^CV^",DV="399.047M*P399.1'X",DW="0;1",DOW="VALUE CODE",DLB="Select "_DOW S:D DC=DC_D
     166 S DIFLD=47,DGO="^IBXSC44",DC="2^399.047PA^CV^",DV="399.047M*P399.1'",DW="0;1",DOW="VALUE CODE",DLB="Select "_DOW S:D DC=DC_D
    167167 S DU="DGCR(399.1,"
    168168 G RE:D I $D(DSC(399.047))#2,$P(DSC(399.047),"I $D(^UTILITY(",1)="" X DSC(399.047) S D=$O(^(0)) S:D="" D=-1 G M30

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC41.m

    r613 r623  
    1 IBXSC41 ; ;12/13/08
     1IBXSC41 ; ;12/27/07
    22 D DE G BEGIN
    33DE S DIE="^DGCR(399,D0,""OT"",",DIC=DIE,DP=399.048,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGCR(399,D0,"OT",DA,""))=""

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC42.m

    r613 r623  
    1 IBXSC42 ; ;12/13/08
     1IBXSC42 ; ;12/27/07
    22 D DE G BEGIN
    33DE S DIE="^DGCR(399,D0,""OC"",",DIC=DIE,DP=399.041,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGCR(399,D0,"OC",DA,""))=""
    … …  
    8383X7 I '$P(^DGCR(399.1,+^DGCR(399,DA(1),"OC",DA,0),0),U,10) S Y="@455"
    8484 Q
    85 8 S DW="0;4",DV="RDX",DU="",DLB="END DATE",DIFLD=.04
     858 S DW="0;4",DV="D",DU="",DLB="END DATE",DIFLD=.04
    8686 G RE
    87 X8 S %DT="EX" D ^%DT S X=Y K:X<1 X I $D(X),X<$P($G(^DGCR(399,DA(1),"OC",DA,0)),U,2) K X
     87X8 S %DT="EX" D ^%DT S X=Y K:Y<1 X
    8888 Q
    8989 ;

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC43.m

    r613 r623  
    1 IBXSC43 ; ;12/13/08
     1IBXSC43 ; ;12/27/07
    22 D DE G BEGIN
    33DE S DIE="^DGCR(399,D0,""CC"",",DIC=DIE,DP=399.04,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGCR(399,D0,"CC",DA,""))=""

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC44.m

    r613 r623  
    1 IBXSC44 ; ;12/13/08
     1IBXSC44 ; ;12/27/07
    22 D DE G BEGIN
    33DE S DIE="^DGCR(399,D0,""CV"",",DIC=DIE,DP=399.047,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGCR(399,D0,"CV",DA,""))=""
    … …  
    5050KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY")
    5151BEGIN S DNM="IBXSC44",DQ=1+D G B
    52 1 S DW="0;1",DV="M*P399.1'X",DU="",DLB="VALUE CODE",DIFLD=.01
    53  S DE(DW)="C1^IBXSC44",DE(DW,"INDEX")=1
     521 S DW="0;1",DV="M*P399.1'",DU="",DLB="VALUE CODE",DIFLD=.01
     53 S DE(DW)="C1^IBXSC44"
    5454 S DU="DGCR(399.1,"
    5555 G RE:'D S DQ=2 G 2
    … …  
    6060 S X=DG(DQ),DIC=DIE
    6161 S ^DGCR(399,DA(1),"CV","B",$E(X,1,30),DA)=""
    62 C1F1 N X,X1,X2 S DIXR=215 D C1X1(U) K X2 M X2=X D C1X1("O") K X1 M X1=X
    63  K X M X=X2 D
    64  . N DIEXARR M DIEXARR=X S DIEZCOND=1
    65  . S X=$$COND^IBCVC(.DA,X1(1),X2(1))
    66  . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND
    67  . D REMOVE^IBCVC(.DA)
    68  G C1F2
    69 C1X1(DION) K X
    70  S X(1)=$G(@DIEZTMP@("V",399.047,DIIENS,.01,DION),$P($G(^DGCR(399,DA(1),"CV",DA,0)),U,1))
    71  S X=$G(X(1))
    72  Q
    73 C1F2 Q
    74 X1 S DIC("S")="I +$P($G(^DGCR(399.1,+Y,0)),U,11),$$ALLOWVC^IBCVC(DA(1),+Y)" D ^DIC K DIC S DIC=$G(DIE),X=+Y K:Y<0 X
     62C1F1 Q
     63X1 S DIC("S")="I +$P($G(^DGCR(399.1,+Y,0)),U,11)" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X
    7564 Q
    7665 ;
    77 2 D:$D(DG)>9 F^DIE17,DE S DQ=2,DW="0;2",DV="FX",DU="",DLB="VALUE",DIFLD=.02
     662 D:$D(DG)>9 F^DIE17,DE S DQ=2,DW="0;2",DV="F",DU="",DLB="VALUE",DIFLD=.02
    7867 G RE
    79 X2 K:$L(X)>10!($L(X)<1)!'$$FORMCHK^IBCVC(X,.DA) X
     68X2 K:$L(X)>9!($L(X)<1) X
    8069 I $D(X),X'?.ANP K X
    8170 Q

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC5.m

    r613 r623  
    1 IBXSC5 ; GENERATED FROM 'IB SCREEN5' INPUT TEMPLATE(#511), FILE 399;12/13/08
     1IBXSC5 ; GENERATED FROM 'IB SCREEN5' INPUT TEMPLATE(#511), FILE 399;04/07/05
    22 D DE G BEGIN
    33DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGCR(399,DA,""))=""
    … …  
    155155 Q
    15615627 S D=0 K DE(1) ;47
    157  S DIFLD=47,DGO="^IBXSC54",DC="2^399.047PA^CV^",DV="399.047M*P399.1'X",DW="0;1",DOW="VALUE CODE",DLB="Select "_DOW S:D DC=DC_D
     157 S DIFLD=47,DGO="^IBXSC54",DC="2^399.047PA^CV^",DV="399.047M*P399.1'",DW="0;1",DOW="VALUE CODE",DLB="Select "_DOW S:D DC=DC_D
    158158 S DU="DGCR(399.1,"
    159159 G RE:D I $D(DSC(399.047))#2,$P(DSC(399.047),"I $D(^UTILITY(",1)="" X DSC(399.047) S D=$O(^(0)) S:D="" D=-1 G M27

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC51.m

    r613 r623  
    1 IBXSC51 ; ;12/13/08
     1IBXSC51 ; ;04/07/05
    22 D DE G BEGIN
    33DE S DIE="^DGCR(399,D0,""OP"",",DIC=DIE,DP=399.043,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGCR(399,D0,"OP",DA,""))=""

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC52.m

    r613 r623  
    1 IBXSC52 ; ;12/13/08
     1IBXSC52 ; ;04/07/05
    22 D DE G BEGIN
    33DE S DIE="^DGCR(399,D0,""OC"",",DIC=DIE,DP=399.041,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGCR(399,D0,"OC",DA,""))=""
    … …  
    8383X7 I '$P(^DGCR(399.1,+^DGCR(399,DA(1),"OC",DA,0),0),U,10) S Y="@555"
    8484 Q
    85 8 S DW="0;4",DV="RDX",DU="",DLB="END DATE",DIFLD=.04
     858 S DW="0;4",DV="D",DU="",DLB="END DATE",DIFLD=.04
    8686 G RE
    87 X8 S %DT="EX" D ^%DT S X=Y K:X<1 X I $D(X),X<$P($G(^DGCR(399,DA(1),"OC",DA,0)),U,2) K X
     87X8 S %DT="EX" D ^%DT S X=Y K:Y<1 X
    8888 Q
    8989 ;

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC53.m

    r613 r623  
    1 IBXSC53 ; ;12/13/08
     1IBXSC53 ; ;04/07/05
    22 D DE G BEGIN
    33DE S DIE="^DGCR(399,D0,""CC"",",DIC=DIE,DP=399.04,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGCR(399,D0,"CC",DA,""))=""

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC54.m

    r613 r623  
    1 IBXSC54 ; ;12/13/08
     1IBXSC54 ; ;04/07/05
    22 D DE G BEGIN
    33DE S DIE="^DGCR(399,D0,""CV"",",DIC=DIE,DP=399.047,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGCR(399,D0,"CV",DA,""))=""
    … …  
    5050KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY")
    5151BEGIN S DNM="IBXSC54",DQ=1+D G B
    52 1 S DW="0;1",DV="M*P399.1'X",DU="",DLB="VALUE CODE",DIFLD=.01
    53  S DE(DW)="C1^IBXSC54",DE(DW,"INDEX")=1
     521 S DW="0;1",DV="M*P399.1'",DU="",DLB="VALUE CODE",DIFLD=.01
     53 S DE(DW)="C1^IBXSC54"
    5454 S DU="DGCR(399.1,"
    5555 G RE:'D S DQ=2 G 2
    … …  
    6060 S X=DG(DQ),DIC=DIE
    6161 S ^DGCR(399,DA(1),"CV","B",$E(X,1,30),DA)=""
    62 C1F1 N X,X1,X2 S DIXR=215 D C1X1(U) K X2 M X2=X D C1X1("O") K X1 M X1=X
    63  K X M X=X2 D
    64  . N DIEXARR M DIEXARR=X S DIEZCOND=1
    65  . S X=$$COND^IBCVC(.DA,X1(1),X2(1))
    66  . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND
    67  . D REMOVE^IBCVC(.DA)
    68  G C1F2
    69 C1X1(DION) K X
    70  S X(1)=$G(@DIEZTMP@("V",399.047,DIIENS,.01,DION),$P($G(^DGCR(399,DA(1),"CV",DA,0)),U,1))
    71  S X=$G(X(1))
    72  Q
    73 C1F2 Q
    74 X1 S DIC("S")="I +$P($G(^DGCR(399.1,+Y,0)),U,11),$$ALLOWVC^IBCVC(DA(1),+Y)" D ^DIC K DIC S DIC=$G(DIE),X=+Y K:Y<0 X
     62C1F1 Q
     63X1 S DIC("S")="I +$P($G(^DGCR(399.1,+Y,0)),U,11)" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X
    7564 Q
    7665 ;
    77 2 D:$D(DG)>9 F^DIE17,DE S DQ=2,DW="0;2",DV="FX",DU="",DLB="VALUE",DIFLD=.02
     662 D:$D(DG)>9 F^DIE17,DE S DQ=2,DW="0;2",DV="F",DU="",DLB="VALUE",DIFLD=.02
    7867 G RE
    79 X2 K:$L(X)>10!($L(X)<1)!'$$FORMCHK^IBCVC(X,.DA) X
     68X2 K:$L(X)>9!($L(X)<1) X
    8069 I $D(X),X'?.ANP K X
    8170 Q

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC6.m

    r613 r623  
    1 IBXSC6 ; GENERATED FROM 'IB SCREEN6' INPUT TEMPLATE(#512), FILE 399;12/13/08
     1IBXSC6 ; GENERATED FROM 'IB SCREEN6' INPUT TEMPLATE(#512), FILE 399;12/27/07
    22 D DE G BEGIN
    33DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGCR(399,DA,""))=""

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC61.m

    r613 r623  
    1 IBXSC61 ; ;12/13/08
     1IBXSC61 ; ;12/27/07
    22 S X=DG(DQ),DIC=DIE
    33 K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=$$PRVNUM^IBCU(DA,"",1) X ^DD(399,.22,1,1,1.4)

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC610.m

    r613 r623  
    1 IBXSC610 ; ;12/13/08
     1IBXSC610 ; ;12/27/07
    22 S X=DE(22),DIC=DIE
    33 K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIU-X X ^DD(399,220,1,1,2.4)

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC611.m

    r613 r623  
    1 IBXSC611 ; ;12/13/08
     1IBXSC611 ; ;12/27/07
    22 S X=DG(DQ),DIC=DIE
    33 K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIU+DIV X ^DD(399,220,1,1,1.4)

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC612.m

    r613 r623  
    1 IBXSC612 ; ;12/13/08
     1IBXSC612 ; ;12/27/07
    22 S X=DE(12),DIC=DIE
    33 K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA,DIV(1)=D1 S Y(1)=$S($D(^DGCR(399,D0,"RC",D1,0)):^(0),1:"") S X=$P(Y(1),U,11),X=X S DIU=X K Y S X="" X ^DD(399.042,.1,1,1,2.4)

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC62.m

    r613 r623  
    1 IBXSC62 ; ;12/13/08
     1IBXSC62 ; ;12/27/07
    22 D DE G BEGIN
    33DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGCR(399,DA,""))=""

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC63.m

    r613 r623  
    1 IBXSC63 ; ;12/13/08
     1IBXSC63 ; ;12/27/07
    22 S X=DG(DQ),DIC=DIE
    33 K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I $P(^DGCR(399,DA,0),U,5)<3 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X=DIV S X=$$LOS1^IBCU64(DA) X ^DD(399,151,1,1,1.4)

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC64.m

    r613 r623  
    1 IBXSC64 ; ;12/13/08
     1IBXSC64 ; ;12/27/07
    22 S X=DG(DQ),DIC=DIE
    33 K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I $P(^DGCR(399,DA,0),U,5)<3 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X=DIV S X=$$LOS1^IBCU64(DA) X ^DD(399,152,1,1,1.4)

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC65.m

    r613 r623  
    1 IBXSC65 ; ;12/13/08
     1IBXSC65 ; ;12/27/07
    22 S X=DE(23),DIC=DIE
    33 ;

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC66.m

    r613 r623  
    1 IBXSC66 ; ;12/13/08
     1IBXSC66 ; ;12/27/07
    22 S X=DG(DQ),DIC=DIE
    33 X ^DD(399,161,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y S X=DIV D DIS^IBCU S X=X S DIH=$G(^DGCR(399,DIV(0),"U")),DIV=X S $P(^("U"),U,12)=DIV,DIH=399,DIG=162 D ^DICR

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC67.m

    r613 r623  
    1 IBXSC67 ; ;12/13/08
     1IBXSC67 ; ;12/27/07
    22 D DE G BEGIN
    33DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGCR(399,DA,""))=""

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC68.m

    r613 r623  
    1 IBXSC68 ; ;12/13/08
     1IBXSC68 ; ;12/27/07
    22 D DE G BEGIN
    33DE S DIE="^DGCR(399,D0,""RC"",",DIC=DIE,DP=399.042,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGCR(399,D0,"RC",DA,""))=""

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC69.m

    r613 r623  
    1 IBXSC69 ; ;12/13/08
     1IBXSC69 ; ;12/27/07
    22 S X=DG(DQ),DIC=DIE
    33 K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIU+DIV X ^DD(399,219,1,1,1.4)

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC7.m

    r613 r623  
    1 IBXSC7 ; GENERATED FROM 'IB SCREEN7' INPUT TEMPLATE(#513), FILE 399;01/03/09
     1IBXSC7 ; GENERATED FROM 'IB SCREEN7' INPUT TEMPLATE(#513), FILE 399;12/27/07
    22 D DE G BEGIN
    33DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGCR(399,DA,""))=""
    4  I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,19) S:%]"" DE(29)=% S %=$P(%Z,U,22) S:%]"" DE(21)=% S %=$P(%Z,U,24) S:%]"" DE(11)=% S %=$P(%Z,U,25) S:%]"" DE(13)=% S %=$P(%Z,U,26) S:%]"" DE(17)=% S %=$P(%Z,U,27) S:%]"" DE(24)=%
     4 I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,22) S:%]"" DE(21)=% S %=$P(%Z,U,24) S:%]"" DE(11)=% S %=$P(%Z,U,25) S:%]"" DE(13)=% S %=$P(%Z,U,26) S:%]"" DE(17)=% S %=$P(%Z,U,27) S:%]"" DE(24)=%
    55 I $D(^("U")) S %Z=^("U") S %=$P(%Z,U,12) S:%]"" DE(20)=%
    66 I $D(^("U2")) S %Z=^("U2") S %=$P(%Z,U,2) S:%]"" DE(18)=% S %=$P(%Z,U,3) S:%]"" DE(19)=%
    … …  
    181181 G RE
    182182C24 G C24S:$D(DE(24))[0 K DB
    183  S X=DE(24),DIC=DIE
    184  ;
     183 D ^IBXSC73
    185184C24S S X="" G:DG(DQ)=X C24F1 K DB
    186  S X=DG(DQ),DIC=DIE
    187  K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,19),X=X S DIU=X K Y S X=DIV S X=$$FT^IBCU3(DA,1) X ^DD(399,.27,1,1,1.4)
     185 D ^IBXSC74
    188186C24F1 Q
    189187X24 Q
    … …  
    198196 Q
    19919728 S DQ=29 ;@714
    200 29 D:$D(DG)>9 F^DIE17,DE S DQ=29,DW="0;19",DV="R*P353'",DU="",DLB="FORM TYPE",DIFLD=.19
    201  S DE(DW)="C29^IBXSC7"
    202  S DU="IBE(353,"
    203  G RE
    204 C29 G C29S:$D(DE(29))[0 K DB
    205  S X=DE(29),DIC=DIE
    206  ;
    207  S X=DE(29),DIC=DIE
    208  S DGRVRCAL=2
    209  S X=DE(29),DIC=DIE
    210  D ALLID^IBCEP3(DA,.19,2)
    211  S X=DE(29),DIC=DIE
    212  ;
    213  S X=DE(29),DIC=DIE
    214  D ATTREND^IBCU1(DA,"","")
    215 C29S S X="" G:DG(DQ)=X C29F1 K DB
    216  D ^IBXSC73
    217 C29F1 Q
    218 X29 S DIC("S")="N Z S Z=$G(^IBE(353,Y,2)) I $P(Z,U,2)=""P"",$P(Z,U,4)" D ^DIC K DIC S DIC=$G(DIE),X=+Y K:Y<0 X
    219  Q
    220  ;
    221 30 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=30 D X30 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
    222 X30 S DIPA("FT")=$P($G(^DGCR(399,DA,0)),U,19)
    223  Q
    224 31 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=31 D X31 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
    225 X31 I $P($G(^IBE(353,+DIPA("FT"),2)),U,2)="P",$P($G(^(2)),U,4) S DIPA("FT1")=DIPA("FT") D CKFT^IBCIUT1(IBIFN) S Y="@715"
    226  Q
    227 32 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=32 D X32 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
    228 X32 W !,*7,"Must be a printable national form type"
    229  Q
    230 33 D:$D(DG)>9 F^DIE17 G ^IBXSC74
     19829 D:$D(DG)>9 F^DIE17 G ^IBXSC75

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC71.m

    r613 r623  
    1 IBXSC71 ; ;01/03/09
     1IBXSC71 ; ;12/27/07
    22 D DE G BEGIN
    33DE S DIE="^DGCR(399,D0,""OP"",",DIC=DIE,DP=399.043,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGCR(399,D0,"OP",DA,""))=""

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC710.m

    r613 r623  
    1 IBXSC710 ; ;12/13/08
     1IBXSC710 ; ;12/27/07
    22 S X=DG(DQ),DIC=DIE
    33 K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIU+DIV X ^DD(399,220,1,1,1.4)

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC711.m

    r613 r623  
    1 IBXSC711 ; ;12/13/08
     1IBXSC711 ; ;12/27/07
    22 S X=DE(11),DIC=DIE
    33 K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA,DIV(1)=D1 S Y(1)=$S($D(^DGCR(399,D0,"RC",D1,0)):^(0),1:"") S X=$P(Y(1),U,11),X=X S DIU=X K Y S X="" X ^DD(399.042,.1,1,1,2.4)

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC712.m

    r613 r623  
    1 IBXSC712 ; ;12/13/08
     1IBXSC712 ; ;12/27/07
    22 D DE G BEGIN
    33DE S DIE="^DGCR(399,D0,""RC"",",DIC=DIE,DP=399.042,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGCR(399,D0,"RC",DA,""))=""

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC72.m

    r613 r623  
    1 IBXSC72 ; ;01/03/09
     1IBXSC72 ; ;12/27/07
    22 S X=DG(DQ),DIC=DIE
    33 K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=$$PRVNUM^IBCU(DA,"",1) X ^DD(399,.22,1,1,1.4)

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC73.m

    r613 r623  
    1 IBXSC73 ; ;01/03/09
    2  S X=DG(DQ),DIC=DIE
    3  X ^DD(399,.19,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,9),X=X S DIU=X K Y S X=DIV S X=5 S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,9)=DIV,DIH=399,DIG=.09 D ^DICR
    4  S X=DG(DQ),DIC=DIE
    5  S DGRVRCAL=1
    6  S X=DG(DQ),DIC=DIE
    7  D ALLID^IBCEP3(DA,.19,1)
    8  S X=DG(DQ),DIC=DIE
    9  D BILLPNS^IBCU(DA)
    10  S X=DG(DQ),DIC=DIE
    11  D ATTREND^IBCU1(DA,"","")
     1IBXSC73 ; ;12/27/07
     2 S X=DE(24),DIC=DIE
     3 ;

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC74.m

    r613 r623  
    1 IBXSC74 ; ;01/03/09
    2  D DE G BEGIN
    3 DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGCR(399,DA,""))=""
    4  I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,19) S:%]"" DE(1)=%
    5  I $D(^("U")) S %Z=^("U") S %=$P(%Z,U,1) S:%]"" DE(15)=% S %=$P(%Z,U,2) S:%]"" DE(16)=% S %=$P(%Z,U,3) S:%]"" DE(12)=% S %=$P(%Z,U,5) S:%]"" DE(7)=% S %=$P(%Z,U,6) S:%]"" DE(10)=% S %=$P(%Z,U,7) S:%]"" DE(9)=%
    6  I $D(^("U1")) S %Z=^("U1") S %=$P(%Z,U,2) S:%]"" DE(21)=% S %=$P(%Z,U,3) S:%]"" DE(23)=% S %=$P(%Z,U,10) S:%]"" DE(26)=%
    7  I $D(^("U2")) S %Z=^("U2") S %=$P(%Z,U,4) S:%]"" DE(31)=%
    8  K %Z Q
    9  ;
    10 W W !?DL+DL-2,DLB_": "
    11  Q
    12 O D W W Y W:$X>45 !?9
    13  I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2
    14  W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W "  (No Editing)" Q
    15 TR R X:DTIME E  S (DTOUT,X)=U W $C(7)
    16  Q
    17 A K DQ(DQ) S DQ=DQ+1
    18 B G @DQ
    19 RE G PR:$D(DE(DQ)) D W,TR
    20 N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A
    21 RD G QS:X?."?" I X["^" D D G ^DIE17
    22  I X="@" D D G Z^DIE2
    23  I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W "  "_X
    24 T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I  W:'$D(DB(DQ)) "  "_% G V
    25  K DDER G X
    26 P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0
    27  G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z
    28  I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X
    29 V D @("X"_DQ) K YS
    30 Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A
    31 X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17
    32  S X="?BAD"
    33 QS S DZ=X D D,QQ^DIEQ G B
    34 D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q
    35 Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N
    36 PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP
    37 R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R
    38  I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R
    39  X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=%
    40 RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17
    41 I I DV'["I",DV'["#" G RD
    42  D E^DIE0 G RD:$D(X),PR
    43  Q
    44 SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1
    45  I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1
    46  D ^DIR I 'DDER S %=Y(0),X=Y
    47  Q
    48 SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ))
    49  I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")=""
    50  E  K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")
    51  Q
    52 NKEY W:'$D(ZTQUEUED) "??  Required key field" S X="?BAD" G QS
    53 KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY")
    54 BEGIN S DNM="IBXSC74",DQ=1
    55 1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW="0;19",DV="R*P353'",DU="",DLB="FORM TYPE",DIFLD=.19
    56  S DE(DW)="C1^IBXSC74"
    57  S DU="IBE(353,"
    58  S X=$G(DIPA("FT1"))
    59  S Y=X
    60  S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)
    61  G RD
    62 C1 G C1S:$D(DE(1))[0 K DB
    63  S X=DE(1),DIC=DIE
    64  ;
    65  S X=DE(1),DIC=DIE
    66  S DGRVRCAL=2
    67  S X=DE(1),DIC=DIE
    68  D ALLID^IBCEP3(DA,.19,2)
    69  S X=DE(1),DIC=DIE
    70  ;
    71  S X=DE(1),DIC=DIE
    72  D ATTREND^IBCU1(DA,"","")
    73 C1S S X="" G:DG(DQ)=X C1F1 K DB
     1IBXSC74 ; ;12/27/07
    742 S X=DG(DQ),DIC=DIE
    75  X ^DD(399,.19,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,9),X=X S DIU=X K Y S X=DIV S X=5 S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,9)=DIV,DIH=399,DIG=.09 D ^DICR
    76  S X=DG(DQ),DIC=DIE
    77  S DGRVRCAL=1
    78  S X=DG(DQ),DIC=DIE
    79  D ALLID^IBCEP3(DA,.19,1)
    80  S X=DG(DQ),DIC=DIE
    81  D BILLPNS^IBCU(DA)
    82  S X=DG(DQ),DIC=DIE
    83  D ATTREND^IBCU1(DA,"","")
    84 C1F1 Q
    85 X1 S DIC("S")="N Z S Z=$G(^IBE(353,Y,2)) I $P(Z,U,2)=""P"",$P(Z,U,4)" D ^DIC K DIC S DIC=$G(DIE),X=+Y K:Y<0 X
    86  Q
    87  ;
    88 2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
    89 X2 S Y="@714"
    90  Q
    91 3 S DQ=4 ;@715
    92 4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
    93 X4 D FTPRV^IBCEU5(DA)
    94  Q
    95 5 S DQ=6 ;@72
    96 6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 D X6 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
    97 X6 S:IBDR20'["72" Y="@73"
    98  Q
    99 7 D:$D(DG)>9 F^DIE17,DE S DQ=7,DW="U;5",DV="RFOX",DU="",DLB="IS THIS A SENSITIVE RECORD?",DIFLD=155
    100  S DQ(7,2)="S Y(0)=Y S Y=$S(Y:""YES"",Y=0:""NO"",1:"""")"
    101  G RE
    102 X7 I $D(X) D YN^IBCU
    103  I $D(X),X'?.ANP K X
    104  Q
    105  ;
    106 8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
    107 X8 S:X=0 Y=156
    108  Q
    109 9 S DW="U;7",DV="FOX",DU="",DLB="R.O.I. FORM(S) COMPLETED?",DIFLD=157
    110  S DQ(9,2)="S Y(0)=Y S Y=$S(Y:""YES"",Y=0:""NO"",1:"""")"
    111  G RE
    112 X9 I $D(X) D YN^IBCU
    113  I $D(X),X'?.ANP K X
    114  Q
    115  ;
    116 10 S DW="U;6",DV="RFOX",DU="",DLB="ASSIGNMENT OF BENEFITS",DIFLD=156
    117  S DQ(10,2)="S Y(0)=Y S Y=$S(Y="""":"""",""Yy1""[Y:""YES"",""Nn0""[Y:""NO"",1:"""")"
    118  G RE
    119 X10 I $D(X) D YN^IBCU I $D(X) X:X=0 ^DD(399,156,9.3) K IBRATY
    120  I $D(X),X'?.ANP K X
    121  Q
    122  ;
    123 11 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=11 D X11 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
    124 X11 S:'$D(IBOX) Y="@73"
    125  Q
    126 12 S DW="U;3",DV="RFOX",DU="",DLB="POWER OF ATTORNEY COMPLETED?",DIFLD=153
    127  S DQ(12,2)="S Y(0)=Y S Y=$S(Y:""YES"",Y=0:""NO"",1:"""")"
    128  G RE
    129 X12 I $D(X) D YN^IBCU
    130  I $D(X),X'?.ANP K X
    131  Q
    132  ;
    133 13 S DQ=14 ;@73
    134 14 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=14 D X14 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
    135 X14 S:IBDR20'["73" Y="@75"
    136  Q
    137 15 S DW="U;1",DV="RDX",DU="",DLB="STATEMENT COVERS FROM",DIFLD=151
    138  S DE(DW)="C15^IBXSC74"
    139  G RE
    140 C15 G C15S:$D(DE(15))[0 K DB
    141  S X=DE(15),DIC=DIE
    142  ;
    143  S X=DE(15),DIC=DIE
    144  S DGRVRCAL=2
    145  S X=DE(15),DIC=DIE
    146  ;
    147  S X=DE(15),DIC=DIE
    148  K:$P(^DGCR(399,DA,0),"^",2) ^DGCR(399,"APDS",$P(^(0),U,2),-X,DA)
    149 C15S S X="" G:DG(DQ)=X C15F1 K DB
    150  S X=DG(DQ),DIC=DIE
    151  K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I $P(^DGCR(399,DA,0),U,5)<3 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X=DIV S X=$$LOS1^IBCU64(DA) X ^DD(399,151,1,1,1.4)
    152  S X=DG(DQ),DIC=DIE
    153  S DGRVRCAL=1
    154  S X=DG(DQ),DIC=DIE
    155  K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I +$G(^DGCR(399,DA,"U1"))=0 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X=DIV S X=0 X ^DD(399,151,1,3,1.4)
    156  S X=DG(DQ),DIC=DIE
    157  S:$P(^DGCR(399,DA,0),"^",2) ^DGCR(399,"APDS",$P(^(0),U,2),-X,DA)=""
    158 C15F1 Q
    159 X15 S %DT="ETP" D ^%DT S X=Y K:Y<1 X I $D(X) D DDAT^IBCU4 K IB00
    160  Q
    161  ;
    162 16 D:$D(DG)>9 F^DIE17,DE S DQ=16,DW="U;2",DV="RDX",DU="",DLB="STATEMENT COVERS TO",DIFLD=152
    163  S DE(DW)="C16^IBXSC74"
    164  G RE
    165 C16 G C16S:$D(DE(16))[0 K DB
    166  S X=DE(16),DIC=DIE
    167  ;
    168  S X=DE(16),DIC=DIE
    169  S DGRVRCAL=2
    170 C16S S X="" G:DG(DQ)=X C16F1 K DB
    171  S X=DG(DQ),DIC=DIE
    172  K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I $P(^DGCR(399,DA,0),U,5)<3 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X=DIV S X=$$LOS1^IBCU64(DA) X ^DD(399,152,1,1,1.4)
    173  S X=DG(DQ),DIC=DIE
    174  S DGRVRCAL=1
    175 C16F1 Q
    176 X16 S %DT="ETP" D ^%DT S X=Y K:Y<1 X I $D(X) D DDAT1^IBCU4 K IB00
    177  Q
    178  ;
    179 17 S DQ=18 ;@75
    180 18 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=18 D X18 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
    181 X18 S:IBDR20'["75" Y="@76"
    182  Q
    183 19 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=19 D X19 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
    184 X19 D RCD^IBCU1
    185  Q
    186 20 D:$D(DG)>9 F^DIE17,DE S DQ=20,D=0 K DE(1) ;42
    187  S DIFLD=42,DGO="^IBXSC75",DC="15^399.042IPA^RC^",DV="399.042MR*P399.2'",DW="0;1",DOW="REVENUE CODE",DLB="Select "_DOW S:D DC=DC_D
    188  S DU="DGCR(399.2,"
    189  G RE:D I $D(DSC(399.042))#2,$P(DSC(399.042),"I $D(^UTILITY(",1)="" X DSC(399.042) S D=$O(^(0)) S:D="" D=-1 G M20
    190  S D=$S($D(^DGCR(399,DA,"RC",0)):$P(^(0),U,3,4),$O(^(0))'="":$O(^(0)),1:-1)
    191 M20 I D>0 S DC=DC_D I $D(^DGCR(399,DA,"RC",+D,0)) S DE(20)=$P(^(0),U,1)
    192  G RE
    193 R20 D DE
    194  S D=$S($D(^DGCR(399,DA,"RC",0)):$P(^(0),U,3,4),1:1) G 20+1
    195  ;
    196 21 S DW="U1;2",DV="NJ8,2",DU="",DLB="OFFSET AMOUNT",DIFLD=202
    197  S DE(DW)="C21^IBXSC74"
    198  G RE
    199 C21 G C21S:$D(DE(21))[0 K DB
    200  S X=DE(21),DIC=DIE
    201  K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,2)="" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X="" X ^DD(399,202,1,1,2.4)
    202 C21S S X="" G:DG(DQ)=X C21F1 K DB
    203  S X=DG(DQ),DIC=DIE
    204  ;
    205 C21F1 Q
    206 X21 S:X["$" X=$P(X,"$",2) K:X'?.N.1".".2N!(X>99999)!(X<0) X
    207  Q
    208  ;
    209 22 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=22 D X22 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
    210 X22 S:'X Y="@757"
    211  Q
    212 23 D:$D(DG)>9 F^DIE17,DE S DQ=23,DW="U1;3",DV="FX",DU="",DLB="OFFSET DESCRIPTION",DIFLD=203
    213  G RE
    214 X23 K:$L(X)>24!($L(X)<3) X
    215  I $D(X),X'?.ANP K X
    216  Q
    217  ;
    218 24 S DQ=25 ;@757
    219 25 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=25 D X25 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
    220 X25 I $P(^DGCR(399,DA,"U1"),"^",11)']"" S Y="@76"
    221  Q
    222 26 S DW="U1;10",DV="RNJ10,2",DU="",DLB="*FY 1 CHARGES",DIFLD=210
    223  G RE
    224 X26 S:X["$" X=$P(X,"$",2) K:X'?.N.1".".2N!(X>9999999)!(X<0) X
    225  Q
    226  ;
    227 27 S DQ=28 ;@76
    228 28 S DQ=29 ;@77
    229 29 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=29 D X29 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
    230 X29 S:IBDR20'["77" Y="@78"
    231  Q
    232 30 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=30 D X30 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
    233 X30 S:'$D(^DGCR(399,DA,"I1")) Y="@772"
    234  Q
    235 31 S DW="U2;4",DV="NJ11,2",DU="",DLB="PRIMARY PRIOR PAYMENT",DIFLD=218
    236  S DE(DW)="C31^IBXSC74"
    237  G RE
    238 C31 G C31S:$D(DE(31))[0 K DB
    239  D ^IBXSC76
    240 C31S S X="" G:DG(DQ)=X C31F1 K DB
    241  D ^IBXSC77
    242 C31F1 Q
    243 X31 S:X["$" X=$P(X,"$",2) K:X'?.N.1".".2N!(X>99999999)!(X<0) X
    244  Q
    245  ;
    246 32 S DQ=33 ;@772
    247 33 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=33 D X33 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
    248 X33 S:'$D(^DGCR(399,DA,"I2")) Y="@773"
    249  Q
    250 34 D:$D(DG)>9 F^DIE17 G ^IBXSC78
     3 K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,19),X=X S DIU=X K Y S X=DIV S X=$$FT^IBCU3(DA,1) X ^DD(399,.27,1,1,1.4)

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC75.m

    r613 r623  
    1 IBXSC75 ; ;01/03/09
     1IBXSC75 ; ;12/27/07
    22 D DE G BEGIN
    3 DE S DIE="^DGCR(399,D0,""RC"",",DIC=DIE,DP=399.042,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGCR(399,D0,"RC",DA,""))=""
    4  I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,1) S:%]"" DE(1)=% S %=$P(%Z,U,2) S:%]"" DE(2)=% S %=$P(%Z,U,3) S:%]"" DE(3)=% S %=$P(%Z,U,4) S:%]"" DE(4)=% S %=$P(%Z,U,5) S:%]"" DE(5)=% S %=$P(%Z,U,6) S:%]"" DE(7)=% S %=$P(%Z,U,7) S:%]"" DE(9)=%
    5  I  S %=$P(%Z,U,9) S:%]"" DE(6)=% S %=$P(%Z,U,10) S:%]"" DE(12)=% S %=$P(%Z,U,12) S:%]"" DE(13)=% S %=$P(%Z,U,15) S:%]"" DE(18)=%
     3DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGCR(399,DA,""))=""
     4 I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,19) S:%]"" DE(1)=%,DE(5)=%
     5 I $D(^("U")) S %Z=^("U") S %=$P(%Z,U,1) S:%]"" DE(19)=% S %=$P(%Z,U,2) S:%]"" DE(20)=% S %=$P(%Z,U,3) S:%]"" DE(16)=% S %=$P(%Z,U,5) S:%]"" DE(11)=% S %=$P(%Z,U,6) S:%]"" DE(14)=% S %=$P(%Z,U,7) S:%]"" DE(13)=%
    66 K %Z Q
    77 ;
    … …  
    5050NKEY W:'$D(ZTQUEUED) "??  Required key field" S X="?BAD" G QS
    5151KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY")
    52 BEGIN S DNM="IBXSC75",DQ=1+D G B
    53 1 S DW="0;1",DV="MR*P399.2'",DU="",DLB="REVENUE CODE",DIFLD=.01
    54  S DE(DW)="C1^IBXSC75",DE(DW,"INDEX")=1
    55  S DU="DGCR(399.2,"
    56  G RE:'D S DQ=2 G 2
     52BEGIN S DNM="IBXSC75",DQ=1
     531 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW="0;19",DV="R*P353'",DU="",DLB="FORM TYPE",DIFLD=.19
     54 S DE(DW)="C1^IBXSC75"
     55 S DU="IBE(353,"
     56 G RE
    5757C1 G C1S:$D(DE(1))[0 K DB
    5858 S X=DE(1),DIC=DIE
    59  K ^DGCR(399,DA(1),"RC","B",$E(X,1,30),DA)
    60  S X=DE(1),DIC=DIE
    61  I $P(^DGCR(399,DA(1),"RC",DA,0),U,5) K ^DGCR(399,DA(1),"RC","ABS",$P(^DGCR(399,DA(1),"RC",DA,0),U,5),$E(X,1,30),DA)
     59 ;
     60 S X=DE(1),DIC=DIE
     61 S DGRVRCAL=2
     62 S X=DE(1),DIC=DIE
     63 D ALLID^IBCEP3(DA,.19,2)
     64 S X=DE(1),DIC=DIE
     65 ;
     66 S X=DE(1),DIC=DIE
     67 D ATTREND^IBCU1(DA,"","")
    6268C1S S X="" G:DG(DQ)=X C1F1 K DB
    6369 S X=DG(DQ),DIC=DIE
    64  S ^DGCR(399,DA(1),"RC","B",$E(X,1,30),DA)=""
    65  S X=DG(DQ),DIC=DIE
    66  I $P(^DGCR(399,DA(1),"RC",DA,0),U,5) S ^DGCR(399,DA(1),"RC","ABS",$P(^DGCR(399,DA(1),"RC",DA,0),U,5),$E(X,1,30),DA)=""
    67 C1F1 N X,X1,X2 S DIXR=53 D C1X1(U) K X2 M X2=X D C1X1("O") K X1 M X1=X
    68  I $G(X(1))]"" D
    69  . I X(2)'=""&'$D(^TMP("IBCRRX",$J)) D DELPR^IBCU1(DA(1),X(2))
    70  G C1F2
    71 C1X1(DION) K X
    72  S X(1)=$G(@DIEZTMP@("V",399.042,DIIENS,.01,DION),$P($G(^DGCR(399,DA(1),"RC",DA,0)),U,1))
    73  S X(2)=$G(@DIEZTMP@("V",399.042,DIIENS,.15,DION),$P($G(^DGCR(399,DA(1),"RC",DA,0)),U,15))
    74  S X=$G(X(1))
    75  Q
    76 C1F2 Q
    77 X1 S DIC("S")="I +$P(^(0),U,3)" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X
    78  Q
    79  ;
    80 2 D:$D(DG)>9 F^DIE17,DE S DQ=2,DW="0;2",DV="RNJ8,2",DU="",DLB="CHARGES",DIFLD=.02
    81  S DE(DW)="C2^IBXSC75"
    82  G RE
    83 C2 G C2S:$D(DE(2))[0 K DB
    84  S X=DE(2),DIC=DIE
    85  D 22^IBCU2
    86 C2S S X="" G:DG(DQ)=X C2F1 K DB
    87  S X=DG(DQ),DIC=DIE
    88  D 21^IBCU2
    89 C2F1 Q
    90 X2 S:X["$" X=$P(X,"$",2) K:X'?.N.1".".2N!(X>99999)!(X<0) X
    91  Q
    92  ;
    93 3 D:$D(DG)>9 F^DIE17,DE S DQ=3,DW="0;3",DV="RNJ6,0X",DU="",DLB="UNITS OF SERVICE",DIFLD=.03
    94  S DE(DW)="C3^IBXSC75"
    95  G RE
    96 C3 G C3S:$D(DE(3))[0 K DB
    97  S X=DE(3),DIC=DIE
    98  D 32^IBCU2
    99 C3S S X="" G:DG(DQ)=X C3F1 K DB
    100  S X=DG(DQ),DIC=DIE
    101  D 31^IBCU2
    102 C3F1 Q
    103 X3 K:X'?1.N X I $D(X) S:X=0 X=1
    104  Q
    105  ;
    106 4 D:$D(DG)>9 F^DIE17,DE S DQ=4,DW="0;4",DV="RNJ9,2XI",DU="",DLB="TOTAL",DIFLD=.04
    107  S DE(DW)="C4^IBXSC75"
    108  G RE
    109 C4 G C4S:$D(DE(4))[0 K DB
    110  S X=DE(4),DIC=DIE
    111  S DGXRF=2 D TC^IBCU2 K DGXRF
    112 C4S S X="" G:DG(DQ)=X C4F1 K DB
    113  S X=DG(DQ),DIC=DIE
    114  S DGXRF=1 D TC^IBCU2 K DGXRF
    115 C4F1 Q
    116 X4 K:X?1.10N.1".".2N X
    117  Q
    118  ;
    119 5 D:$D(DG)>9 F^DIE17,DE S DQ=5,DW="0;5",DV="R*P399.1'",DU="",DLB="BEDSECTION",DIFLD=.05
     70 X ^DD(399,.19,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,9),X=X S DIU=X K Y S X=DIV S X=5 S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,9)=DIV,DIH=399,DIG=.09 D ^DICR
     71 S X=DG(DQ),DIC=DIE
     72 S DGRVRCAL=1
     73 S X=DG(DQ),DIC=DIE
     74 D ALLID^IBCEP3(DA,.19,1)
     75 S X=DG(DQ),DIC=DIE
     76 D BILLPNS^IBCU(DA)
     77 S X=DG(DQ),DIC=DIE
     78 D ATTREND^IBCU1(DA,"","")
     79C1F1 Q
     80X1 S DIC("S")="N Z S Z=$G(^IBE(353,Y,2)) I $P(Z,U,2)=""P"",$P(Z,U,4)" D ^DIC K DIC S DIC=$G(DIE),X=+Y K:Y<0 X
     81 Q
     82 ;
     832 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
     84X2 S DIPA("FT")=$P($G(^DGCR(399,DA,0)),U,19)
     85 Q
     863 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=3 D X3 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
     87X3 I $P($G(^IBE(353,+DIPA("FT"),2)),U,2)="P",$P($G(^(2)),U,4) S DIPA("FT1")=DIPA("FT") D CKFT^IBCIUT1(IBIFN) S Y="@715"
     88 Q
     894 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
     90X4 W !,*7,"Must be a printable national form type"
     91 Q
     925 D:$D(DG)>9 F^DIE17,DE S DQ=5,DW="0;19",DV="R*P353'",DU="",DLB="FORM TYPE",DIFLD=.19
    12093 S DE(DW)="C5^IBXSC75"
    121  S DU="DGCR(399.1,"
    122  G RE
     94 S DU="IBE(353,"
     95 S X=$G(DIPA("FT1"))
     96 S Y=X
     97 S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)
     98 G RD
    12399C5 G C5S:$D(DE(5))[0 K DB
    124100 S X=DE(5),DIC=DIE
    125  K ^DGCR(399,DA(1),"RC","ABS",$E(X,1,30),+^DGCR(399,DA(1),"RC",DA,0),DA)
     101 ;
     102 S X=DE(5),DIC=DIE
     103 S DGRVRCAL=2
     104 S X=DE(5),DIC=DIE
     105 D ALLID^IBCEP3(DA,.19,2)
     106 S X=DE(5),DIC=DIE
     107 ;
     108 S X=DE(5),DIC=DIE
     109 D ATTREND^IBCU1(DA,"","")
    126110C5S S X="" G:DG(DQ)=X C5F1 K DB
    127111 S X=DG(DQ),DIC=DIE
    128  S ^DGCR(399,DA(1),"RC","ABS",$E(X,1,30),+^DGCR(399,DA(1),"RC",DA,0),DA)=""
     112 X ^DD(399,.19,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,9),X=X S DIU=X K Y S X=DIV S X=5 S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,9)=DIV,DIH=399,DIG=.09 D ^DICR
     113 S X=DG(DQ),DIC=DIE
     114 S DGRVRCAL=1
     115 S X=DG(DQ),DIC=DIE
     116 D ALLID^IBCEP3(DA,.19,1)
     117 S X=DG(DQ),DIC=DIE
     118 D BILLPNS^IBCU(DA)
     119 S X=DG(DQ),DIC=DIE
     120 D ATTREND^IBCU1(DA,"","")
    129121C5F1 Q
    130 X5 S DIC("S")="I $P(^(0),U,5)" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X
    131  Q
    132  ;
    133 6 D:$D(DG)>9 F^DIE17,DE S DQ=6,DW="0;9",DV="NJ8,2",DU="",DLB="NON-COVERED CHARGE",DIFLD=.09
    134  G RE
    135 X6 S:X["$" X=$P(X,"$",2) K:X'?.N.1".".2N!(X>99999)!(X<0)!(X?.E1"."3.N) X
    136  Q
    137  ;
    138 7 S DW="0;6",DV="*P81'",DU="",DLB="PROCEDURE",DIFLD=.06
    139  S DE(DW)="C7^IBXSC75"
    140  S DU="ICPT("
    141  G RE
    142 C7 G C7S:$D(DE(7))[0 K DB
    143  S X=DE(7),DIC=DIE
    144  K ^DGCR(399,"ASC1",$E(X,1,30),DA(1),DA)
    145  S X=DE(7),DIC=DIE
    146  K ^DGCR(399,"ASC2",DA(1),$E(X,1,30),DA)
    147 C7S S X="" G:DG(DQ)=X C7F1 K DB
    148  S X=DG(DQ),DIC=DIE
    149  I $$RC^IBEFUNC1(DA(1),DA) S ^DGCR(399,"ASC1",$E(X,1,30),DA(1),DA)=""
    150  S X=DG(DQ),DIC=DIE
    151  I $$RC^IBEFUNC1(DA(1),DA) S ^DGCR(399,"ASC2",DA(1),$E(X,1,30),DA)=""
    152 C7F1 Q
    153 X7 S ICPTVDT=$$BDATE^IBACSV($G(DA(1))),DIC("S")="I $$CPTACT^IBACSV(+Y,ICPTVDT)",DIC("W")="D EN^DDIOL(""   ""_$P($$CPT^IBACSV(+Y,ICPTVDT),U,2),,""?0"")" D ^DIC K DIC S DIC=$G(DIE),X=+Y K:Y<0 X
    154  Q
    155  ;
     122X5 S DIC("S")="N Z S Z=$G(^IBE(353,Y,2)) I $P(Z,U,2)=""P"",$P(Z,U,4)" D ^DIC K DIC S DIC=$G(DIE),X=+Y K:Y<0 X
     123 Q
     124 ;
     1256 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 D X6 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
     126X6 S Y="@714"
     127 Q
     1287 S DQ=8 ;@715
    1561298 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
    157 X8 I '$P(^DGCR(399,DA(1),"RC",DA,0),U,6) S Y="@758"
    158  Q
    159 9 D:$D(DG)>9 F^DIE17,DE S DQ=9,DW="0;7",DV="P40.8'X",DU="",DLB="DIVISION",DIFLD=.07
    160  S DE(DW)="C9^IBXSC75"
    161  S DU="DG(40.8,"
    162  S X=$$DEFDIV^IBCU7(DA(1))
    163  S Y=X
    164  G Y
    165 C9 G C9S:$D(DE(9))[0 K DB
    166  S X=DE(9),DIC=DIE
    167  K ^DGCR(399,"ASC1",+$P(^DGCR(399,DA(1),"RC",DA,0),U,6),DA(1),DA)
    168  S X=DE(9),DIC=DIE
    169  K ^DGCR(399,"ASC2",DA(1),+$P(^DGCR(399,DA(1),"RC",DA,0),U,6),DA)
    170 C9S S X="" G:DG(DQ)=X C9F1 K DB
    171  S X=DG(DQ),DIC=DIE
    172  I $$RC^IBEFUNC1(DA(1),DA) S ^DGCR(399,"ASC1",$P(^DGCR(399,DA(1),"RC",DA,0),U,6),DA(1),DA)=""
    173  S X=DG(DQ),DIC=DIE
    174  I $$RC^IBEFUNC1(DA(1),DA) S ^DGCR(399,"ASC2",DA(1),$P(^DGCR(399,DA(1),"RC",DA,0),U,6),DA)=""
    175 C9F1 Q
    176 X9 Q
    177 10 S DQ=11 ;@758
    178 11 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=11 D X11 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
    179 X11 I +$P(^DGCR(399,DA(1),"RC",DA,0),U,8) W !," AUTO ADDED CHARGE - NO CHANGE TO TYPE/COMPONENT" S Y="@759"
    180  Q
    181 12 D:$D(DG)>9 F^DIE17,DE S DQ=12,DW="0;10",DV="S",DU="",DLB="TYPE",DIFLD=.1
    182  S DE(DW)="C12^IBXSC75"
    183  S DU="1:INPT BS;2:OPT VST DT;3:RX;4:CPT;5:PROS;6:DRG;9:UNASSOCIATED;"
    184  G RE
    185 C12 G C12S:$D(DE(12))[0 K DB
    186  S X=DE(12),DIC=DIE
    187  K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA,DIV(1)=D1 S Y(1)=$S($D(^DGCR(399,D0,"RC",D1,0)):^(0),1:"") S X=$P(Y(1),U,11),X=X S DIU=X K Y S X="" X ^DD(399.042,.1,1,1,2.4)
    188  S X=DE(12),DIC=DIE
    189  X ^DD(399.042,.1,1,2,2.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"RC",D1,0)):^(0),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X="" S DIH=$G(^DGCR(399,DIV(0),"RC",DIV(1),0)),DIV=X S $P(^(0),U,15)=DIV,DIH=399.042,DIG=.15 D ^DICR
    190 C12S S X="" G:DG(DQ)=X C12F1 K DB
    191  S X=DG(DQ),DIC=DIE
    192  ;
    193  S X=DG(DQ),DIC=DIE
    194  ;
    195 C12F1 Q
    196 X12 Q
    197 13 D:$D(DG)>9 F^DIE17,DE S DQ=13,DW="0;12",DV="S",DU="",DLB="COMPONENT",DIFLD=.12
    198  S DU="1:INSTITUTIONAL;2:PROFESSIONAL;"
    199  G RE
    200 X13 Q
    201 14 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=14 D X14 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
    202 X14 I $S($P($G(^DGCR(399,DA(1),"RC",DA,0)),U,10)=3:0,1:$P($G(^(0)),U,10)'=4)!$P($G(^(0)),U,8) S Y="@759"
    203  Q
     130X8 D FTPRV^IBCEU5(DA)
     131 Q
     1329 S DQ=10 ;@72
     13310 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 D X10 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
     134X10 S:IBDR20'["72" Y="@73"
     135 Q
     13611 D:$D(DG)>9 F^DIE17,DE S DQ=11,DW="U;5",DV="RFOX",DU="",DLB="IS THIS A SENSITIVE RECORD?",DIFLD=155
     137 S DQ(11,2)="S Y(0)=Y S Y=$S(Y:""YES"",Y=0:""NO"",1:"""")"
     138 G RE
     139X11 I $D(X) D YN^IBCU
     140 I $D(X),X'?.ANP K X
     141 Q
     142 ;
     14312 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=12 D X12 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
     144X12 S:X=0 Y=156
     145 Q
     14613 S DW="U;7",DV="FOX",DU="",DLB="R.O.I. FORM(S) COMPLETED?",DIFLD=157
     147 S DQ(13,2)="S Y(0)=Y S Y=$S(Y:""YES"",Y=0:""NO"",1:"""")"
     148 G RE
     149X13 I $D(X) D YN^IBCU
     150 I $D(X),X'?.ANP K X
     151 Q
     152 ;
     15314 S DW="U;6",DV="RFOX",DU="",DLB="ASSIGNMENT OF BENEFITS",DIFLD=156
     154 S DQ(14,2)="S Y(0)=Y S Y=$S(Y="""":"""",""Yy1""[Y:""YES"",""Nn0""[Y:""NO"",1:"""")"
     155 G RE
     156X14 I $D(X) D YN^IBCU I $D(X) X:X=0 ^DD(399,156,9.3) K IBRATY
     157 I $D(X),X'?.ANP K X
     158 Q
     159 ;
    20416015 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=15 D X15 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
    205 X15 I $P($G(^DGCR(399,DA(1),"RC",DA,0)),U,10)=4 S Y="@7581"
    206  Q
    207 16 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=16 D X16 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
    208 X16 S DGRVRCAL=1
    209  Q
    210 17 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=17 D X17 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
    211 X17 D LINKRX^IBCEU5(DA(1),DA)
    212  Q
    213 18 S DW="0;15",DV="FXO",DU="",DLB="RX PROCEDURE",DIFLD=.15
    214  S DQ(18,2)="S Y(0)=Y S Y=Y_"" - ""_$P($$PRCNM^IBCSCH1($P($G(^DGCR(399,D0,""CP"",+Y,0)),U)),U)"
    215  S DE(DW)="C18^IBXSC75",DE(DW,"INDEX")=1
    216  G RE
    217 C18 G C18S:$D(DE(18))[0 K DB
    218  S X=DE(18),DIC=DIE
    219  K ^DGCR(399,DA(1),"RC","ACP",$E(X,1,30),DA)
    220 C18S S X="" G:DG(DQ)=X C18F1 K DB
    221  S X=DG(DQ),DIC=DIE
    222  S ^DGCR(399,DA(1),"RC","ACP",$E(X,1,30),DA)=""
    223 C18F1 N X,X1,X2 S DIXR=53 D C18X1(U) K X2 M X2=X D C18X1("O") K X1 M X1=X
    224  I $G(X(1))]"" D
    225  . I X(2)'=""&'$D(^TMP("IBCRRX",$J)) D DELPR^IBCU1(DA(1),X(2))
    226  G C18F2
    227 C18X1(DION) K X
    228  S X(1)=$G(@DIEZTMP@("V",399.042,DIIENS,.01,DION),$P($G(^DGCR(399,DA(1),"RC",DA,0)),U,1))
    229  S X(2)=$G(@DIEZTMP@("V",399.042,DIIENS,.15,DION),$P($G(^DGCR(399,DA(1),"RC",DA,0)),U,15))
    230  S X=$G(X(1))
    231  Q
    232 C18F2 Q
    233 X18 S X=$$RXPRLOOK^IBCEU4(X) K:'X X
    234  I $D(X),X'?.ANP K X
    235  Q
    236  ;
    237 19 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=19 D X19 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
    238 X19 S Y="@759"
    239  Q
    240 20 S DQ=21 ;@7581
    241 21 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=21 D X21 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
    242 X21 D LINKCPT^IBCEU5(DA(1),DA)
    243  Q
    244 22 S DQ=23 ;@759
    245 23 G 1^DIE17
     161X15 S:'$D(IBOX) Y="@73"
     162 Q
     16316 S DW="U;3",DV="RFOX",DU="",DLB="POWER OF ATTORNEY COMPLETED?",DIFLD=153
     164 S DQ(16,2)="S Y(0)=Y S Y=$S(Y:""YES"",Y=0:""NO"",1:"""")"
     165 G RE
     166X16 I $D(X) D YN^IBCU
     167 I $D(X),X'?.ANP K X
     168 Q
     169 ;
     17017 S DQ=18 ;@73
     17118 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=18 D X18 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
     172X18 S:IBDR20'["73" Y="@75"
     173 Q
     17419 S DW="U;1",DV="RDX",DU="",DLB="STATEMENT COVERS FROM",DIFLD=151
     175 S DE(DW)="C19^IBXSC75"
     176 G RE
     177C19 G C19S:$D(DE(19))[0 K DB
     178 S X=DE(19),DIC=DIE
     179 ;
     180 S X=DE(19),DIC=DIE
     181 S DGRVRCAL=2
     182 S X=DE(19),DIC=DIE
     183 ;
     184 S X=DE(19),DIC=DIE
     185 K:$P(^DGCR(399,DA,0),"^",2) ^DGCR(399,"APDS",$P(^(0),U,2),-X,DA)
     186C19S S X="" G:DG(DQ)=X C19F1 K DB
     187 D ^IBXSC76
     188C19F1 Q
     189X19 S %DT="ETP" D ^%DT S X=Y K:Y<1 X I $D(X) D DDAT^IBCU4 K IB00
     190 Q
     191 ;
     19220 D:$D(DG)>9 F^DIE17,DE S DQ=20,DW="U;2",DV="RDX",DU="",DLB="STATEMENT COVERS TO",DIFLD=152
     193 S DE(DW)="C20^IBXSC75"
     194 G RE
     195C20 G C20S:$D(DE(20))[0 K DB
     196 S X=DE(20),DIC=DIE
     197 ;
     198 S X=DE(20),DIC=DIE
     199 S DGRVRCAL=2
     200C20S S X="" G:DG(DQ)=X C20F1 K DB
     201 D ^IBXSC77
     202C20F1 Q
     203X20 S %DT="ETP" D ^%DT S X=Y K:Y<1 X I $D(X) D DDAT1^IBCU4 K IB00
     204 Q
     205 ;
     20621 S DQ=22 ;@75
     20722 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=22 D X22 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
     208X22 S:IBDR20'["75" Y="@76"
     209 Q
     21023 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=23 D X23 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
     211X23 D RCD^IBCU1
     212 Q
     21324 D:$D(DG)>9 F^DIE17 G ^IBXSC78

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC76.m

    r613 r623  
    1 IBXSC76 ; ;01/03/09
    2  S X=DE(31),DIC=DIE
    3  K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIU-X X ^DD(399,218,1,1,2.4)
    4  S X=DE(31),DIC=DIE
    5  ;
     1IBXSC76 ; ;12/27/07
     2 S X=DG(DQ),DIC=DIE
     3 K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I $P(^DGCR(399,DA,0),U,5)<3 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X=DIV S X=$$LOS1^IBCU64(DA) X ^DD(399,151,1,1,1.4)
     4 S X=DG(DQ),DIC=DIE
     5 S DGRVRCAL=1
     6 S X=DG(DQ),DIC=DIE
     7 K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I +$G(^DGCR(399,DA,"U1"))=0 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X=DIV S X=0 X ^DD(399,151,1,3,1.4)
     8 S X=DG(DQ),DIC=DIE
     9 S:$P(^DGCR(399,DA,0),"^",2) ^DGCR(399,"APDS",$P(^(0),U,2),-X,DA)=""

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC77.m

    r613 r623  
    1 IBXSC77 ; ;01/03/09
     1IBXSC77 ; ;12/27/07
    22 S X=DG(DQ),DIC=DIE
    3  K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIU+DIV X ^DD(399,218,1,1,1.4)
     3 K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I $P(^DGCR(399,DA,0),U,5)<3 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X=DIV S X=$$LOS1^IBCU64(DA) X ^DD(399,152,1,1,1.4)
    44 S X=DG(DQ),DIC=DIE
    5  K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV S X="PRIOR PAYMENT(S)" X ^DD(399,218,1,2,1.4)
     5 S DGRVRCAL=1

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC78.m

    r613 r623  
    1 IBXSC78 ; ;01/03/09
     1IBXSC78 ; ;12/27/07
    22 D DE G BEGIN
    33DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGCR(399,DA,""))=""
    4  I $D(^("U2")) S %Z=^("U2") S %=$P(%Z,U,5) S:%]"" DE(1)=% S %=$P(%Z,U,6) S:%]"" DE(4)=%
     4 I $D(^("U1")) S %Z=^("U1") S %=$P(%Z,U,2) S:%]"" DE(2)=% S %=$P(%Z,U,3) S:%]"" DE(4)=% S %=$P(%Z,U,10) S:%]"" DE(7)=%
     5 I $D(^("U2")) S %Z=^("U2") S %=$P(%Z,U,4) S:%]"" DE(12)=% S %=$P(%Z,U,5) S:%]"" DE(15)=% S %=$P(%Z,U,6) S:%]"" DE(18)=%
    56 K %Z Q
    67 ;
    … …  
    5051KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY")
    5152BEGIN S DNM="IBXSC78",DQ=1
    52 1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW="U2;5",DV="NJ11,2",DU="",DLB="SECONDARY PRIOR PAYMENT",DIFLD=219
    53  S DE(DW)="C1^IBXSC78"
     531 D:$D(DG)>9 F^DIE17,DE S DQ=1,D=0 K DE(1) ;42
     54 S DIFLD=42,DGO="^IBXSC79",DC="15^399.042IPA^RC^",DV="399.042MR*P399.2'",DW="0;1",DOW="REVENUE CODE",DLB="Select "_DOW S:D DC=DC_D
     55 S DU="DGCR(399.2,"
     56 G RE:D I $D(DSC(399.042))#2,$P(DSC(399.042),"I $D(^UTILITY(",1)="" X DSC(399.042) S D=$O(^(0)) S:D="" D=-1 G M1
     57 S D=$S($D(^DGCR(399,DA,"RC",0)):$P(^(0),U,3,4),$O(^(0))'="":$O(^(0)),1:-1)
     58M1 I D>0 S DC=DC_D I $D(^DGCR(399,DA,"RC",+D,0)) S DE(1)=$P(^(0),U,1)
    5459 G RE
    55 C1 G C1S:$D(DE(1))[0 K DB
    56  S X=DE(1),DIC=DIE
     60R1 D DE
     61 S D=$S($D(^DGCR(399,DA,"RC",0)):$P(^(0),U,3,4),1:1) G 1+1
     62 ;
     632 S DW="U1;2",DV="NJ8,2",DU="",DLB="OFFSET AMOUNT",DIFLD=202
     64 S DE(DW)="C2^IBXSC78"
     65 G RE
     66C2 G C2S:$D(DE(2))[0 K DB
     67 S X=DE(2),DIC=DIE
     68 K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,2)="" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X="" X ^DD(399,202,1,1,2.4)
     69C2S S X="" G:DG(DQ)=X C2F1 K DB
     70 S X=DG(DQ),DIC=DIE
     71 ;
     72C2F1 Q
     73X2 S:X["$" X=$P(X,"$",2) K:X'?.N.1".".2N!(X>99999)!(X<0) X
     74 Q
     75 ;
     763 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=3 D X3 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
     77X3 S:'X Y="@757"
     78 Q
     794 D:$D(DG)>9 F^DIE17,DE S DQ=4,DW="U1;3",DV="FX",DU="",DLB="OFFSET DESCRIPTION",DIFLD=203
     80 G RE
     81X4 K:$L(X)>24!($L(X)<3) X
     82 I $D(X),X'?.ANP K X
     83 Q
     84 ;
     855 S DQ=6 ;@757
     866 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 D X6 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
     87X6 I $P(^DGCR(399,DA,"U1"),"^",11)']"" S Y="@76"
     88 Q
     897 S DW="U1;10",DV="RNJ10,2",DU="",DLB="*FY 1 CHARGES",DIFLD=210
     90 G RE
     91X7 S:X["$" X=$P(X,"$",2) K:X'?.N.1".".2N!(X>9999999)!(X<0) X
     92 Q
     93 ;
     948 S DQ=9 ;@76
     959 S DQ=10 ;@77
     9610 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 D X10 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
     97X10 S:IBDR20'["77" Y="@78"
     98 Q
     9911 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=11 D X11 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
     100X11 S:'$D(^DGCR(399,DA,"I1")) Y="@772"
     101 Q
     10212 S DW="U2;4",DV="NJ11,2",DU="",DLB="PRIMARY PRIOR PAYMENT",DIFLD=218
     103 S DE(DW)="C12^IBXSC78"
     104 G RE
     105C12 G C12S:$D(DE(12))[0 K DB
     106 S X=DE(12),DIC=DIE
     107 K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIU-X X ^DD(399,218,1,1,2.4)
     108 S X=DE(12),DIC=DIE
     109 ;
     110C12S S X="" G:DG(DQ)=X C12F1 K DB
     111 S X=DG(DQ),DIC=DIE
     112 K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIU+DIV X ^DD(399,218,1,1,1.4)
     113 S X=DG(DQ),DIC=DIE
     114 K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV S X="PRIOR PAYMENT(S)" X ^DD(399,218,1,2,1.4)
     115C12F1 Q
     116X12 S:X["$" X=$P(X,"$",2) K:X'?.N.1".".2N!(X>99999999)!(X<0) X
     117 Q
     118 ;
     11913 S DQ=14 ;@772
     12014 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=14 D X14 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
     121X14 S:'$D(^DGCR(399,DA,"I2")) Y="@773"
     122 Q
     12315 D:$D(DG)>9 F^DIE17,DE S DQ=15,DW="U2;5",DV="NJ11,2",DU="",DLB="SECONDARY PRIOR PAYMENT",DIFLD=219
     124 S DE(DW)="C15^IBXSC78"
     125 G RE
     126C15 G C15S:$D(DE(15))[0 K DB
     127 S X=DE(15),DIC=DIE
    57128 K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIU-X X ^DD(399,219,1,1,2.4)
    58  S X=DE(1),DIC=DIE
     129 S X=DE(15),DIC=DIE
    59130 ;
    60 C1S S X="" G:DG(DQ)=X C1F1 K DB
     131C15S S X="" G:DG(DQ)=X C15F1 K DB
    61132 S X=DG(DQ),DIC=DIE
    62133 K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIU+DIV X ^DD(399,219,1,1,1.4)
    63134 S X=DG(DQ),DIC=DIE
    64135 K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV S X="PRIOR PAYMENT(S)" X ^DD(399,219,1,2,1.4)
    65 C1F1 Q
    66 X1 S:X["$" X=$P(X,"$",2) K:X'?.N.1".".2N!(X>99999999)!(X<0) X
     136C15F1 Q
     137X15 S:X["$" X=$P(X,"$",2) K:X'?.N.1".".2N!(X>99999999)!(X<0) X
    67138 Q
    68139 ;
    69 2 S DQ=3 ;@773
    70 3 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=3 D X3 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
    71 X3 S:'$D(^DGCR(399,DA,"I3")) Y="@78"
     14016 S DQ=17 ;@773
     14117 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=17 D X17 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
     142X17 S:'$D(^DGCR(399,DA,"I3")) Y="@78"
    72143 Q
    73 4 D:$D(DG)>9 F^DIE17,DE S DQ=4,DW="U2;6",DV="NJ11,2",DU="",DLB="TERTIARY PRIOR PAYMENT",DIFLD=220
    74  S DE(DW)="C4^IBXSC78"
     14418 D:$D(DG)>9 F^DIE17,DE S DQ=18,DW="U2;6",DV="NJ11,2",DU="",DLB="TERTIARY PRIOR PAYMENT",DIFLD=220
     145 S DE(DW)="C18^IBXSC78"
    75146 G RE
    76 C4 G C4S:$D(DE(4))[0 K DB
    77  S X=DE(4),DIC=DIE
     147C18 G C18S:$D(DE(18))[0 K DB
     148 S X=DE(18),DIC=DIE
    78149 K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIU-X X ^DD(399,220,1,1,2.4)
    79  S X=DE(4),DIC=DIE
     150 S X=DE(18),DIC=DIE
    80151 ;
    81 C4S S X="" G:DG(DQ)=X C4F1 K DB
    82  S X=DG(DQ),DIC=DIE
    83  K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIU+DIV X ^DD(399,220,1,1,1.4)
    84  S X=DG(DQ),DIC=DIE
    85  K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV S X="PRIOR PAYMENT(S)" X ^DD(399,220,1,2,1.4)
    86 C4F1 Q
    87 X4 S:X["$" X=$P(X,"$",2) K:X'?.N.1".".2N!(X>99999999)!(X<0) X
     152C18S S X="" G:DG(DQ)=X C18F1 K DB
     153 D ^IBXSC710
     154C18F1 Q
     155X18 S:X["$" X=$P(X,"$",2) K:X'?.N.1".".2N!(X>99999999)!(X<0) X
    88156 Q
    89157 ;
    90 5 S DQ=6 ;@78
    91 6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 D X6 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
    92 X6 K DIE("NO^")
     15819 S DQ=20 ;@78
     15920 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=20 D X20 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
     160X20 K DIE("NO^")
    93161 Q
    94 7 G 0^DIE17
     16221 G 0^DIE17

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC79.m

    r613 r623  
    1 IBXSC79 ; ;12/13/08
     1IBXSC79 ; ;12/27/07
    22 D DE G BEGIN
    33DE S DIE="^DGCR(399,D0,""RC"",",DIC=DIE,DP=399.042,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGCR(399,D0,"RC",DA,""))=""

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX.m

    r613 r623  
    1 IBXX ; DRIVER FOR COMPILED XREFS FOR FILE #399 ; 01/03/09
     1IBXX ; DRIVER FOR COMPILED XREFS FOR FILE #399 ; 12/27/07
    22 ;
    33 N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
    … …  
    77DI S DIKM1=0,DIKUM=0,DA(0)="",DV=0 F  S DV=$O(DA(DV)) Q:DV'>0  S DIKUM=DIKUM+1,DIKUP(DV)=DA(DV)
    88 S:DV="" DV=-1 S DH(1)=399,DIKUP=DA
    9  I $D(DIKKS) D:DIKZ1=DH(1) ^IBXX1 S DA=DIKUP D:DIKZ1=DH(1) ^IBXX15 D:DIKZ1'=DH(1) KILL D:DIKZ1'=DH(1) DA D:DIKZ1'=DH(1) SET D DA Q
     9 I $D(DIKKS) D:DIKZ1=DH(1) ^IBXX1 S DA=DIKUP D:DIKZ1=DH(1) ^IBXX14 D:DIKZ1'=DH(1) KILL D:DIKZ1'=DH(1) DA D:DIKZ1'=DH(1) SET D DA Q
    1010 I $D(DIKIL) D:DIKZ1=DH(1) ^IBXX1 S:DIKZ1=DH(1) DIKM1=1 D:DIKZ1'=DH(1) KILL S DA=DIKUP D:DIKM1>0 KIL1 D DA Q
    11  I $D(DIKST) D:DIKZ1=DH(1) ^IBXX15 D:DIKZ1'=DH(1) SET D DA Q
     11 I $D(DIKST) D:DIKZ1=DH(1) ^IBXX14 D:DIKZ1'=DH(1) SET D DA Q
    1212 I $D(DIKSAT) D SET1 D DA Q
    1313 Q
    … …  
    1717 S DU=$E(DIK,1,$L(DIK)-1),DIKLK=$S(DIK[",":DU_")",1:DU) L +@DIKLK:10 K:'$T DIKLK
    1818C I @("$O("_DIK_"DA))'>0") S DA=$$C1(DA),^(0)=$P(@(DIK_"0)"),U,1,2)_U_DA_U_DCNT K DCNT L:$D(DIKLK) -@DIKLK Q
    19  S (DIKY,DA)=$O(^(DA)) G C:$P($G(^(DA,0)),U)']"" S DU=1,DCNT=DCNT+1 S:DA="" (DIKY,DA)=-1 D:DIKZ1=DH(1) ^IBXX15 D:DIKZ1'=DH(1) SET D:DIKZ1'=DH(1) DA K DB(0) S DA=DIKY G C
     19 S (DIKY,DA)=$O(^(DA)) G C:$P($G(^(DA,0)),U)']"" S DU=1,DCNT=DCNT+1 S:DA="" (DIKY,DA)=-1 D:DIKZ1=DH(1) ^IBXX14 D:DIKZ1'=DH(1) SET D:DIKZ1'=DH(1) DA K DB(0) S DA=DIKY G C
    2020 Q
    2121C1(A) Q:$P($G(@(DIK_"A,0)")),U)]"" A
    … …  
    2424KILL S DIKILL=1,DIKZK=2
    2525 I DIKZ1=399.0222,DIKUM'<1 S DIKM1=1 D A1^IBXX3 Q
    26  I DIKZ1=399.0304,DIKUM'<1 S DIKM1=1 D A1^IBXX4,A1^IBXX14 Q
     26 I DIKZ1=399.0304,DIKUM'<1 S DIKM1=1 D A1^IBXX4,A1^IBXX13 Q
    2727 I DIKZ1=399.041,DIKUM'<1 S DIKM1=1 D A1^IBXX5 Q
    2828 I DIKZ1=399.042,DIKUM'<1 S DIKM1=1 D A1^IBXX6 Q
    … …  
    3333 I DIKZ1=399.047,DIKUM'<1 S DIKM1=1 D A1^IBXX11 Q
    3434 I DIKZ1=399.048,DIKUM'<1 S DIKM1=1 D A1^IBXX12 Q
    35  I DIKZ1=399.077,DIKUM'<1 S DIKM1=1 D A1^IBXX13 Q
    36  I DIKZ1=399.30416,DIKUM'<2 S DIKM1=2 D A1^IBXX14 Q
     35 I DIKZ1=399.30416,DIKUM'<2 S DIKM1=2 D A1^IBXX13 Q
    3736 Q
    3837SET S DISET=1,DIKZK=1 K DIKPUSH
    3938 I DIKZ1=399.0222,DIKUM'<1 S DIKM1=1 D A1^IBXX18 Q
    40  I DIKZ1=399.0304,DIKUM'<1 S DIKM1=1 D A1^IBXX19,A1^IBXX29 Q
     39 I DIKZ1=399.0304,DIKUM'<1 S DIKM1=1 D A1^IBXX19,A1^IBXX28 Q
    4140 I DIKZ1=399.041,DIKUM'<1 S DIKM1=1 D A1^IBXX20 Q
    4241 I DIKZ1=399.042,DIKUM'<1 S DIKM1=1 D A1^IBXX21 Q
    … …  
    4746 I DIKZ1=399.047,DIKUM'<1 S DIKM1=1 D A1^IBXX26 Q
    4847 I DIKZ1=399.048,DIKUM'<1 S DIKM1=1 D A1^IBXX27 Q
    49  I DIKZ1=399.077,DIKUM'<1 S DIKM1=1 D A1^IBXX28 Q
    50  I DIKZ1=399.30416,DIKUM'<2 S DIKM1=2 D A1^IBXX29 Q
     48 I DIKZ1=399.30416,DIKUM'<2 S DIKM1=2 D A1^IBXX28 Q
    5149 Q
    5250KIL1 K @(DIK_"DA)") Q:'$D(^(0))

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX1.m

    r613 r623  
    1 IBXX1 ; COMPILED XREF FOR FILE #399 ; 01/03/09
     1IBXX1 ; COMPILED XREF FOR FILE #399 ; 12/27/07
    22 ;
    33 S DIKZK=2
    … …  
    171171 S DIKZ("U2")=$G(^DGCR(399,DA,"U2"))
    172172 S X=$P(DIKZ("U2"),U,4)
    173  I X'="" D
    174  .N DIK,DIV,DIU,DIN
    175  .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIU-X X ^DD(399,218,1,1,2.4)
    176  S DIKZ("U2")=$G(^DGCR(399,DA,"U2"))
    177  S X=$P(DIKZ("U2"),U,5)
    178  I X'="" D
    179  .N DIK,DIV,DIU,DIN
    180  .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIU-X X ^DD(399,219,1,1,2.4)
    181  S DIKZ("U2")=$G(^DGCR(399,DA,"U2"))
    182  S X=$P(DIKZ("U2"),U,6)
    183  I X'="" D
    184  .N DIK,DIV,DIU,DIN
    185  .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIU-X X ^DD(399,220,1,1,2.4)
    186  S DIKZ("U2")=$G(^DGCR(399,DA,"U2"))
    187  S X=$P(DIKZ("U2"),U,10)
    188  I X'="" D
    189  .N DIK,DIV,DIU,DIN
    190  .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U2")):^("U2"),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y S X="" X ^DD(399,232,1,1,2.4)
    191  S X=$P(DIKZ("U2"),U,10)
    192  I X'="" D
    193  .N DIK,DIV,DIU,DIN
    194  .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U2")):^("U2"),1:"") S X=$P(Y(1),U,11),X=X S DIU=X K Y S X="" X ^DD(399,232,1,2,2.4)
    195  S X=$P(DIKZ("U2"),U,10)
    196  I X'="" D
    197  .N DIK,DIV,DIU,DIN
    198  .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=$$CLIAREQ^IBCEP8A(DA) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U2")):^("U2"),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$CLIA^IBCEP8A(DA) X ^DD(399,232,1,3,2.4)
    199  S X=$P(DIKZ("U2"),U,10)
    200  I X'="" D
    201  .N DIK,DIV,DIU,DIN
    202  .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U3")):^("U3"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X="" S DIH=$G(^DGCR(399,DIV(0),"U3")),DIV=X S $P(^("U3"),U,3)=DIV,DIH=399,DIG=244 D ^DICR
    203  S DIKZ("M1")=$G(^DGCR(399,DA,"M1"))
    204  S X=$P(DIKZ("M1"),U,8)
    205  I X'="" K ^DGCR(399,"AG",$E(X,1,30),DA)
    206  S DIKZ(0)=$G(^DGCR(399,DA,0))
    207  S X=$P(DIKZ(0),U,1)
    208  I X'="" K ^DGCR(399,"B",$E(X,1,30),DA)
    209 CR1 S DIXR=139
    210  K X
    211  S DIKZ("M")=$G(^DGCR(399,DA,"M"))
    212  S X(1)=$P(DIKZ("M"),U,1)
    213  S X(2)=$P(DIKZ("M"),U,2)
    214  S X(3)=$P(DIKZ("M"),U,3)
    215  S X(4)=$P(DIKZ("M"),U,13)
    216  S X(5)=$P(DIKZ("M"),U,12)
    217  S X(6)=$P(DIKZ("M"),U,14)
    218  S X=$G(X(1))
    219173END G ^IBXX2

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX10.m

    r613 r623  
    1 IBXX10 ; COMPILED XREF FOR FILE #399.046 ; 01/03/09
     1IBXX10 ; COMPILED XREF FOR FILE #399.046 ; 12/27/07
    22 ;
    33 S DA=0

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX11.m

    r613 r623  
    1 IBXX11 ; COMPILED XREF FOR FILE #399.047 ; 01/03/09
     1IBXX11 ; COMPILED XREF FOR FILE #399.047 ; 12/27/07
    22 ;
    33 S DA=0

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX12.m

    r613 r623  
    1 IBXX12 ; COMPILED XREF FOR FILE #399.048 ; 01/03/09
     1IBXX12 ; COMPILED XREF FOR FILE #399.048 ; 12/27/07
    22 ;
    33 S DA=0

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX13.m

    r613 r623  
    1 IBXX13 ; COMPILED XREF FOR FILE #399.077 ; 01/03/09
     1IBXX13 ; COMPILED XREF FOR FILE #399.30416 ; 12/27/07
    22 ;
    3  S DA=0
     3 S DA(2)=DA(1) S DA(1)=0 S DA=0
    44A1 ;
    5  I $D(DIKILL) K DIKLM S:DIKM1=1 DIKLM=1 G @DIKM1
    6 0 ;
    7 A S DA=$O(^DGCR(399,DA(1),"TXC",DA)) I DA'>0 S DA=0 G END
     5 I $D(DIKILL) K DIKLM S:DIKM1=2 DIKLM=1 S:DIKM1'=2&'$G(DIKPUSH(2)) DIKPUSH(2)=1,DA(2)=DA(1),DA(1)=DA,DA=0 G @DIKM1
     6A S DA(1)=$O(^DGCR(399,DA(2),"CP",DA(1))) I DA(1)'>0 S DA(1)=0 G END
    871 ;
    9  S DIKZ(0)=$G(^DGCR(399,DA(1),"TXC",DA,0))
     8B S DA=$O(^DGCR(399,DA(2),"CP",DA(1),"MOD",DA)) I DA'>0 S DA=0 Q:DIKM1=1  G A
     92 ;
     10 S DIKZ(0)=$G(^DGCR(399,DA(2),"CP",DA(1),"MOD",DA,0))
     11 S X=$P(DIKZ(0),U,2)
     12 I X'="" K ^DGCR(399,DA(2),"CP",DA(1),"MOD","C",$E(X,1,30),DA)
    1013 S X=$P(DIKZ(0),U,1)
    11  I X'="" K ^DGCR(399,DA(1),"TXC","B",$E(X,1,30),DA)
    12  G:'$D(DIKLM) A Q:$D(DIKILL)
    13 END G ^IBXX14
     14 I X'="" K ^DGCR(399,DA(2),"CP",DA(1),"MOD","B",$E(X,1,30),DA)
     15 G:'$D(DIKLM) B Q:$D(DIKILL)
     16END Q

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX14.m

    r613 r623  
    1 IBXX14 ; COMPILED XREF FOR FILE #399.30416 ; 01/03/09
     1IBXX14 ; COMPILED XREF FOR FILE #399 ; 12/27/07
    22 ;
    3  S DA(2)=DA(1) S DA(1)=0 S DA=0
    4 A1 ;
    5  I $D(DIKILL) K DIKLM S:DIKM1=2 DIKLM=1 S:DIKM1'=2&'$G(DIKPUSH(2)) DIKPUSH(2)=1,DA(2)=DA(1),DA(1)=DA,DA=0 G @DIKM1
    6 A S DA(1)=$O(^DGCR(399,DA(2),"CP",DA(1))) I DA(1)'>0 S DA(1)=0 G END
    7 1 ;
    8 B S DA=$O(^DGCR(399,DA(2),"CP",DA(1),"MOD",DA)) I DA'>0 S DA=0 Q:DIKM1=1  G A
    9 2 ;
    10  S DIKZ(0)=$G(^DGCR(399,DA(2),"CP",DA(1),"MOD",DA,0))
     3 S DIKZK=1
     4 S DIKZ(0)=$G(^DGCR(399,DA,0))
     5 S X=$P(DIKZ(0),U,1)
     6 I X'="" S ^DGCR(399,"B",$E(X,1,30),DA)=""
     7 S X=$P(DIKZ(0),U,1)
     8 I X'="" D
     9 .N DIK,DIV,DIU,DIN
     10 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,1)="" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X=DIV S X=DT X ^DD(399,.01,1,3,1.4)
     11 S X=$P(DIKZ(0),U,1)
     12 I X'="" D
     13 .N DIK,DIV,DIU,DIN
     14 .X ^DD(399,.01,1,4,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=$S(($D(DUZ)#2):DUZ,1:"") X ^DD(399,.01,1,4,1.4)
     15 S X=$P(DIKZ(0),U,1)
     16 I X'="" D
     17 .N DIK,DIV,DIU,DIN
     18 .X ^DD(399,.01,1,5,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,14),X=X S DIU=X K Y S X=DIV S X=$S($D(^IBE(350.9,1,1)):$P(^(1),U,6),1:"") X ^DD(399,.01,1,5,1.4)
     19 S X=$P(DIKZ(0),U,1)
     20 I X'="" D
     21 .N DIK,DIV,DIU,DIN
     22 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=1 S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,13)=DIV,DIH=399,DIG=.13 D ^DICR
     23 S X=$P(DIKZ(0),U,1)
     24 I X'="" D
     25 .N DIK,DIV,DIU,DIN
     26 .X ^DD(399,.01,1,7,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,19),X=X S DIU=X K Y S X=DIV S X=3 S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,19)=DIV,DIH=399,DIG=.19 D ^DICR
     27 S DIKZ(0)=$G(^DGCR(399,DA,0))
    1128 S X=$P(DIKZ(0),U,2)
    12  I X'="" K ^DGCR(399,DA(2),"CP",DA(1),"MOD","C",$E(X,1,30),DA)
    13  S X=$P(DIKZ(0),U,1)
    14  I X'="" K ^DGCR(399,DA(2),"CP",DA(1),"MOD","B",$E(X,1,30),DA)
    15  G:'$D(DIKLM) B Q:$D(DIKILL)
    16 END Q
     29 I X'="" S ^DGCR(399,"C",$E(X,1,30),DA)=""
     30 S X=$P(DIKZ(0),U,3)
     31 I X'="" S ^DGCR(399,"D",$E(X,1,30),DA)=""
     32 S X=$P(DIKZ(0),U,3)
     33 I X'="" S IBN=$P(^DGCR(399,DA,0),"^",2) S:$D(IBN) ^DGCR(399,"APDT",IBN,DA,9999999-X)="" K IBN
     34 S X=$P(DIKZ(0),U,3)
     35 I X'="" S ^DGCR(399,"ABNDT",DA,9999999-X)=""
     36 S X=$P(DIKZ(0),U,4)
     37 I X'="" D
     38 .N DIK,DIV,DIU,DIN
     39 .X ^DD(399,.04,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,24),X=X S DIU=X K Y S X=DIV S X=DIV,X=X S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,24)=DIV,DIH=399,DIG=.24 D ^DICR
     40 S DIKZ(0)=$G(^DGCR(399,DA,0))
     41 S X=$P(DIKZ(0),U,5)
     42 I X'="" S ^DGCR(399,"ABT",$E(X,1,30),DA)=""
     43 S X=$P(DIKZ(0),U,5)
     44 I X'="" D
     45 .N DIK,DIV,DIU,DIN
     46 .X ^DD(399,.05,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,25),X=X S DIU=X K Y S X=DIV S X=$$TRIG05^IBCU4(X,D0) S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,25)=DIV,DIH=399,DIG=.25 D ^DICR
     47 S DIKZ(0)=$G(^DGCR(399,DA,0))
     48 S X=$P(DIKZ(0),U,6)
     49 I X'="" D
     50 .N DIK,DIV,DIU,DIN
     51 .X ^DD(399,.06,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,26),X=X S DIU=X K Y S X=DIV S X=DIV,X=X S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,26)=DIV,DIH=399,DIG=.26 D ^DICR
     52 S DIKZ(0)=$G(^DGCR(399,DA,0))
     53 S X=$P(DIKZ(0),U,7)
     54 I X'="" D
     55 .N DIK,DIV,DIU,DIN
     56 .X ^DD(399,.07,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,6),X=X S DIU=X K Y S X=DIV S X=1 X ^DD(399,.07,1,1,1.4)
     57 S X=$P(DIKZ(0),U,7)
     58 I X'="" D
     59 .N DIK,DIV,DIU,DIN
     60 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,11),X=X S DIU=X K Y S X=DIV S X=$P(^DGCR(399.3,$P(^DGCR(399,DA,0),U,7),0),U,7) X ^DD(399,.07,1,2,1.4)
     61 S X=$P(DIKZ(0),U,7)
     62 I X'="" S ^DGCR(399,"AD",$E(X,1,30),DA)=""
     63 S DIKZ(0)=$G(^DGCR(399,DA,0))
     64 S X=$P(DIKZ(0),U,8)
     65 I X'="" D
     66 .N DIK,DIV,DIU,DIN
     67 .X ^DD(399,.08,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,9),X=X S DIU=X K Y S X=DIV S X=2 X ^DD(399,.08,1,1,1.4)
     68 S X=$P(DIKZ(0),U,8)
     69 I X'="" D
     70 .N DIK,DIV,DIU,DIN
     71 .X ^DD(399,.08,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,8),X=X S DIU=X K Y S X=DIV S X=2 X ^DD(399,.08,1,2,1.4)
     72 S X=$P(DIKZ(0),U,8)
     73 I X'="" D
     74 .N DIK,DIV,DIU,DIN
     75 .X ^DD(399,.08,1,4,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y S X=DIV D DIS^IBCU S X=X X ^DD(399,.08,1,4,1.4)
     76 S X=$P(DIKZ(0),U,8)
     77 I X'="" S ^DGCR(399,"APTF",$E(X,1,30),DA)=""
     78 S X=$P(DIKZ(0),U,8)
     79 I X'="" D
     80 .N DIK,DIV,DIU,DIN
     81 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I $P(^DGCR(399,DA,0),U,5)<3 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X=DIV S X=+$$LOS1^IBCU64(DA) X ^DD(399,.08,1,6,1.4)
     82 S DIKZ(0)=$G(^DGCR(399,DA,0))
     83 S X=$P(DIKZ(0),U,11)
     84 I X'="" D
     85 .N DIK,DIV,DIU,DIN
     86 .X ^DD(399,.11,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"M")):^("M"),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y S X=DIV D EN1^IBCU5 X ^DD(399,.11,1,1,1.4)
     87 S X=$P(DIKZ(0),U,11)
     88 I X'="" D EN^IBCU5
     89 S X=$P(DIKZ(0),U,11)
     90 I X'="" S DGRVRCAL=1
     91 S X=$P(DIKZ(0),U,11)
     92 I X'="" D
     93 .N DIK,DIV,DIU,DIN
     94 .X ^DD(399,.11,1,4,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,21),X=X S DIU=X K Y X ^DD(399,.11,1,4,1.1) X ^DD(399,.11,1,4,1.4)
     95 S DIKZ(0)=$G(^DGCR(399,DA,0))
     96 S X=$P(DIKZ(0),U,13)
     97 I X'="" D
     98 .N DIK,DIV,DIU,DIN
     99 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,14),X=X S DIU=X K Y S X=DIV S X=DT X ^DD(399,.13,1,1,1.4)
     100 S X=$P(DIKZ(0),U,13)
     101 I X'="" I X>0,X<3,$P(^DGCR(399,DA,0),U,2) S ^DGCR(399,"AOP",$P(^(0),U,2),DA)=""
     102 S X=$P(DIKZ(0),U,13)
     103 I X'="" I +X=3 S ^DGCR(399,"AST",+X,DA)=""
     104 S X=$P(DIKZ(0),U,13)
     105 I X'="" D
     106 .N DIK,DIV,DIU,DIN
     107 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=Y(0),X=X S X=X=2 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"TX")):^("TX"),1:"") S X=$P(Y(1),U,5),X=X S DIU=X K Y S X=DIV S X="1N" X ^DD(399,.13,1,4,1.4)
     108 S DIKZ(0)=$G(^DGCR(399,DA,0))
     109 S X=$P(DIKZ(0),U,14)
     110 I X'="" D BC^IBJVDEQ
     111 S X=$P(DIKZ(0),U,17)
     112 I X'="" S ^DGCR(399,"AC",$E(X,1,30),DA)=""
     113 S X=$P(DIKZ(0),U,19)
     114 I X'="" D
     115 .N DIK,DIV,DIU,DIN
     116 .X ^DD(399,.19,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,9),X=X S DIU=X K Y S X=DIV S X=5 S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,9)=DIV,DIH=399,DIG=.09 D ^DICR
     117 S X=$P(DIKZ(0),U,19)
     118 I X'="" S DGRVRCAL=1
     119 S X=$P(DIKZ(0),U,19)
     120 I X'="" D ALLID^IBCEP3(DA,.19,1)
     121 S X=$P(DIKZ(0),U,19)
     122 I X'="" D BILLPNS^IBCU(DA)
     123 S X=$P(DIKZ(0),U,19)
     124 I X'="" D ATTREND^IBCU1(DA,"","")
     125 S DIKZ(0)=$G(^DGCR(399,DA,0))
     126 S X=$P(DIKZ(0),U,20)
     127 I X'="" D
     128 .N DIK,DIV,DIU,DIN
     129 .X ^DD(399,.2,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=.5 X ^DD(399,.2,1,1,1.4)
     130 S DIKZ(0)=$G(^DGCR(399,DA,0))
     131 S X=$P(DIKZ(0),U,21)
     132 I X'="" D
     133 .N DIK,DIV,DIU,DIN
     134 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"MP")):^("MP"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=$$BPP^IBCNS2(DA) X ^DD(399,.21,1,1,1.4)
     135 S X=$P(DIKZ(0),U,21)
     136 I X'="" D
     137 .N DIK,DIV,DIU,DIN
     138 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=('$$REQMRA^IBEFUNC(DA)&$$NEEDMRA^IBEFUNC(DA)) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"TX")):^("TX"),1:"") S X=$P(Y(1),U,5),X=X S DIU=X K Y S X=DIV S X=0 X ^DD(399,.21,1,2,1.4)
     139 S X=$P(DIKZ(0),U,21)
     140 I X'="" D
     141 .N DIK,DIV,DIU,DIN
     142 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=$S($$WNRBILL^IBEFUNC(DA,X):1,1:0) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"TX")):^("TX"),1:"") S X=$P(Y(1),U,8),X=X S DIU=X K Y S X="" X ^DD(399,.21,1,3,1.4)
     143 S DIKZ(0)=$G(^DGCR(399,DA,0))
     144 S X=$P(DIKZ(0),U,22)
     145 I X'="" D
     146 .N DIK,DIV,DIU,DIN
     147 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=$$PRVNUM^IBCU(DA,"",1) X ^DD(399,.22,1,1,1.4)
     148 S X=$P(DIKZ(0),U,22)
     149 I X'="" D
     150 .N DIK,DIV,DIU,DIN
     151 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV S X=$$PRVNUM^IBCU(DA,"",2) X ^DD(399,.22,1,2,1.4)
     152 S X=$P(DIKZ(0),U,22)
     153 I X'="" D
     154 .N DIK,DIV,DIU,DIN
     155 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X=DIV S X=$$PRVNUM^IBCU(DA,"",3) X ^DD(399,.22,1,3,1.4)
     156 S X=$P(DIKZ(0),U,22)
     157END G ^IBXX15

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX15.m

    r613 r623  
    1 IBXX15 ; COMPILED XREF FOR FILE #399 ; 01/03/09
     1IBXX15 ; COMPILED XREF FOR FILE #399.0222 ; 12/27/07
    22 ;
    3  S DIKZK=1
    4  S DIKZ(0)=$G(^DGCR(399,DA,0))
    5  S X=$P(DIKZ(0),U,1)
    6  I X'="" S ^DGCR(399,"B",$E(X,1,30),DA)=""
    7  S X=$P(DIKZ(0),U,1)
    8  I X'="" D
    9  .N DIK,DIV,DIU,DIN
    10  .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,1)="" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X=DIV S X=DT X ^DD(399,.01,1,3,1.4)
    11  S X=$P(DIKZ(0),U,1)
    12  I X'="" D
    13  .N DIK,DIV,DIU,DIN
    14  .X ^DD(399,.01,1,4,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=$S(($D(DUZ)#2):DUZ,1:"") X ^DD(399,.01,1,4,1.4)
    15  S X=$P(DIKZ(0),U,1)
    16  I X'="" D
    17  .N DIK,DIV,DIU,DIN
    18  .X ^DD(399,.01,1,5,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,14),X=X S DIU=X K Y S X=DIV S X=$S($D(^IBE(350.9,1,1)):$P(^(1),U,6),1:"") X ^DD(399,.01,1,5,1.4)
    19  S X=$P(DIKZ(0),U,1)
    20  I X'="" D
    21  .N DIK,DIV,DIU,DIN
    22  .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=1 S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,13)=DIV,DIH=399,DIG=.13 D ^DICR
    23  S X=$P(DIKZ(0),U,1)
    24  I X'="" D
    25  .N DIK,DIV,DIU,DIN
    26  .X ^DD(399,.01,1,7,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,19),X=X S DIU=X K Y S X=DIV S X=3 S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,19)=DIV,DIH=399,DIG=.19 D ^DICR
    27  S DIKZ(0)=$G(^DGCR(399,DA,0))
    28  S X=$P(DIKZ(0),U,2)
    29  I X'="" S ^DGCR(399,"C",$E(X,1,30),DA)=""
    30  S X=$P(DIKZ(0),U,3)
    31  I X'="" S ^DGCR(399,"D",$E(X,1,30),DA)=""
    32  S X=$P(DIKZ(0),U,3)
    33  I X'="" S IBN=$P(^DGCR(399,DA,0),"^",2) S:$D(IBN) ^DGCR(399,"APDT",IBN,DA,9999999-X)="" K IBN
    34  S X=$P(DIKZ(0),U,3)
    35  I X'="" S ^DGCR(399,"ABNDT",DA,9999999-X)=""
    36  S X=$P(DIKZ(0),U,4)
    37  I X'="" D
    38  .N DIK,DIV,DIU,DIN
    39  .X ^DD(399,.04,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,24),X=X S DIU=X K Y S X=DIV S X=DIV,X=X S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,24)=DIV,DIH=399,DIG=.24 D ^DICR
    40  S DIKZ(0)=$G(^DGCR(399,DA,0))
    41  S X=$P(DIKZ(0),U,5)
    42  I X'="" S ^DGCR(399,"ABT",$E(X,1,30),DA)=""
    43  S X=$P(DIKZ(0),U,5)
    44  I X'="" D
    45  .N DIK,DIV,DIU,DIN
    46  .X ^DD(399,.05,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,25),X=X S DIU=X K Y S X=DIV S X=$$TRIG05^IBCU4(X,D0) S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,25)=DIV,DIH=399,DIG=.25 D ^DICR
    47  S DIKZ(0)=$G(^DGCR(399,DA,0))
    48  S X=$P(DIKZ(0),U,6)
    49  I X'="" D
    50  .N DIK,DIV,DIU,DIN
    51  .X ^DD(399,.06,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,26),X=X S DIU=X K Y S X=DIV S X=DIV,X=X S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,26)=DIV,DIH=399,DIG=.26 D ^DICR
    52  S DIKZ(0)=$G(^DGCR(399,DA,0))
    53  S X=$P(DIKZ(0),U,7)
    54  I X'="" D
    55  .N DIK,DIV,DIU,DIN
    56  .X ^DD(399,.07,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,6),X=X S DIU=X K Y S X=DIV S X=1 X ^DD(399,.07,1,1,1.4)
    57  S X=$P(DIKZ(0),U,7)
    58  I X'="" D
    59  .N DIK,DIV,DIU,DIN
    60  .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,11),X=X S DIU=X K Y S X=DIV S X=$P(^DGCR(399.3,$P(^DGCR(399,DA,0),U,7),0),U,7) X ^DD(399,.07,1,2,1.4)
    61  S X=$P(DIKZ(0),U,7)
    62  I X'="" S ^DGCR(399,"AD",$E(X,1,30),DA)=""
    63  S DIKZ(0)=$G(^DGCR(399,DA,0))
    64  S X=$P(DIKZ(0),U,8)
    65  I X'="" D
    66  .N DIK,DIV,DIU,DIN
    67  .X ^DD(399,.08,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,9),X=X S DIU=X K Y S X=DIV S X=2 X ^DD(399,.08,1,1,1.4)
    68  S X=$P(DIKZ(0),U,8)
    69  I X'="" D
    70  .N DIK,DIV,DIU,DIN
    71  .X ^DD(399,.08,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,8),X=X S DIU=X K Y S X=DIV S X=2 X ^DD(399,.08,1,2,1.4)
    72  S X=$P(DIKZ(0),U,8)
    73  I X'="" D
    74  .N DIK,DIV,DIU,DIN
    75  .X ^DD(399,.08,1,4,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y S X=DIV D DIS^IBCU S X=X X ^DD(399,.08,1,4,1.4)
    76  S X=$P(DIKZ(0),U,8)
    77  I X'="" S ^DGCR(399,"APTF",$E(X,1,30),DA)=""
    78  S X=$P(DIKZ(0),U,8)
    79  I X'="" D
    80  .N DIK,DIV,DIU,DIN
    81  .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I $P(^DGCR(399,DA,0),U,5)<3 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X=DIV S X=+$$LOS1^IBCU64(DA) X ^DD(399,.08,1,6,1.4)
    82  S DIKZ(0)=$G(^DGCR(399,DA,0))
    83  S X=$P(DIKZ(0),U,11)
    84  I X'="" D
    85  .N DIK,DIV,DIU,DIN
    86  .X ^DD(399,.11,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"M")):^("M"),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y S X=DIV D EN1^IBCU5 X ^DD(399,.11,1,1,1.4)
    87  S X=$P(DIKZ(0),U,11)
    88  I X'="" D EN^IBCU5
    89  S X=$P(DIKZ(0),U,11)
    90  I X'="" S DGRVRCAL=1
    91  S X=$P(DIKZ(0),U,11)
    92  I X'="" D
    93  .N DIK,DIV,DIU,DIN
    94  .X ^DD(399,.11,1,4,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,21),X=X S DIU=X K Y X ^DD(399,.11,1,4,1.1) X ^DD(399,.11,1,4,1.4)
    95  S DIKZ(0)=$G(^DGCR(399,DA,0))
    96  S X=$P(DIKZ(0),U,13)
    97  I X'="" D
    98  .N DIK,DIV,DIU,DIN
    99  .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,14),X=X S DIU=X K Y S X=DIV S X=DT X ^DD(399,.13,1,1,1.4)
    100  S X=$P(DIKZ(0),U,13)
    101  I X'="" I X>0,X<3,$P(^DGCR(399,DA,0),U,2) S ^DGCR(399,"AOP",$P(^(0),U,2),DA)=""
    102  S X=$P(DIKZ(0),U,13)
    103  I X'="" I +X=3 S ^DGCR(399,"AST",+X,DA)=""
    104  S X=$P(DIKZ(0),U,13)
    105  I X'="" D
    106  .N DIK,DIV,DIU,DIN
    107  .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=Y(0),X=X S X=X=2 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"TX")):^("TX"),1:"") S X=$P(Y(1),U,5),X=X S DIU=X K Y S X=DIV S X="1N" X ^DD(399,.13,1,4,1.4)
    108  S DIKZ(0)=$G(^DGCR(399,DA,0))
    109  S X=$P(DIKZ(0),U,14)
    110  I X'="" D BC^IBJVDEQ
    111  S X=$P(DIKZ(0),U,17)
    112  I X'="" S ^DGCR(399,"AC",$E(X,1,30),DA)=""
    113  S X=$P(DIKZ(0),U,19)
    114  I X'="" D
    115  .N DIK,DIV,DIU,DIN
    116  .X ^DD(399,.19,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,9),X=X S DIU=X K Y S X=DIV S X=5 S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,9)=DIV,DIH=399,DIG=.09 D ^DICR
    117  S X=$P(DIKZ(0),U,19)
    118  I X'="" S DGRVRCAL=1
    119  S X=$P(DIKZ(0),U,19)
    120  I X'="" D ALLID^IBCEP3(DA,.19,1)
    121  S X=$P(DIKZ(0),U,19)
    122  I X'="" D BILLPNS^IBCU(DA)
    123  S X=$P(DIKZ(0),U,19)
    124  I X'="" D ATTREND^IBCU1(DA,"","")
    125  S DIKZ(0)=$G(^DGCR(399,DA,0))
    126  S X=$P(DIKZ(0),U,20)
    127  I X'="" D
    128  .N DIK,DIV,DIU,DIN
    129  .X ^DD(399,.2,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=.5 X ^DD(399,.2,1,1,1.4)
    130  S DIKZ(0)=$G(^DGCR(399,DA,0))
    131  S X=$P(DIKZ(0),U,21)
    132  I X'="" D
    133  .N DIK,DIV,DIU,DIN
    134  .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"MP")):^("MP"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=$$BPP^IBCNS2(DA) X ^DD(399,.21,1,1,1.4)
    135  S X=$P(DIKZ(0),U,21)
    136  I X'="" D
    137  .N DIK,DIV,DIU,DIN
    138  .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=('$$REQMRA^IBEFUNC(DA)&$$NEEDMRA^IBEFUNC(DA)) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"TX")):^("TX"),1:"") S X=$P(Y(1),U,5),X=X S DIU=X K Y S X=DIV S X=0 X ^DD(399,.21,1,2,1.4)
    139  S X=$P(DIKZ(0),U,21)
    140  I X'="" D
    141  .N DIK,DIV,DIU,DIN
    142  .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=$S($$WNRBILL^IBEFUNC(DA,X):1,1:0) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"TX")):^("TX"),1:"") S X=$P(Y(1),U,8),X=X S DIU=X K Y S X="" X ^DD(399,.21,1,3,1.4)
    143  S DIKZ(0)=$G(^DGCR(399,DA,0))
    144  S X=$P(DIKZ(0),U,22)
    145  I X'="" D
    146  .N DIK,DIV,DIU,DIN
    147  .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=$$PRVNUM^IBCU(DA,"",1) X ^DD(399,.22,1,1,1.4)
    148  S X=$P(DIKZ(0),U,22)
    149  I X'="" D
    150  .N DIK,DIV,DIU,DIN
    151  .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV S X=$$PRVNUM^IBCU(DA,"",2) X ^DD(399,.22,1,2,1.4)
    152  S X=$P(DIKZ(0),U,22)
    153  I X'="" D
    154  .N DIK,DIV,DIU,DIN
    155  .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X=DIV S X=$$PRVNUM^IBCU(DA,"",3) X ^DD(399,.22,1,3,1.4)
    156  S X=$P(DIKZ(0),U,22)
    1573 I X'="" D
    1584 .N DIK,DIV,DIU,DIN
    … …  
    19036 I X'="" S ^DGCR(399,"APD",$E(X,1,30),DA)=""
    19137 S X=$P(DIKZ("S"),U,3)
     38 I X'="" D
     39 .N DIK,DIV,DIU,DIN
     40 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,4)="" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X=DIV S X=DT X ^DD(399,3,1,1,1.4)
     41 S X=$P(DIKZ("S"),U,3)
     42 I X'="" D
     43 .N DIK,DIV,DIU,DIN
     44 .X ^DD(399,3,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,5),X=X S DIU=X K Y S X=DIV S X=DUZ X ^DD(399,3,1,2,1.4)
     45 S DIKZ("S")=$G(^DGCR(399,DA,"S"))
     46 S X=$P(DIKZ("S"),U,7)
     47 I X'="" S ^DGCR(399,"APM",$E(X,1,30),DA)=""
     48 S X=$P(DIKZ("S"),U,9)
     49 I X'="" D
     50 .N DIK,DIV,DIU,DIN
     51 .X ^DD(399,9,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,10),X=X S DIU=X K Y S X=DIV S X=DT X ^DD(399,9,1,1,1.4)
     52 S X=$P(DIKZ("S"),U,9)
     53 I X'="" D
     54 .N DIK,DIV,DIU,DIN
     55 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X X ^DD(399,9,1,2,69.2) S X=X="YES",Y=X,X=Y(2),X=X&Y I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,11),X=X S DIU=X K Y S X=DIV S X=DUZ X ^DD(399,9,1,2,1.4)
     56 S X=$P(DIKZ("S"),U,9)
     57 I X'="" D
     58 .N DIK,DIV,DIU,DIN
     59 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y=Y(0) X:$D(^DD(399,9,2)) ^(2) S X=Y="YES" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=3 X ^DD(399,9,1,3,1.4)
     60 S X=$P(DIKZ("S"),U,9)
     61 I X'="" D
     62 .N DIK,DIV,DIU,DIN
     63 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=$$EXTERNAL^DIDU(399,9,"",Y(0))="YES" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"TX")):^("TX"),1:"") S X=$P(Y(1),U,6),X=X S DIU=X K Y S X="" X ^DD(399,9,1,4,1.4)
     64 S DIKZ("S")=$G(^DGCR(399,DA,"S"))
     65 S X=$P(DIKZ("S"),U,10)
     66 I X'="" S ^DGCR(399,"APD3",$E(X,1,30),DA)=""
     67 S X=$P(DIKZ("S"),U,12)
     68 I X'="" D
     69 .N DIK,DIV,DIU,DIN
     70 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,14)="" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,14),X=X S DIU=X K Y S X=DIV S X=DT X ^DD(399,12,1,1,1.4)
     71 S X=$P(DIKZ("S"),U,12)
     72 I X'="" D
     73 .N DIK,DIV,DIU,DIN
     74 .X ^DD(399,12,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X=DIV S X=DUZ S DIH=$G(^DGCR(399,DIV(0),"S")),DIV=X S $P(^("S"),U,15)=DIV,DIH=399,DIG=15 D ^DICR
     75 S X=$P(DIKZ("S"),U,12)
     76 I X'="" D
     77 .N DIK,DIV,DIU,DIN
     78 .X ^DD(399,12,1,3,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=DUZ S DIH=$G(^DGCR(399,DIV(0),"S")),DIV=X S $P(^("S"),U,13)=DIV,DIH=399,DIG=13 D ^DICR
     79 S X=$P(DIKZ("S"),U,12)
     80 I X'="" S ^DGCR(399,"AP",$E(X,1,30),DA)=""
     81 S DIKZ("S")=$G(^DGCR(399,DA,"S"))
     82 S X=$P(DIKZ("S"),U,14)
     83 I X'="" D
     84 .N DIK,DIV,DIU,DIN
     85 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=4 S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,13)=DIV,DIH=399,DIG=.13 D ^DICR
     86 S X=$P(DIKZ("S"),U,14)
     87 I X'="" D
     88 .N DIK,DIV,DIU,DIN
     89 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X=DIV S X=DUZ S DIH=$G(^DGCR(399,DIV(0),"S")),DIV=X S $P(^("S"),U,15)=DIV,DIH=399,DIG=15 D ^DICR
     90 S DIKZ("S")=$G(^DGCR(399,DA,"S"))
     91 S X=$P(DIKZ("S"),U,16)
     92 I X'="" D
     93 .N DIK,DIV,DIU,DIN
     94 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=$$EXTERNAL^DIDU(399,16,"",Y(0))="YES" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,17),X=X S DIU=X K Y S X=DIV S X=DT X ^DD(399,16,1,1,1.4)
     95 S X=$P(DIKZ("S"),U,16)
     96 I X'="" D
     97 .N DIK,DIV,DIU,DIN
     98 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=$$EXTERNAL^DIDU(399,16,"",Y(0))="YES" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,18),X=X S DIU=X K Y S X=DIV S X=DUZ X ^DD(399,16,1,2,1.4)
     99 S DIKZ("S")=$G(^DGCR(399,DA,"S"))
     100 S X=$P(DIKZ("S"),U,17)
     101 I X'="" D
     102 .N DIK,DIV,DIU,DIN
     103 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,16),X=X S X=X=1 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=7 X ^DD(399,17,1,1,1.4)
     104 S DIKZ("TX")=$G(^DGCR(399,DA,"TX"))
     105 S X=$P(DIKZ("TX"),U,2)
     106 I X'="" S ^DGCR(399,"ALEX",$E(X,1,30),DA)=""
     107 S X=$P(DIKZ("TX"),U,5)
     108 I X'="" D
     109 .N DIK,DIV,DIU,DIN
     110 .X ^DD(399,24,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"TX")):^("TX"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV S X=DT X ^DD(399,24,1,1,1.4)
     111 S DIKZ("TX")=$G(^DGCR(399,DA,"TX"))
     112 S X=$P(DIKZ("TX"),U,6)
     113 I X'="" D
     114 .N DIK,DIV,DIU,DIN
     115 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=Y(0),X=X S X=X=1 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=2 X ^DD(399,25,1,1,1.4)
     116 S X=$P(DIKZ("TX"),U,6)
     117 I X'="" D
     118 .N DIK,DIV,DIU,DIN
     119 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X X ^DD(399,25,1,2,69.2) S X=X S X=X="",Y=X,X=Y(2),X=X&Y I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,8),X=X S DIU=X K Y S X=DIV S X=DUZ X ^DD(399,25,1,2,1.4)
     120 S X=$P(DIKZ("TX"),U,6)
     121 I X'="" D
     122 .N DIK,DIV,DIU,DIN
     123 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X X ^DD(399,25,1,3,69.2) S X=X S X=X="",Y=X,X=Y(2),X=X&Y I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,7),X=X S DIU=X K Y S X=DIV S X=DT X ^DD(399,25,1,3,1.4)
     124 S DIKZ("C")=$G(^DGCR(399,DA,"C"))
     125 S X=$P(DIKZ("C"),U,14)
     126 I X'="" D
     127 .N DIK,DIV,DIU,DIN
     128 .X ^DD(399,64,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"C")):^("C"),1:"") S X=$P(Y(1),U,10),X=X S DIU=X K Y S X=DIV S X=$P(^ICD9(+X,0),"^",3) X ^DD(399,64,1,1,1.4)
     129 S DIKZ("M")=$G(^DGCR(399,DA,"M"))
     130 S X=$P(DIKZ("M"),U,1)
     131 I X'="" D
     132 .N DIK,DIV,DIU,DIN
     133 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=$$PRVNUM^IBCU(DA,X,1) X ^DD(399,101,1,1,1.4)
     134 S X=$P(DIKZ("M"),U,1)
    192135END G ^IBXX16

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX16.m

    r613 r623  
    1 IBXX16 ; COMPILED XREF FOR FILE #399.0222 ; 01/03/09
     1IBXX16 ; COMPILED XREF FOR FILE #399.0222 ; 12/27/07
    22 ;
    3 END G ^IBXX16
    4  .N DIK,DIV,DIU,DIN
    5  .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,4)="" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X=DIV S X=DT X ^DD(399,3,1,1,1.4)
    6  S X=$P(DIKZ("S"),U,3)
    7  I X'="" D
    8  .N DIK,DIV,DIU,DIN
    9  .X ^DD(399,3,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,5),X=X S DIU=X K Y S X=DIV S X=DUZ X ^DD(399,3,1,2,1.4)
    10  S DIKZ("S")=$G(^DGCR(399,DA,"S"))
    11  S X=$P(DIKZ("S"),U,7)
    12  I X'="" S ^DGCR(399,"APM",$E(X,1,30),DA)=""
    13  S X=$P(DIKZ("S"),U,9)
    14  I X'="" D
    15  .N DIK,DIV,DIU,DIN
    16  .X ^DD(399,9,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,10),X=X S DIU=X K Y S X=DIV S X=DT X ^DD(399,9,1,1,1.4)
    17  S X=$P(DIKZ("S"),U,9)
    18  I X'="" D
    19  .N DIK,DIV,DIU,DIN
    20  .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X X ^DD(399,9,1,2,69.2) S X=X="YES",Y=X,X=Y(2),X=X&Y I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,11),X=X S DIU=X K Y S X=DIV S X=DUZ X ^DD(399,9,1,2,1.4)
    21  S X=$P(DIKZ("S"),U,9)
    22  I X'="" D
    23  .N DIK,DIV,DIU,DIN
    24  .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y=Y(0) X:$D(^DD(399,9,2)) ^(2) S X=Y="YES" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=3 X ^DD(399,9,1,3,1.4)
    25  S X=$P(DIKZ("S"),U,9)
    26  I X'="" D
    27  .N DIK,DIV,DIU,DIN
    28  .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=$$EXTERNAL^DIDU(399,9,"",Y(0))="YES" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"TX")):^("TX"),1:"") S X=$P(Y(1),U,6),X=X S DIU=X K Y S X="" X ^DD(399,9,1,4,1.4)
    29  S DIKZ("S")=$G(^DGCR(399,DA,"S"))
    30  S X=$P(DIKZ("S"),U,10)
    31  I X'="" S ^DGCR(399,"APD3",$E(X,1,30),DA)=""
    32  S X=$P(DIKZ("S"),U,12)
    33  I X'="" D
    34  .N DIK,DIV,DIU,DIN
    35  .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,14)="" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,14),X=X S DIU=X K Y S X=DIV S X=DT X ^DD(399,12,1,1,1.4)
    36  S X=$P(DIKZ("S"),U,12)
    37  I X'="" D
    38  .N DIK,DIV,DIU,DIN
    39  .X ^DD(399,12,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X=DIV S X=DUZ S DIH=$G(^DGCR(399,DIV(0),"S")),DIV=X S $P(^("S"),U,15)=DIV,DIH=399,DIG=15 D ^DICR
    40  S X=$P(DIKZ("S"),U,12)
    41  I X'="" D
    42  .N DIK,DIV,DIU,DIN
    43  .X ^DD(399,12,1,3,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=DUZ S DIH=$G(^DGCR(399,DIV(0),"S")),DIV=X S $P(^("S"),U,13)=DIV,DIH=399,DIG=13 D ^DICR
    44  S X=$P(DIKZ("S"),U,12)
    45  I X'="" S ^DGCR(399,"AP",$E(X,1,30),DA)=""
    46  S DIKZ("S")=$G(^DGCR(399,DA,"S"))
    47  S X=$P(DIKZ("S"),U,14)
    48  I X'="" D
    49  .N DIK,DIV,DIU,DIN
    50  .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=4 S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,13)=DIV,DIH=399,DIG=.13 D ^DICR
    51  S X=$P(DIKZ("S"),U,14)
    52  I X'="" D
    53  .N DIK,DIV,DIU,DIN
    54  .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X=DIV S X=DUZ S DIH=$G(^DGCR(399,DIV(0),"S")),DIV=X S $P(^("S"),U,15)=DIV,DIH=399,DIG=15 D ^DICR
    55  S DIKZ("S")=$G(^DGCR(399,DA,"S"))
    56  S X=$P(DIKZ("S"),U,16)
    57  I X'="" D
    58  .N DIK,DIV,DIU,DIN
    59  .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=$$EXTERNAL^DIDU(399,16,"",Y(0))="YES" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,17),X=X S DIU=X K Y S X=DIV S X=DT X ^DD(399,16,1,1,1.4)
    60  S X=$P(DIKZ("S"),U,16)
    61  I X'="" D
    62  .N DIK,DIV,DIU,DIN
    63  .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=$$EXTERNAL^DIDU(399,16,"",Y(0))="YES" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,18),X=X S DIU=X K Y S X=DIV S X=DUZ X ^DD(399,16,1,2,1.4)
    64  S DIKZ("S")=$G(^DGCR(399,DA,"S"))
    65  S X=$P(DIKZ("S"),U,17)
    66  I X'="" D
    67  .N DIK,DIV,DIU,DIN
    68  .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,16),X=X S X=X=1 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=7 X ^DD(399,17,1,1,1.4)
    69  S DIKZ("TX")=$G(^DGCR(399,DA,"TX"))
    70  S X=$P(DIKZ("TX"),U,2)
    71  I X'="" S ^DGCR(399,"ALEX",$E(X,1,30),DA)=""
    72  S X=$P(DIKZ("TX"),U,5)
    73  I X'="" D
    74  .N DIK,DIV,DIU,DIN
    75  .X ^DD(399,24,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"TX")):^("TX"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV S X=DT X ^DD(399,24,1,1,1.4)
    76  S DIKZ("TX")=$G(^DGCR(399,DA,"TX"))
    77  S X=$P(DIKZ("TX"),U,6)
    78  I X'="" D
    79  .N DIK,DIV,DIU,DIN
    80  .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=Y(0),X=X S X=X=1 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=2 X ^DD(399,25,1,1,1.4)
    81  S X=$P(DIKZ("TX"),U,6)
    82  I X'="" D
    83  .N DIK,DIV,DIU,DIN
    84  .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X X ^DD(399,25,1,2,69.2) S X=X S X=X="",Y=X,X=Y(2),X=X&Y I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,8),X=X S DIU=X K Y S X=DIV S X=DUZ X ^DD(399,25,1,2,1.4)
    85  S X=$P(DIKZ("TX"),U,6)
    86  I X'="" D
    87  .N DIK,DIV,DIU,DIN
    88  .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X X ^DD(399,25,1,3,69.2) S X=X S X=X="",Y=X,X=Y(2),X=X&Y I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,7),X=X S DIU=X K Y S X=DIV S X=DT X ^DD(399,25,1,3,1.4)
    89  S DIKZ("C")=$G(^DGCR(399,DA,"C"))
    90  S X=$P(DIKZ("C"),U,14)
    91  I X'="" D
    92  .N DIK,DIV,DIU,DIN
    93  .X ^DD(399,64,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"C")):^("C"),1:"") S X=$P(Y(1),U,10),X=X S DIU=X K Y S X=DIV S X=$P(^ICD9(+X,0),"^",3) X ^DD(399,64,1,1,1.4)
    94  S DIKZ("M")=$G(^DGCR(399,DA,"M"))
    95  S X=$P(DIKZ("M"),U,1)
    96  I X'="" D
    97  .N DIK,DIV,DIU,DIN
    98  .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=$$PRVNUM^IBCU(DA,X,1) X ^DD(399,101,1,1,1.4)
    99  S X=$P(DIKZ("M"),U,1)
    1003 I X'="" D
    1014 .N DIK,DIV,DIU,DIN
    … …  
    17477 S DIKZ("MP")=$G(^DGCR(399,DA,"MP"))
    17578 S X=$P(DIKZ("MP"),U,1)
     79 I X'="" D
     80 .N DIK,DIV,DIU,DIN
     81 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,19),X=X S DIU=X K Y S X=DIV S X=$$FT^IBCU3(DA,1) X ^DD(399,135,1,2,1.4)
     82 S X=$P(DIKZ("MP"),U,1)
     83 I X'="" D MAILA^IBCU5
     84 S X=$P(DIKZ("MP"),U,1)
     85 I X'="" S DGRVRCAL=1
     86 S DIKZ("MP")=$G(^DGCR(399,DA,"MP"))
     87 S X=$P(DIKZ("MP"),U,2)
     88 I X'="" D
     89 .N DIK,DIV,DIU,DIN
     90 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$WNRBILL^IBEFUNC(DA) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"MP")):^("MP"),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y X ^DD(399,136,1,1,1.1) X ^DD(399,136,1,1,1.4)
     91 S DIKZ("U")=$G(^DGCR(399,DA,"U"))
     92 S X=$P(DIKZ("U"),U,1)
     93 I X'="" D
     94 .N DIK,DIV,DIU,DIN
     95 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I $P(^DGCR(399,DA,0),U,5)<3 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X=DIV S X=$$LOS1^IBCU64(DA) X ^DD(399,151,1,1,1.4)
     96 S X=$P(DIKZ("U"),U,1)
     97 I X'="" S DGRVRCAL=1
     98 S X=$P(DIKZ("U"),U,1)
     99 I X'="" D
     100 .N DIK,DIV,DIU,DIN
     101 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I +$G(^DGCR(399,DA,"U1"))=0 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X=DIV S X=0 X ^DD(399,151,1,3,1.4)
     102 S X=$P(DIKZ("U"),U,1)
     103 I X'="" S:$P(^DGCR(399,DA,0),"^",2) ^DGCR(399,"APDS",$P(^(0),U,2),-X,DA)=""
     104 S DIKZ("U")=$G(^DGCR(399,DA,"U"))
     105 S X=$P(DIKZ("U"),U,2)
     106 I X'="" D
     107 .N DIK,DIV,DIU,DIN
     108 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I $P(^DGCR(399,DA,0),U,5)<3 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X=DIV S X=$$LOS1^IBCU64(DA) X ^DD(399,152,1,1,1.4)
     109 S X=$P(DIKZ("U"),U,2)
     110 I X'="" S DGRVRCAL=1
     111 S DIKZ("U")=$G(^DGCR(399,DA,"U"))
     112 S X=$P(DIKZ("U"),U,11)
     113 I X'="" D
     114 .N DIK,DIV,DIU,DIN
     115 .X ^DD(399,161,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y S X=DIV D DIS^IBCU S X=X S DIH=$G(^DGCR(399,DIV(0),"U")),DIV=X S $P(^("U"),U,12)=DIV,DIH=399,DIG=162 D ^DICR
     116 S DIKZ("U")=$G(^DGCR(399,DA,"U"))
     117 S X=$P(DIKZ("U"),U,15)
     118 I X'="" D
     119 .N DIK,DIV,DIU,DIN
     120 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=($P($G(^DGCR(399,DA,"U2")),U,2)=""&$$INPAT^IBCEF(DA,1)) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U2")):^("U2"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIV X ^DD(399,165,1,1,1.4)
     121 S X=$P(DIKZ("U"),U,15)
     122 I X'="" D
     123 .N DIK,DIV,DIU,DIN
     124 .X ^DD(399,165,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U2")):^("U2"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV N Z S X=$$LOS1^IBCU64(DA,.Z),X=+$G(Z) X ^DD(399,165,1,2,1.4)
     125 S DIKZ("U2")=$G(^DGCR(399,DA,"U2"))
     126 S X=$P(DIKZ("U2"),U,4)
     127 I X'="" D
     128 .N DIK,DIV,DIU,DIN
     129 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIU+DIV X ^DD(399,218,1,1,1.4)
     130 S X=$P(DIKZ("U2"),U,4)
     131 I X'="" D
     132 .N DIK,DIV,DIU,DIN
     133 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV S X="PRIOR PAYMENT(S)" X ^DD(399,218,1,2,1.4)
     134 S DIKZ("U2")=$G(^DGCR(399,DA,"U2"))
     135 S X=$P(DIKZ("U2"),U,5)
     136 I X'="" D
     137 .N DIK,DIV,DIU,DIN
     138 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIU+DIV X ^DD(399,219,1,1,1.4)
     139 S X=$P(DIKZ("U2"),U,5)
     140 I X'="" D
     141 .N DIK,DIV,DIU,DIN
     142 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV S X="PRIOR PAYMENT(S)" X ^DD(399,219,1,2,1.4)
     143 S DIKZ("U2")=$G(^DGCR(399,DA,"U2"))
     144 S X=$P(DIKZ("U2"),U,6)
     145 I X'="" D
     146 .N DIK,DIV,DIU,DIN
     147 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIU+DIV X ^DD(399,220,1,1,1.4)
     148 S X=$P(DIKZ("U2"),U,6)
    176149END G ^IBXX17

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX17.m

    r613 r623  
    1 IBXX17 ; COMPILED XREF FOR FILE #399.0222 ; 01/03/09
     1IBXX17 ; COMPILED XREF FOR FILE #399.0222 ; 12/27/07
    22 ;
    3 END G ^IBXX17
    4  .N DIK,DIV,DIU,DIN
    5  .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,19),X=X S DIU=X K Y S X=DIV S X=$$FT^IBCU3(DA,1) X ^DD(399,135,1,2,1.4)
    6  S X=$P(DIKZ("MP"),U,1)
    7  I X'="" D MAILA^IBCU5
    8  S X=$P(DIKZ("MP"),U,1)
    9  I X'="" S DGRVRCAL=1
    10  S DIKZ("MP")=$G(^DGCR(399,DA,"MP"))
    11  S X=$P(DIKZ("MP"),U,2)
    12  I X'="" D
    13  .N DIK,DIV,DIU,DIN
    14  .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$WNRBILL^IBEFUNC(DA) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"MP")):^("MP"),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y X ^DD(399,136,1,1,1.1) X ^DD(399,136,1,1,1.4)
    15  S DIKZ("U")=$G(^DGCR(399,DA,"U"))
    16  S X=$P(DIKZ("U"),U,1)
    17  I X'="" D
    18  .N DIK,DIV,DIU,DIN
    19  .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I $P(^DGCR(399,DA,0),U,5)<3 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X=DIV S X=$$LOS1^IBCU64(DA) X ^DD(399,151,1,1,1.4)
    20  S X=$P(DIKZ("U"),U,1)
    21  I X'="" S DGRVRCAL=1
    22  S X=$P(DIKZ("U"),U,1)
    23  I X'="" D
    24  .N DIK,DIV,DIU,DIN
    25  .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I +$G(^DGCR(399,DA,"U1"))=0 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X=DIV S X=0 X ^DD(399,151,1,3,1.4)
    26  S X=$P(DIKZ("U"),U,1)
    27  I X'="" S:$P(^DGCR(399,DA,0),"^",2) ^DGCR(399,"APDS",$P(^(0),U,2),-X,DA)=""
    28  S DIKZ("U")=$G(^DGCR(399,DA,"U"))
    29  S X=$P(DIKZ("U"),U,2)
    30  I X'="" D
    31  .N DIK,DIV,DIU,DIN
    32  .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I $P(^DGCR(399,DA,0),U,5)<3 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X=DIV S X=$$LOS1^IBCU64(DA) X ^DD(399,152,1,1,1.4)
    33  S X=$P(DIKZ("U"),U,2)
    34  I X'="" S DGRVRCAL=1
    35  S DIKZ("U")=$G(^DGCR(399,DA,"U"))
    36  S X=$P(DIKZ("U"),U,11)
    37  I X'="" D
    38  .N DIK,DIV,DIU,DIN
    39  .X ^DD(399,161,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y S X=DIV D DIS^IBCU S X=X S DIH=$G(^DGCR(399,DIV(0),"U")),DIV=X S $P(^("U"),U,12)=DIV,DIH=399,DIG=162 D ^DICR
    40  S DIKZ("U")=$G(^DGCR(399,DA,"U"))
    41  S X=$P(DIKZ("U"),U,15)
    42  I X'="" D
    43  .N DIK,DIV,DIU,DIN
    44  .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=($P($G(^DGCR(399,DA,"U2")),U,2)=""&$$INPAT^IBCEF(DA,1)) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U2")):^("U2"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIV X ^DD(399,165,1,1,1.4)
    45  S X=$P(DIKZ("U"),U,15)
    46  I X'="" D
    47  .N DIK,DIV,DIU,DIN
    48  .X ^DD(399,165,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U2")):^("U2"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV N Z S X=$$LOS1^IBCU64(DA,.Z),X=+$G(Z) X ^DD(399,165,1,2,1.4)
    49  S DIKZ("U2")=$G(^DGCR(399,DA,"U2"))
    50  S X=$P(DIKZ("U2"),U,4)
    51  I X'="" D
    52  .N DIK,DIV,DIU,DIN
    53  .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIU+DIV X ^DD(399,218,1,1,1.4)
    54  S X=$P(DIKZ("U2"),U,4)
    55  I X'="" D
    56  .N DIK,DIV,DIU,DIN
    57  .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV S X="PRIOR PAYMENT(S)" X ^DD(399,218,1,2,1.4)
    58  S DIKZ("U2")=$G(^DGCR(399,DA,"U2"))
    59  S X=$P(DIKZ("U2"),U,5)
    60  I X'="" D
    61  .N DIK,DIV,DIU,DIN
    62  .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIU+DIV X ^DD(399,219,1,1,1.4)
    63  S X=$P(DIKZ("U2"),U,5)
    64  I X'="" D
    65  .N DIK,DIV,DIU,DIN
    66  .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV S X="PRIOR PAYMENT(S)" X ^DD(399,219,1,2,1.4)
    67  S DIKZ("U2")=$G(^DGCR(399,DA,"U2"))
    68  S X=$P(DIKZ("U2"),U,6)
    69  I X'="" D
    70  .N DIK,DIV,DIU,DIN
    71  .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIU+DIV X ^DD(399,220,1,1,1.4)
    72  S X=$P(DIKZ("U2"),U,6)
    733 I X'="" D
    744 .N DIK,DIV,DIU,DIN

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX18.m

    r613 r623  
    1 IBXX18 ; COMPILED XREF FOR FILE #399.0222 ; 01/03/09
     1IBXX18 ; COMPILED XREF FOR FILE #399.0222 ; 12/27/07
    22 ;
    33 S DA(1)=DA S DA=0

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX19.m

    r613 r623  
    1 IBXX19 ; COMPILED XREF FOR FILE #399.0304 ; 01/03/09
     1IBXX19 ; COMPILED XREF FOR FILE #399.0304 ; 12/27/07
    22 ;
    33 S DA=0

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX2.m

    r613 r623  
    1 IBXX2 ; COMPILED XREF FOR FILE #399.0222 ; 01/03/09
     1IBXX2 ; COMPILED XREF FOR FILE #399.0222 ; 12/27/07
    22 ;
    3 END G ^IBXX2
     3 I X'="" D
     4 .N DIK,DIV,DIU,DIN
     5 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIU-X X ^DD(399,218,1,1,2.4)
     6 S DIKZ("U2")=$G(^DGCR(399,DA,"U2"))
     7 S X=$P(DIKZ("U2"),U,5)
     8 I X'="" D
     9 .N DIK,DIV,DIU,DIN
     10 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIU-X X ^DD(399,219,1,1,2.4)
     11 S DIKZ("U2")=$G(^DGCR(399,DA,"U2"))
     12 S X=$P(DIKZ("U2"),U,6)
     13 I X'="" D
     14 .N DIK,DIV,DIU,DIN
     15 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIU-X X ^DD(399,220,1,1,2.4)
     16 S DIKZ("U2")=$G(^DGCR(399,DA,"U2"))
     17 S X=$P(DIKZ("U2"),U,10)
     18 I X'="" D
     19 .N DIK,DIV,DIU,DIN
     20 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U2")):^("U2"),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y S X="" X ^DD(399,232,1,1,2.4)
     21 S X=$P(DIKZ("U2"),U,10)
     22 I X'="" D
     23 .N DIK,DIV,DIU,DIN
     24 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U2")):^("U2"),1:"") S X=$P(Y(1),U,11),X=X S DIU=X K Y S X="" X ^DD(399,232,1,2,2.4)
     25 S X=$P(DIKZ("U2"),U,10)
     26 I X'="" D
     27 .N DIK,DIV,DIU,DIN
     28 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=$$CLIAREQ^IBCEP8A(DA) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U2")):^("U2"),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$CLIA^IBCEP8A(DA) X ^DD(399,232,1,3,2.4)
     29 S X=$P(DIKZ("U2"),U,10)
     30 I X'="" D
     31 .N DIK,DIV,DIU,DIN
     32 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U3")):^("U3"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X="" S DIH=$G(^DGCR(399,DIV(0),"U3")),DIV=X S $P(^("U3"),U,3)=DIV,DIH=399,DIG=244 D ^DICR
     33 S DIKZ("M1")=$G(^DGCR(399,DA,"M1"))
     34 S X=$P(DIKZ("M1"),U,8)
     35 I X'="" K ^DGCR(399,"AG",$E(X,1,30),DA)
     36 S DIKZ(0)=$G(^DGCR(399,DA,0))
     37 S X=$P(DIKZ(0),U,1)
     38 I X'="" K ^DGCR(399,"B",$E(X,1,30),DA)
     39CR1 S DIXR=139
     40 K X
     41 S DIKZ("M")=$G(^DGCR(399,DA,"M"))
     42 S X(1)=$P(DIKZ("M"),U,1)
     43 S X(2)=$P(DIKZ("M"),U,2)
     44 S X(3)=$P(DIKZ("M"),U,3)
     45 S X(4)=$P(DIKZ("M"),U,13)
     46 S X(5)=$P(DIKZ("M"),U,12)
     47 S X(6)=$P(DIKZ("M"),U,14)
     48 S X=$G(X(1))
     49 D
    450 . K X1,X2 M X1=X,X2=X
    551 . S:$D(DIKIL) (X2,X2(1),X2(2),X2(3),X2(4),X2(5),X2(6))=""

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX20.m

    r613 r623  
    1 IBXX20 ; COMPILED XREF FOR FILE #399.041 ; 01/03/09
     1IBXX20 ; COMPILED XREF FOR FILE #399.041 ; 12/27/07
    22 ;
    33 S DA=0

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX21.m

    r613 r623  
    1 IBXX21 ; COMPILED XREF FOR FILE #399.042 ; 01/03/09
     1IBXX21 ; COMPILED XREF FOR FILE #399.042 ; 12/27/07
    22 ;
    33 S DA=0

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX22.m

    r613 r623  
    1 IBXX22 ; COMPILED XREF FOR FILE #399.043 ; 01/03/09
     1IBXX22 ; COMPILED XREF FOR FILE #399.043 ; 12/27/07
    22 ;
    33 S DA=0

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX23.m

    r613 r623  
    1 IBXX23 ; COMPILED XREF FOR FILE #399.044 ; 01/03/09
     1IBXX23 ; COMPILED XREF FOR FILE #399.044 ; 12/27/07
    22 ;
    33 S DA=0

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX24.m

    r613 r623  
    1 IBXX24 ; COMPILED XREF FOR FILE #399.045 ; 01/03/09
     1IBXX24 ; COMPILED XREF FOR FILE #399.045 ; 12/27/07
    22 ;
    33 S DA=0

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX25.m

    r613 r623  
    1 IBXX25 ; COMPILED XREF FOR FILE #399.046 ; 01/03/09
     1IBXX25 ; COMPILED XREF FOR FILE #399.046 ; 12/27/07
    22 ;
    33 S DA=0

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX26.m

    r613 r623  
    1 IBXX26 ; COMPILED XREF FOR FILE #399.047 ; 01/03/09
     1IBXX26 ; COMPILED XREF FOR FILE #399.047 ; 12/27/07
    22 ;
    33 S DA=0

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX27.m

    r613 r623  
    1 IBXX27 ; COMPILED XREF FOR FILE #399.048 ; 01/03/09
     1IBXX27 ; COMPILED XREF FOR FILE #399.048 ; 12/27/07
    22 ;
    33 S DA=0

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX28.m

    r613 r623  
    1 IBXX28 ; COMPILED XREF FOR FILE #399.077 ; 01/03/09
     1IBXX28 ; COMPILED XREF FOR FILE #399.30416 ; 12/27/07
    22 ;
    3  S DA=0
     3 S DA(2)=DA(1) S DA(1)=0 S DA=0
    44A1 ;
    5  I $D(DISET) K DIKLM S:DIKM1=1 DIKLM=1 G @DIKM1
    6 0 ;
    7 A S DA=$O(^DGCR(399,DA(1),"TXC",DA)) I DA'>0 S DA=0 G END
     5 I $D(DISET) K DIKLM S:DIKM1=2 DIKLM=1 S:DIKM1'=2&'$G(DIKPUSH(2)) DIKPUSH(2)=1,DA(2)=DA(1),DA(1)=DA,DA=0 G @DIKM1
     6A S DA(1)=$O(^DGCR(399,DA(2),"CP",DA(1))) I DA(1)'>0 S DA(1)=0 G END
    871 ;
    9  S DIKZ(0)=$G(^DGCR(399,DA(1),"TXC",DA,0))
     8B S DA=$O(^DGCR(399,DA(2),"CP",DA(1),"MOD",DA)) I DA'>0 S DA=0 Q:DIKM1=1  G A
     92 ;
     10 S DIKZ(0)=$G(^DGCR(399,DA(2),"CP",DA(1),"MOD",DA,0))
    1011 S X=$P(DIKZ(0),U,1)
    11  I X'="" S ^DGCR(399,DA(1),"TXC","B",$E(X,1,30),DA)=""
    12  S X=$P(DIKZ(0),U,1)
    13  I X'="" D
    14  .N DIK,DIV,DIU,DIN
    15  .K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA,DIV(1)=D1 S Y(1)=$S($D(^DGCR(399,D0,"TXC",D1,0)):^(0),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DUZ X ^DD(399.077,.01,1,2,1.4)
    16  G:'$D(DIKLM) A Q:$D(DISET)
    17 END G ^IBXX29
     12 I X'="" S ^DGCR(399,DA(2),"CP",DA(1),"MOD","B",$E(X,1,30),DA)=""
     13 S X=$P(DIKZ(0),U,2)
     14 I X'="" S ^DGCR(399,DA(2),"CP",DA(1),"MOD","C",$E(X,1,30),DA)=""
     15 G:'$D(DIKLM) B Q:$D(DISET)
     16END Q

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX3.m

    r613 r623  
    1 IBXX3 ; COMPILED XREF FOR FILE #399.0222 ; 01/03/09
     1IBXX3 ; COMPILED XREF FOR FILE #399.0222 ; 12/27/07
    22 ;
    33 S DA(1)=DA S DA=0

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX4.m

    r613 r623  
    1 IBXX4 ; COMPILED XREF FOR FILE #399.0304 ; 01/03/09
     1IBXX4 ; COMPILED XREF FOR FILE #399.0304 ; 12/27/07
    22 ;
    33 S DA=0

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX5.m

    r613 r623  
    1 IBXX5 ; COMPILED XREF FOR FILE #399.041 ; 01/03/09
     1IBXX5 ; COMPILED XREF FOR FILE #399.041 ; 12/27/07
    22 ;
    33 S DA=0

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX6.m

    r613 r623  
    1 IBXX6 ; COMPILED XREF FOR FILE #399.042 ; 01/03/09
     1IBXX6 ; COMPILED XREF FOR FILE #399.042 ; 12/27/07
    22 ;
    33 S DA=0

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX7.m

    r613 r623  
    1 IBXX7 ; COMPILED XREF FOR FILE #399.043 ; 01/03/09
     1IBXX7 ; COMPILED XREF FOR FILE #399.043 ; 12/27/07
    22 ;
    33 S DA=0

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX8.m

    r613 r623  
    1 IBXX8 ; COMPILED XREF FOR FILE #399.044 ; 01/03/09
     1IBXX8 ; COMPILED XREF FOR FILE #399.044 ; 12/27/07
    22 ;
    33 S DA=0

  • WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX9.m

    r613 r623  
    1 IBXX9 ; COMPILED XREF FOR FILE #399.045 ; 01/03/09
     1IBXX9 ; COMPILED XREF FOR FILE #399.045 ; 12/27/07
    22 ;
    33 S DA=0
Note: See TracChangeset for help on using the changeset viewer.