source: FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSC4A.m@ 1397

Last change on this file since 1397 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 6.3 KB
Line 
1IBCSC4A ;ALB/MJB - MCCR PTF SCREEN ;24 FEB 89 9:49
2 ;;2.0;INTEGRATED BILLING;**106,228,339**;21-MAR-94;Build 2
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5 ;MAP TO DGCRSC4A
6 ;
7DX Q:'$D(^DGPT(+IBPTF,0)) S (IBDXC,IBOPC)=0,IBNC="NO DX CODES ENTERED FOR THIS DATE" K ^UTILITY($J,"IBDX")
8 ;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)=""
9 ;I '$D(^DGPT(IBPTF,"M","AM")) S IBDX(9999999-DT,1)=""
10 ;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
11 ;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']""
12 ;
13PRO S IBNC="NO PRO CODES ENTERED FOR THIS DATE",IBOPC=0 K ^UTILITY($J,"IB"),^TMP("IBTYPE",$J)
14 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)
15 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)
16 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
17 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
18 D PTFPS(DFN,IBPTF,+IB("U"),$P(IB("U"),"^",2))
19 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=""
20 Q
21 ;
22T 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
23 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
24 ;
25ODD 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:"")
26 Q
27 ;
28EVEN 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:"")
29 I $P(IBWE(0),U,1)']"" F M=1:1:5 S IBWE(M)=""
30 Q
31 ;
32TP 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
33 S ^UTILITY($J,"IB",I,1)=IBNC_U_$P(+M,".",1) Q
34T1 S ^UTILITY($J,"IB",I,IBCT)=$P(M,U,J) Q
35T2 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
36 S ^UTILITY($J,"IB",I,1)=IBNC_U_$P($P(M,U,1),".",1)_"^^*" Q
37 ;
38ODDP 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:"")
39 Q
40 ;
41EVENP 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:"")
42 Q
43 ;
44NUL F I=1:1:13 S $P(^DGCR(399,IBIFN,"C"),U,I)=""
45 Q
46 ;
47P 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)
48 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
49 S:'$D(IBA) M=0 K IBA Q
50D 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)
51 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
52 S:'$D(IBA) M=0 K IBA Q
53 ;
54SC(M) ; - check SC flag of movement
55 ; input movement node
56 ; output flag as to whether sc or not
57 I '$D(M) Q ""
58 I M="" Q ""
59 Q $S($P(M,"^",18)=1:"<SC>",1:"<NSC>")
60 ;
61PTFPS(DFN,IBPTF,IBFDT,IBTDT) ; this will return a list of professional
62 ; services from the ptf records. If no date range specified, then
63 ; it will return all services for that ptf entry.
64 ; return: ^utility($j,"IB",count for event,count for procedures) =
65 ; pices: 1 = procedure
66 ; 2 = date (only if new date)
67 ; 3 = sequentual grouping letter (only if new date)
68 ; 4 = "+" to flag as CPT 4 procedure
69 ; 5 = if exemption applicable, info for that
70 ; 6-9 = assoc dx in order
71 ; 10 = quantity
72 ; 11-12 = modifiers
73 ; 13 = provider
74 ; 14 = location
75 ;
76 ; the exemption information returned will be first evaluated at the
77 ; dx level and if nothing there to exempt, it will be at the procedure
78 ; level.
79 ;
80 N IBX,IBY,IBDT,IBXX,IBP,IBC,IBRMARK,IBDX,IBDXX,IBPP,IB46
81 K ^TMP("PTF",$J),^TMP("IBPTFPS",$J)
82 S IBFDT=$G(IBFDT),IBTDT=$G(IBTDT,9999999)_".99999"
83 ;
84 ; get starting place for ^utility global
85 S IBC=+$O(^UTILITY($J,"IB",":"),-1)
86 ;
87 D PTFINFOR^DGAPI(DFN,IBPTF) I '$D(^TMP("PTF",$J)) G PTFPSQ
88 ;
89 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)=""
90 I '$D(^TMP("IBPTFPS",$J)) G PTFPSQ
91 ;
92 K ^TMP("PTF",$J)
93 D ICDINFO^DGAPI(DFN,IBPTF) ;get the dx's for the ptf
94 ;
95 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
96 . ;
97 . S IBD=0
98 . D CPTINFO^DGAPI(DFN,,IBDT) I '$D(^TMP("PTF",$J,46)) Q
99 . S IB46=$P($G(^TMP("PTF",$J,46,0)),"^",2)_"^"_$P($G(^(0)),"^",4)
100 . ;
101 . S IBX=0 F S IBX=$O(^TMP("PTF",$J,46,IBX)) Q:IBX<1 S IBY=^TMP("PTF",$J,46,IBX) D
102 .. S IBRMARK=""
103 .. 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
104 ... F IBPP=3:1:10 I $P(^TMP("PTF",$J,46.1,IBDXX),"^",IBPP) S IBRMARK=IBPP Q
105 .. 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
106 . S IBD=0
107 . K ^TMP("PTF",$J,46)
108 ;
109 ;
110PTFPSQ K ^TMP("PTF",$J),^TMP("IBPTFPS",$J),^TMP("CPT",$J)
111 Q
112 ;
113EXEMPT ; exemption reasons
114 ;;SC
115 ;;AO
116 ;;IR
117 ;;SW
118 ;;MT
119 ;;HC
120 ;;CV
121 ;;SH
122 ;
Note: See TracBrowser for help on using the repository browser.