123 lines
6.3 KiB
Mathematica
123 lines
6.3 KiB
Mathematica
IBCSC4A ;ALB/MJB - MCCR PTF SCREEN ;24 FEB 89 9:49
|
|
;;2.0;INTEGRATED BILLING;**106,228,339**;21-MAR-94;Build 2
|
|
;;Per VHA Directive 2004-038, this routine should not be modified.
|
|
;
|
|
;MAP TO DGCRSC4A
|
|
;
|
|
DX Q:'$D(^DGPT(+IBPTF,0)) S (IBDXC,IBOPC)=0,IBNC="NO DX CODES ENTERED FOR THIS DATE" K ^UTILITY($J,"IBDX")
|
|
;F I=0:0 S I=$O(^DGPT(IBPTF,"M","AM",I)) Q:I'>0 S X=$O(^DGPT(IBPTF,"M","AM",I,0)),IBDX((9999999-$P(I,".",1)),X)=""
|
|
;I '$D(^DGPT(IBPTF,"M","AM")) S IBDX(9999999-DT,1)=""
|
|
;S IBDIA=0 F I=1:1:26 S IBDIA=$O(IBDX(IBDIA)) Q:IBDIA="" S X=$O(IBDX(IBDIA,0)),M=$S($D(^DGPT(IBPTF,"M",X,0)):^(0),1:"") I M]"" S IBCT=0 F J=5:1:9 S:$P(M,U,J)]"" IBCT=IBCT+1,^UTILITY($J,"IBDX",I,IBCT)=$P(M,U,J) D:J=5 T
|
|
;S IBDIA="" F I=1:1:13 S IBDIA=$O(^UTILITY($J,"IBDX",IBDIA)) Q:IBDIA="" D ODD S IBDIA=$O(^UTILITY($J,"IBDX",IBDIA)) D:IBDIA]"" EVEN D SETD^IBCSC4C Q:IBDIA']""
|
|
;
|
|
PRO S IBNC="NO PRO CODES ENTERED FOR THIS DATE",IBOPC=0 K ^UTILITY($J,"IB"),^TMP("IBTYPE",$J)
|
|
F I=0:0 S I=$O(^DGPT(IBPTF,"S",I)) Q:I'>0 S J=$S($D(^DGPT(IBPTF,"S",I,0)):^(0),1:"") I J]"" S X=+J,X=$S(X[".":9999999-X,1:(9999999_"."_I)-X),IBOP(X)=$P(J,U)_U_$P(J,U,8,12)
|
|
F I=0:0 S I=$O(^DGPT(IBPTF,"P",I)) Q:I'>0 S J=$S($D(^DGPT(IBPTF,"P",I,0)):^(0),1:"") I J]"" S X=+J,X=$S(X[".":9999999-X,1:(9999999_"."_I)-X),IBSP(X)=$P(J,U)_U_$P(J,U,5,9)
|
|
S IBP=0 F I=1:1:26 S IBP=$O(IBOP(IBP)) Q:IBP="" S M=IBOP(IBP),IBCT=0 F J=2:1:6 Q:IBCT=3 S:$P(M,U,J)]"" IBCT=IBCT+1,^UTILITY($J,"IB",I,IBCT)=$P(M,U,J) D:J=2 TP
|
|
I I<26 S IBP="" F I=I:1:26 S IBP=$O(IBSP(IBP)) Q:IBP="" S M=IBSP(IBP),IBCT=0 F J=2:1:6 Q:IBCT=3 S:$P(M,U,J)]"" IBCT=IBCT+1 D:$P(M,U,J)]"" T1 D:J=2 T2
|
|
D PTFPS(DFN,IBPTF,+IB("U"),$P(IB("U"),"^",2))
|
|
S IBP="" F I=1:1:13 S IBP=$O(^UTILITY($J,"IB",IBP)) Q:IBP="" D ODDP S IBP=$O(^UTILITY($J,"IB",IBP)) D:IBP]"" EVENP D SETP^IBCSC4C Q:IBP=""
|
|
Q
|
|
;
|
|
T I IBCT>0 S IBDXC=IBDXC+1,^UTILITY($J,"IBDX",I,IBCT)=^UTILITY($J,"IBDX",I,IBCT)_U_$P($P(M,U,10),".",1)_U_$C(64+IBDXC)_U_$P(M,U,2)_"^"_$S(X'=1:"",'$D(^DGPT(IBPTF,70)):"",1:"D/C")_"^"_$$SC(M) Q
|
|
S ^UTILITY($J,"IBDX",I,1)=IBNC_U_$P($P(M,U,10),".",1)_"^^"_$P(^DGPT(IBPTF,"M",X,0),U,2)_"^^"_$$SC(M) Q
|
|
;
|
|
ODD S X=^UTILITY($J,"IBDX",IBDIA,1),IBWO(0)=$P(X,U,3)_U_$P(X,U,2)_U_$P(X,U,4,6),IBWO(1)=$P(X,U,1) F M=2:1:5 S IBWO(M)=$S($D(^UTILITY($J,"IBDX",IBDIA,M)):^(M),1:"")
|
|
Q
|
|
;
|
|
EVEN S X=^UTILITY($J,"IBDX",IBDIA,1),IBWE(0)=$P(X,U,3)_U_$P(X,U,2)_U_$P(X,U,4,6),IBWE(1)=$P(X,U,1) F M=2:1:5 S IBWE(M)=$S($D(^UTILITY($J,"IBDX",IBDIA,M)):^(M),1:"")
|
|
I $P(IBWE(0),U,1)']"" F M=1:1:5 S IBWE(M)=""
|
|
Q
|
|
;
|
|
TP I IBCT>0 S IBOPC=IBOPC+1,^UTILITY($J,"IB",I,IBCT)=^UTILITY($J,"IB",I,IBCT)_U_$P(+M,".",1)_U_$C(64+IBOPC) Q
|
|
S ^UTILITY($J,"IB",I,1)=IBNC_U_$P(+M,".",1) Q
|
|
T1 S ^UTILITY($J,"IB",I,IBCT)=$P(M,U,J) Q
|
|
T2 I IBCT>0 S IBOPC=IBOPC+1,^UTILITY($J,"IB",I,IBCT)=^UTILITY($J,"IB",I,IBCT)_U_$P($P(M,U,1),".",1)_U_$C(64+IBOPC)_U_"*" Q
|
|
S ^UTILITY($J,"IB",I,1)=IBNC_U_$P($P(M,U,1),".",1)_"^^*" Q
|
|
;
|
|
ODDP S X=^UTILITY($J,"IB",IBP,1),IBWO(0)=$P(X,U,3)_U_$P(X,U,2)_U_$S($P(X,U,4)="*":"*",$P(X,U,4)="+":"+",1:""),IBWO(1)=$P(X,U,1)_"^"_$P(X,"^",5,13) F M=2:1:5 S IBWO(M)=$S($D(^UTILITY($J,"IB",IBP,M)):^(M),1:"")
|
|
Q
|
|
;
|
|
EVENP S X=^UTILITY($J,"IB",IBP,1),IBWE(0)=$P(X,U,3)_U_$P(X,U,2)_U_$S($P(X,U,4)="*":"*",$P(X,U,4)="+":"+",1:""),IBWE(1)=$P(X,U,1)_"^"_$P(X,"^",5,13) F M=2:1:5 S IBWE(M)=$S($D(^UTILITY($J,"IB",IBP,M)):^(M),1:"")
|
|
Q
|
|
;
|
|
NUL F I=1:1:13 S $P(^DGCR(399,IBIFN,"C"),U,I)=""
|
|
Q
|
|
;
|
|
P S M=($A($E(X,1))-64),S=$E(X,2),IB5=$S($D(^UTILITY($J,"IB",M,S)):^(S),1:"") I IB5]"" Q:$P(^UTILITY($J,"IB",M,1),U,3)=$E(X,1)
|
|
F J=M:1:26 Q:'$D(^UTILITY($J,"IB",J)) I $P(^UTILITY($J,"IB",J,1),U,3)=$E(X,1) S M=J,IBA=1 Q
|
|
S:'$D(IBA) M=0 K IBA Q
|
|
D S M=($A($E(X,1))-64),S=$E(X,2),IB4=$S($D(^UTILITY($J,"IBDX",M,S)):^(S),1:"") I IB4]"" Q:$P(^UTILITY($J,"IBDX",M,1),U,3)=$E(X,1)
|
|
F J=M:1:26 Q:'$D(^UTILITY($J,"IBDX",J)) I $P(^UTILITY($J,"IBDX",J,1),U,3)=$E(X,1) S M=J,IBA=1 Q
|
|
S:'$D(IBA) M=0 K IBA Q
|
|
;
|
|
SC(M) ; - check SC flag of movement
|
|
; input movement node
|
|
; output flag as to whether sc or not
|
|
I '$D(M) Q ""
|
|
I M="" Q ""
|
|
Q $S($P(M,"^",18)=1:"<SC>",1:"<NSC>")
|
|
;
|
|
PTFPS(DFN,IBPTF,IBFDT,IBTDT) ; this will return a list of professional
|
|
; services from the ptf records. If no date range specified, then
|
|
; it will return all services for that ptf entry.
|
|
; return: ^utility($j,"IB",count for event,count for procedures) =
|
|
; pices: 1 = procedure
|
|
; 2 = date (only if new date)
|
|
; 3 = sequentual grouping letter (only if new date)
|
|
; 4 = "+" to flag as CPT 4 procedure
|
|
; 5 = if exemption applicable, info for that
|
|
; 6-9 = assoc dx in order
|
|
; 10 = quantity
|
|
; 11-12 = modifiers
|
|
; 13 = provider
|
|
; 14 = location
|
|
;
|
|
; the exemption information returned will be first evaluated at the
|
|
; dx level and if nothing there to exempt, it will be at the procedure
|
|
; level.
|
|
;
|
|
N IBX,IBY,IBDT,IBXX,IBP,IBC,IBRMARK,IBDX,IBDXX,IBPP,IB46
|
|
K ^TMP("PTF",$J),^TMP("IBPTFPS",$J)
|
|
S IBFDT=$G(IBFDT),IBTDT=$G(IBTDT,9999999)_".99999"
|
|
;
|
|
; get starting place for ^utility global
|
|
S IBC=+$O(^UTILITY($J,"IB",":"),-1)
|
|
;
|
|
D PTFINFOR^DGAPI(DFN,IBPTF) I '$D(^TMP("PTF",$J)) G PTFPSQ
|
|
;
|
|
S IBX=0 F S IBX=$O(^TMP("PTF",$J,IBX)) Q:IBX<1 S IBY=^TMP("PTF",$J,IBX) I $S(IBFDT<+IBY&(IBTDT>+IBY):1,1:0) S ^TMP("IBPTFPS",$J,+IBY)=""
|
|
I '$D(^TMP("IBPTFPS",$J)) G PTFPSQ
|
|
;
|
|
K ^TMP("PTF",$J)
|
|
D ICDINFO^DGAPI(DFN,IBPTF) ;get the dx's for the ptf
|
|
;
|
|
S IBDT=0 F S:'IBC!($D(^UTILITY($J,"IB",IBC))) IBC=IBC+1 S IBDT=$O(^TMP("IBPTFPS",$J,IBDT)) Q:IBDT<1 D
|
|
. ;
|
|
. S IBD=0
|
|
. D CPTINFO^DGAPI(DFN,,IBDT) I '$D(^TMP("PTF",$J,46)) Q
|
|
. S IB46=$P($G(^TMP("PTF",$J,46,0)),"^",2)_"^"_$P($G(^(0)),"^",4)
|
|
. ;
|
|
. S IBX=0 F S IBX=$O(^TMP("PTF",$J,46,IBX)) Q:IBX<1 S IBY=^TMP("PTF",$J,46,IBX) D
|
|
.. S IBRMARK=""
|
|
.. F IBP=5:1:8,16:1:19 S IBDX=$P(IBY,"^",IBP),IBDXX=0 F S IBDXX=$O(^TMP("PTF",$J,46.1,IBDXX)) Q:IBDXX<1!(IBRMARK) I $P(^TMP("PTF",$J,46.1,IBDXX),"^",2)=IBDX D
|
|
... F IBPP=3:1:10 I $P(^TMP("PTF",$J,46.1,IBDXX),"^",IBPP) S IBRMARK=IBPP Q
|
|
.. S IBD=IBD+1,^UTILITY($J,"IB",IBC,IBD)=$P(IBY,"^",2)_"^"_$S(IBD=1:$P(IBDT,".")_"^"_$C(IBC+64)_"^+^",1:"^^^")_$S(IBRMARK:$P($T(EXEMPT+(IBRMARK-2)),";",3),1:"")_"^"_$P(IBY,"^",5,8)_"^"_$P(IBY,"^",15)_"^"_$P(IBY,"^",3,4)_"^"_IB46
|
|
. S IBD=0
|
|
. K ^TMP("PTF",$J,46)
|
|
;
|
|
;
|
|
PTFPSQ K ^TMP("PTF",$J),^TMP("IBPTFPS",$J),^TMP("CPT",$J)
|
|
Q
|
|
;
|
|
EXEMPT ; exemption reasons
|
|
;;SC
|
|
;;AO
|
|
;;IR
|
|
;;SW
|
|
;;MT
|
|
;;HC
|
|
;;CV
|
|
;;SH
|
|
;
|