- 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/IBATO1.m
r613 r623 1 IBATO1 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() 6 7 8 9 NUM(X,X2,X3) 10 11 12 UNIT(IBA,IBD,IBO) 13 14 15 16 17 18 19 20 21 22 23 24 TYPE(IBA,IBO) 25 26 27 28 29 30 31 32 33 34 35 DES(IBA,IBD,IBO) 36 37 38 39 40 41 42 . S IBD(1,IBO,IBB)=$E($P($$PIN^IBATUTL(+$P(IBA(0),"^",12)),U,2),1,18)43 44 45 46 47 48 PRICE(IBA,IBD,IBO) 49 50 51 52 53 54 55 56 57 58 59 60 QTY(IBA,IBD,IBO) 61 62 63 64 65 66 67 68 69 70 71 72 COPAY(IBA) 73 74 75 76 77 78 79 VAR(IBA) 80 81 82 83 PRT(IBIEN) 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 EXPRT(IBIEN) 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 STRIP(A,B) 145 146 147 EXSING(IBF) 148 149 150 151 152 153 154 PRTH 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 PRTG(X,Y,Z,C) 170 171 172 173 174 SEL(B) 175 176 177 178 179 180 181 AGAIN 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 DISP 198 199 200 201 202 203 204 205 206 207 208 209 210 1 IBATO1 ;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 ; 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($$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 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
Note:
See TracChangeset
for help on using the changeset viewer.
