source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSC4C.m@ 972

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

initial load of WorldVistAEHR
File size: 4.2 KB
RevLine 
[613]1IBCSC4C ;ALB/MJB - MCCR PTF SCREEN (CONT.) ;24 FEB 9:43
2 ;;2.0;INTEGRATED BILLING;**210,266**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ;MAP TO DGCRSC4C
6 ;
7SETP S:IBP'>2 IB9=0 D S
8 F F=1:1:3 Q:IB9=3 I $D(IBWO(F)),IBWO(F)]"",$P(IBWO(F),U,1)'=IBNC S IB9=IB9+1,IB7(IB9)=IBWO(F)_U_$S($P(IBWO(F),U,2)']"":$P(IBWO(0),U,2),1:"")
9 I '$D(IB7(3)) F F=1:1:3 Q:IB9=3 I $D(IBWE(F)),IBWE(F)]"",$P(IBWE(F),U,1)'=IBNC S IB9=IB9+1,IB7(IB9)=IBWE(F)_U_$S($P(IBWE(F),U,2)']"":$P(IBWE(0),U,2),1:"")
10 Q:"^^"[$P(IB("C"),U,4,6)!($P(IB("C"),U,4)]"")!($P(IB("C"),U,5)]"")!($P(IB("C"),U,6)]"")
11 F F=1:1:3 I $D(IB7(F)),$P(^DGCR(399,IBIFN,"C"),U,(F+3))']"" S $P(^DGCR(399,IBIFN,"C"),U,(F+3))=$P(IB7(F),U,1),$P(^("C"),U,(F+10))=$P(IB7(F),U,2)
12 S:$P(^DGCR(399,IBIFN,0),U,9)="" $P(^DGCR(399,IBIFN,0),U,9)=9
13 Q
14SETD S:IBDIA'>2 IB8=0 D S
15 F F=1:1:5 Q:IB8=5 I $D(IBWO(F)),IBWO(F)]"",$P(IBWO(F),U,1)'=IBNC S IB8=IB8+1,IB6(IB8)=$P(IBWO(F),U,1)
16 I '$D(IB6(5)) F F=1:1:5 Q:IB8=5 I $D(IBWE(F)),IBWE(F)]"",$P(IBWE(F),U,1)'=IBNC S IB8=IB8+1,IB6(IB8)=$P(IBWE(F),U,1)
17 Q:"^^^^"[$P(IB("C"),U,14,18)!($P(IB("C"),U,14)]"")!($P(IB("C"),U,15)]"")!($P(IB("C"),U,16)]"")!($P(IB("C"),U,17)]"")!($P(IB("C"),U,18)]"")
18 F F=1:1:5 I $D(IB6(F)) S $P(^DGCR(399,IBIFN,"C"),U,(F+13))=IB6(F)
19 Q
20SELP D S F I=1:1 W ! Q:$Y+10>IOSL
21 N IBZ,IBQ
22 S IBQ=0 ; Quit flag
23 F I=1:1:3 W !,"ICD PROCEDURE CODE (",I,"): " D Q:IBQ
24 . S IBPX=$P(IB("C"),U,(I+3))
25 . I IBPX S IBZ=$$ICD0^IBACSV(+IBPX) W $S(IBZ'="":$J($P(IBZ,U),6),1:IBUC)_"// "
26 . R X:DTIME I '$T!(X["^") S IBQ=1 Q
27 . D CHP
28 . I $D(IB3) D PD
29 . D S
30 Q
31 ;
32PD S %DT("A")=" PROCEDURE DATE ("_I_"): ",%DT="AEX" D ^%DT I Y>0 S $P(^DGCR(399,IBIFN,"C"),U,(I+10))=+Y,IB("C")=^DGCR(399,IBIFN,"C") K IB3
33 Q
34 ; Select Diagnosis codes
35SELD D S F I=1:1 W ! Q:$Y+10>IOSL
36 N IBZ,IBQ
37 S IBQ=0
38 F I=1:1:5 W !,"DIAGNOSIS CODE (",I,"): " D Q:IBQ
39 . S IBPY=$P(IB("C"),U,(I+13))
40 . I IBPY S IBZ=$$ICD9^IBACSV(+IBPY) W $S(IBZ'="":$J($P(IBZ,U),6),1:IBUC)_"// "
41 . R X:DTIME I '$T!(X["^")!((X="")&(IBPY="")) S IBQ=1 Q
42 . D CHD,S
43 Q
44CHP N IBDATE,ICDVDT
45 I X="?" D 3^IBCSCH1 S I=I-1 Q
46 I X="",$P(IB("C"),U,(I+3))]"" Q
47 I X["@" W " ...Deleted" S IB7(I)="",$P(^DGCR(399,IBIFN,"C"),U,(I+3))="",$P(^("C"),U,(I+10))="",$P(IB("C"),U,(I+10))="",IBPX=1 Q
48 I X="" S $P(^DGCR(399,IBIFN,"C"),U,(I+3))="",$P(^("C"),U,(I+10))="" Q
49 I X?1A1N D P^IBCSC4A S IB5=$S($D(^UTILITY($J,"IB",M,S)):^(S),1:"") S:IB5]"" $P(^DGCR(399,IBIFN,"C"),U,(I+3))=$P(IB5,U,1) D:IB5]"" DT Q:IB5]"" W *7," ??" S I=I-1 Q
50 I $P(^IBE(350.9,1,1),U,15)'=1 D PAR Q
51 S:X["?" X="??"
52 S IBI=I
53 S IBDATE=$P(^DGCR(399,IBIFN,"C"),U,I+10)
54 I 'IBDATE S IBDATE=$$BDATE^IBACSV(IBIFN)
55 S ICDVDT=IBDATE ; for DD identifier (date of service)
56 S DIC("S")="N IBZ S IBZ=$G(^(0)) I $$SEXSCR^IBCSC4C(IBZ,$G(DFN)),$$ICD0ACT^IBACSV(+Y,IBDATE)"
57 S DIC="^ICD0(" D DIC I Y'>0 S I=IBI-1 Q
58 S X=+Y,$P(^DGCR(399,IBIFN,"C"),U,(I+3))=X D PD
59 Q
60 ;
61CHD N IBDATE,ICDVDT
62 I X="?" D 3^IBCSCH1 S I=I-1 Q
63 I X="",$P(IB("C"),U,(I+13))]"" Q
64 I X["@" W " ...Deleted" S IB6(I)="",$P(^DGCR(399,IBIFN,"C"),U,(I+13))="",$P(IB("C"),U,(I+13))="",IBPY=1 Q
65 I X="" S $P(^DGCR(399,IBIFN,"C"),U,(I+13))="" Q
66 I X?1A1N D D^IBCSC4A S IB4=$S($D(^UTILITY($J,"IBDX",M,S)):^(S),1:"") S:IB4]"" $P(^DGCR(399,IBIFN,"C"),U,(I+13))=$P(IB4,U,1),IB3=1 Q:IB4]"" W *7," ??" S I=I-1 Q
67 I $P(^IBE(350.9,1,1),U,15)'=1 D PAR Q
68 S:X["?" X="??"
69 S IBI=I
70 S IBDATE=$$BDATE^IBACSV(IBIFN) ; The date of service
71 S ICDVDT=IBDATE ; For the DD identifier
72 S DIC("S")="N IBZ S IBZ=$G(^(0)) I $$SEXSCR^IBCSC4C(IBZ,$G(DFN)),$$ICD9ACT^IBACSV(+Y,IBDATE)"
73 S DIC="^ICD9(" D DIC I Y'>0 S I=IBI-1 Q
74 S X=+Y,$P(^DGCR(399,IBIFN,"C"),U,(I+13))=X
75 Q
76 ;
77 ; Check the sex of procedure and the patients
78SEXSCR(IBZ,DFN) ;
79 N IBCODSEX,IBPTSEX
80 S IBCODSEX=$P(IBZ,U,10) ; Sex of the ICD0/ICD9 code, if any
81 I IBCODSEX'="M",IBCODSEX'="F" Q 1 ; No assigned sex for the code
82 I '$G(DFN) Q 1
83 S IBPTSEX=$E($P($G(^DPT(+DFN,0)),U,2)) ; Patient's sex
84 I IBPTSEX'="M",IBPTSEX'="F" S IBPTSEX="M" ; Male is default for veterans
85 Q IBPTSEX=IBCODSEX
86 ;
87DT S $P(^DGCR(399,IBIFN,"C"),U,(I+10))=$S($P(IB5,U,2)]"":$P(IB5,U,2),1:$P(^UTILITY($J,"IB",M,1),U,2))
88 Q
89PAR W:X'["?" " ??" W !?7,"You may only choose codes found in PTF record!" D 3^IBCSCH1 S I=I-1
90 Q
91DIC S DIC(0)="EMQ" D ^DIC
92 Q
93S S:'$D(^DGCR(399,IBIFN,"C")) ^DGCR(399,IBIFN,"C")="" S IB("C")=^DGCR(399,IBIFN,"C")
94 Q
Note: See TracBrowser for help on using the repository browser.