- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJTBA.m
r613 r623 1 IBJTBA 2 ;;2.0;INTEGRATED BILLING;**39,80,51,137,135,309,349,389**;21-MAR-94;Build63 4 5 EN 6 7 8 9 HDR 10 11 12 13 INIT 14 15 16 17 18 19 20 21 22 23 24 INITQ 25 26 MRA 27 28 29 30 31 32 33 34 35 36 37 38 39 40 HELP 41 42 43 44 EXIT 45 46 47 48 49 BLD 50 51 52 53 54 55 56 H1500 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 H1500Q 74 75 UB04 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 UB04Q 102 103 SETLN(STR,IBX,COL,WD) 104 105 106 107 SET(STR,LN) 108 109 110 111 112 SETQ 113 114 COB 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 RX 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 PROS 155 156 157 158 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 161 162 163 164 165 166 167 1 IBJTBA ;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 ; 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($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 ;
Note:
See TracChangeset
for help on using the changeset viewer.
