source: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTFVC1.m@ 1259

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

initial load of WorldVistAEHR

File size: 6.5 KB
Line 
1DGPTFVC1 ;ALB/AS/ADL - Expanded PTF Close-Out Edits ; 12/14/04 10:34am
2 ;;5.3;Registration;**52,58,79,114,164,400,342,466,415,493,512,510,544,629**;Aug 13, 1993
3 ;;ADL;Updated for CSV Project;;Mar 26, 2003
4 ;Called from Q+2^DGPTFTR. Variable must be passed in: PTF
5 ;Variable returned: DGERR. DGERR <-- 1 if record fails to pass a check; DGERR <-- "" if record passes all checks
6 ;
7 Q:'$D(PTF)
8 S DGERR="",DGV(701)=$S($D(^DGPT(PTF,70)):^(70),1:""),DGV(101)=^(0),DGSUFFIX=$P(DGV(101),"^",5),DGV("FEE")=$P(DGV(101),"^",4),DFN=$P(DGV(101),"^",1)
9 ;
10 I $P(DGV(101),"^",2)>2820700 D AO
11 ;
12 I DGRTY=1,DGV("FEE") D MT
13 ;
14 ; DG*512, sck/Remove 101-Means Test indocator = 'U' xmit block
15 ;I 'DGV("FEE"),$P(DGV(101),"^",10)="U",'DGV(701)!(+DGV(701)>2890700) S DGERR=1 W !,"101 MEANS TEST",?23," value 'U' - not valid for discharges as of 7/1/1989",!?42,"per MAS VACO policy"
16 ;
17 I $D(^DPT(DFN,57)),$P(^(57),"^",4)>0 S S0=$P(^(57),"^",4),DGDX=$S(S0=1!(S0=3):"344.1",1:"344.0"),DGSCI="" F DGX=0:0 S DGX=$O(^DGPT(PTF,"M",DGX)) Q:DGX'>0 S DGNODE=^(DGX,0),DGSCI="" D SCI
18 ;
19 S DGDP="",DGDISPO=$P(DGV(701),"^",6),DGRECSUF=$P(DGV(701),"^",13)
20 I DGRTY=1 D
21 .S DGSTATYP=$S(DGDISPO=12!(DGDISPO=13):30,DGDISPO=10:42,DGDISPO=8:40,1:"")
22 .I DGSTATYP]"" D
23 ..D NUMACT^DGPTSUF(DGSTATYP)
24 ..I DGANUM>0 F I=1:1:DGANUM I DGSUFFIX=DGSUFNAM(I) D
25 ...I DGDISPO'=8 I DGRECSUF=DGSUFNAM(DGANUM) S DGDP=5 D DP
26 ...I DGDISPO=8 N DGANUM,DGSUFNAM D NUMACT^DGPTSUF(42) I DGRECSUF=DGSUFNAM(DGANUM) S DGDP=5 D DP
27 .K DGANUM,DGSTATYP,DGSUFNAM,I
28 ;
29 I DGRTY=1 S %=$P(DGV(701),"^",3) I %=4!(%=6)!(%=7) S DGDP="" D OP I $P(DGV(701),"^",5)=1 S DGERR=1 W !,"701 VA AUSPICES",?23," value inconsistent for discharge"
30 ;
31 ;I 'DGV("FEE") S %=$P(^DPT(DFN,0),"^",6),%=$S($D(^DIC(10,+%,0)):$P(^(0),"^",2),1:"") I '%!(%>7) S DGERR=1 W !,"701 RACE",?23," value " W:%']"" "blank" I %]"" W %," (invalid code)"
32 ;
33 ;If PRRTP treating specialty, must have valid PRRTP suffix
34 ;Fee records would not contain PRRTP specialties
35 I 'DGV("FEE"),"^25^26^27^28^29^38^39^"[(U_$P(DGV(701),U,2)_U) D
36 .I DGSUFFIX'="PA",(DGSUFFIX'="PB"),(DGSUFFIX'="PC"),(DGSUFFIX'="PD") D
37 ..S DGERR=1
38 ..W !,"101 SUFFIX",?23,"value must be set to a valid PRRTP suffix."
39 ;
40 D RACETHNC
41 K DGDISPO,DGRECSUF,DGV,DGDP,DGDX,DGSCI,DGSUFFIX,DGNODE,DGX,%,S0,I,X
42 I DGERR H 4
43 Q
44 ;
45SCI F X=5:1:15 I X#10 S DGPTTMP=$$ICDDX^ICDCODE(+$P(DGNODE,"^",X),$$GETDATE^ICDGTDRG(PTF)) I +DGPTTMP>0&($P(DGPTTMP,U,10)) S:$E($P(DGPTTMP,"^",2),1,5)=DGDX DGSCI=1 Q:DGSCI
46 I 'DGSCI S DGERR=1,%=$P(DGNODE,"^",10),X=$TR($$FMTE^XLFDT(%,"5DF")," ","0") W !,"501 ",X," SCI of ",S0,?23," requires an ICD Diagnosis code beginning with",!?12," or equal to ",DGDX
47 Q
48 ;
49MT S DGVMT=$P(DGV(101),"^",10),DGX=999 G DGX:DGVMT']"" I +$P(DGV(101),"^",2)<2860700!(DGSUFFIX="BU") S DGX="X" G DGX
50 ;S DGZEC=$S($D(^DPT(DFN,.36)):$P(^(.36),U,1),1:""),DGZEC=$S($D(^DIC(8,+DGZEC,0)):^(0),1:"") I $P(DGZEC,U,5)="N" S DGX="N" G DGX
51 S DGZEC=$P($G(^DGPT(PTF,101)),U,8),DGZEC=$S($D(^DIC(8,+DGZEC,0)):^(0),1:"") I $P(DGZEC,U,5)="N" S DGX="N" G DGX
52 S DGT=$P(DGV(701),".") G AS:'$O(^DGMT(408.31,"AD",1,DFN,0)) S DGZ1=$$LST^DGMTU(DFN,DGT) K:DGZ1']"" DGZ1
53 I DGVMT="X" K DGX,DGVMT Q
54 S DGX=$S('$D(DGZ1):"U",1:$P(DGZ1,U,4))
55 ; Determine if the Pending Adjudication is for MT(C) or GMT(G)
56 I DGX="P" D G DGX
57 . I '+$P($G(DGZ1),U) S DGX="U" Q
58 . S DGX=$$PA^DGMTUTL($P(DGZ1,U)),DGX=$S('$D(DGX):"U",DGX="MT":"C",DGX="GMT":"G",1:"U")
59 ; sc < 50%, 0% non-comp, sc movements - DG*5.3*544
60 I DGX="A",$P(DGZEC,U,4)=3,$$SC^DGMTR(DFN),$$ANYSC^DGPTSCAN(PTF) S DGX="AS" G DGX
61 ;-- sc, >0% - DG*5.3*544
62 I DGX="A","^1^3^"[("^"_$P(DGZEC,U,4)_"^"),$P($G(^DPT(DFN,.3)),U,2)>0 S DGX="AS" G DGX
63 S DGX=$S(DGX="A":"AN","BCGN"[DGX:DGX,1:"U") G AS:DGX="U" G DGX:DGX'="N"
64AS S DGZ=$S($D(^DPT(DFN,.321)):^(.321),1:0) I $P(DGZ,U,2)="Y"!($P(DGZ,U,3)="Y") S DGX="AS" G DGX
65 S DGZ=$S($D(^DPT(DFN,.322)):^(.322),1:0) I $P(DGZ,U,13)="Y" S DGX="AS" G DGX
66 N DGNTARR S DGZ=$S($$GETCUR^DGNTAPI(DFN,"DGNTARR")>0:DGNTARR("NTR"),1:"") I $P(DGZ,U)="Y" S DGX="AS" G DGX
67 S DGZ=$$GETSTAT^DGMSTAPI(DFN) I $P(DGZ,U,2)="Y" S DGX="AS" G DGX
68 I $P(DGZEC,U,5)="Y",$P(DGZEC,U,4)<4,"^2^15^"'[(U_$P(DGZEC,U,9)_U) S DGX="AS" G DGX
69 S DGX="AN"
70DGX I DGVMT'=DGX S DGERR=1 W !,"101 ","MEANS TEST",?23," value ",DGVMT,$S(DGVMT']"":"blank",DGVMT="X":" only for admissions prior to 7/1/86 or domicilliary use",1:" inconsistent with eligibility data")
71 K DGZEC,DGZ,DGZ1,DGT,DGX,DGVMT Q
72 ;
73DP I $P(DGV(701),"^",3)'=5 S DGERR=1 W !,"701 ",$E("TYPE OF DISPOSITION",1,18),?23," value inconsistent for discharge"
74OP I $P(DGV(701),"^",4)=1 S DGERR=1 W !,"701 ",$E("OUTPATIENT TREATMENT",1,18),?23," value inconsistent for discharge" Q:DGDP=""
75 I $P(DGV(701),"^",5)=2 S DGERR=1 W !,"701 VA AUSPICES",?23," value inconsistent for discharge"
76 Q
77 ;
78AO I DGPTFMT<2 D Q
79 .S %=$S($D(^DGPT(PTF,101)):$P(^(101),"^",4),1:"")
80 .S %=$S($D(^DIC(45.82,+%,0)):$P(^(0),"^",1),1:"")
81 .S I=$S($D(^DPT(DFN,.321)):^(.321),1:"")
82 .S:$P(I,"^",2)="Y"&(%'=6) DGERR=1,DGV("E")=1
83 .W:$D(DGV("E")) !,"101 AGENT ORANGE",?23," value ",$S(DGV("E"):"can only be used with COB of '6'",1:"is inconsistent with Vietnam Service and/or COB")
84 ;
85 N AO,AOL,TMP
86 S TMP=$G(^DPT(DFN,.321))
87 S AO=$S($P(TMP,"^",2)="Y":1,1:0)
88 S AOL=$P(TMP,"^",13)
89 Q:('AO)
90 Q:(AOL'="")
91 S DGERR=1,DGV("E")=1
92 W !,"101 AGENT ORANGE LOCATION",?23,"value required if exposure to Agent Orange claimed"
93 Q
94RACETHNC ;Race and ethnicity check
95 ;Ensure that a value for ethnicity and at least one race is on file.
96 ;Ensure all active race/ethnicity values have a valid PTF value and an
97 ;associated collection method. Ensure all collection methods have a
98 ;valid PTF value. Ignore race/ethicity entries that are inactive or
99 ;invalid pointers. Note: PTF sends first active ethnicity and first
100 ;six active races.
101 N REF,IEN,TYPE,TEXT,PTRVAL,PTRMTHD,NUM,MAX
102 N VALIDVAL,VALIDMTH,VALUE,VADM
103 D DEM^VADPT
104 F REF=11,12 D
105 .I REF=12 D
106 ..S MAX=6
107 ..S TYPE=1
108 ..S VALIDVAL=",3,8,9,A,B,C,D,"
109 ..S VALIDMTH=",S,P,O,U,"
110 ..S TEXT="RACE"
111 .I REF=11 D
112 ..S MAX=1
113 ..S TYPE=2
114 ..S TEXT="ETHNICITY"
115 ..S VALIDVAL=",H,N,D,U,"
116 ..S VALIDMTH=",S,P,O,U,"
117 .S NUM=1
118 .S IEN=0
119 .F S IEN=+$O(VADM(REF,IEN)) Q:'IEN D Q:NUM>MAX
120 ..S PTRVAL=+VADM(REF,IEN)
121 ..S PTRMTHD=+$G(VADM(REF,IEN,1))
122 ..Q:'PTRVAL
123 ..Q:$$INACTIVE^DGUTL4(PTRVAL,TYPE)
124 ..S NUM=NUM+1
125 ..S VALUE=$$PTR2CODE^DGUTL4(PTRVAL,TYPE,4)
126 ..I (VALUE="")!(VALIDVAL'[VALUE) D Q
127 ...W !,"701 ",TEXT,?23,"missing/invalid xmit value"
128 ...S DGERR=1
129 ..I ('PTRMTHD) D Q
130 ...W !,"701 ",TEXT,?23,"method of collection missing/invalid"
131 ...S DGERR=1
132 ..S VALUE=$$PTR2CODE^DGUTL4(PTRMTHD,3,4)
133 ..I (VALUE="")!(VALIDMTH'[VALUE) D Q
134 ...W !,"701 ",TEXT,?23,"missing/invalid xmit value for method of collection"
135 ...S DGERR=1
136 Q
Note: See TracBrowser for help on using the repository browser.