Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DGPTFVC1

DGPTFVC1.m

Go to the documentation of this file. 
  1. DGPTFVC1 ;ALB/AS/ADL - Expanded PTF Close-Out Edits ; 12/14/04 10:34am
  1.  ;;5.3;PIMS;**52,58,79,114,164,400,342,466,415,493,512,510,544,629,1015,1016**;JUN 30, 2012;Build 20
  1.  ;;ADL;Updated for CSV Project;;Mar 26, 2003
  1.  ;Called from Q+2^DGPTFTR. Variable must be passed in: PTF
  1.  ;Variable returned: DGERR.   DGERR <-- 1 if record fails to pass a check; DGERR <-- "" if record passes all checks
  1.  ;
  1.  Q:'$D(PTF)
  1.  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)
  1.  ;
  1.  I $P(DGV(101),"^",2)>2820700 D AO
  1.  ;
  1.  I DGRTY=1,DGV("FEE") D MT
  1.  ;
  1.  ; DG*512, sck/Remove 101-Means Test indicator = 'U' xmit block
  1.  ;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"
  1.  ;
  1.  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
  1.  ;
  1.  S DGDP="",DGDISPO=$P(DGV(701),"^",6),DGRECSUF=$P(DGV(701),"^",13)
  1.  I DGRTY=1 D
  1.  .S DGSTATYP=$S(DGDISPO=12!(DGDISPO=13):30,DGDISPO=10:42,DGDISPO=8:40,1:"")
  1.  .I DGSTATYP]"" D
  1.  ..D NUMACT^DGPTSUF(DGSTATYP)
  1.  ..I DGANUM>0 F I=1:1:DGANUM I DGSUFFIX=DGSUFNAM(I) D
  1.  ...I DGDISPO'=8 I DGRECSUF=DGSUFNAM(DGANUM) S DGDP=5 D DP
  1.  ...I DGDISPO=8 N DGANUM,DGSUFNAM D NUMACT^DGPTSUF(42) I DGRECSUF=DGSUFNAM(DGANUM) S DGDP=5 D DP
  1.  .K DGANUM,DGSTATYP,DGSUFNAM,I
  1.  ;
  1.  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"
  1.  ;
  1.  ;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)"
  1.  ;
  1.  ;If PRRTP treating specialty, must have valid PRRTP suffix
  1.  ;Fee records would not contain PRRTP specialties
  1.  I 'DGV("FEE"),"^25^26^27^28^29^38^39^"[(U_$P(DGV(701),U,2)_U) D
  1.  .I DGSUFFIX'="PA",(DGSUFFIX'="PB"),(DGSUFFIX'="PC"),(DGSUFFIX'="PD") D
  1.  ..S DGERR=1
  1.  ..W !,"101 SUFFIX",?23,"value must be set to a valid PRRTP suffix."
  1.  ;
  1.  D RACETHNC
  1.  K DGDISPO,DGRECSUF,DGV,DGDP,DGDX,DGSCI,DGSUFFIX,DGNODE,DGX,%,S0,I,X
  1.  I DGERR H 4
  1.  Q
  1.  ;
  1. SCI 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
  1.  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
  1.  Q
  1.  ;
  1. MT S DGVMT=$P(DGV(101),"^",10),DGX=999 G DGX:DGVMT']"" I +$P(DGV(101),"^",2)<2860700!(DGSUFFIX="BU") S DGX="X" G DGX
  1.  ;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
  1.  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
  1.  S DGT=$P(DGV(701),".") G AS:'$O(^DGMT(408.31,"AD",1,DFN,0)) S DGZ1=$$LST^DGMTU(DFN,DGT) K:DGZ1']"" DGZ1
  1.  I DGVMT="X" K DGX,DGVMT Q
  1.  S DGX=$S('$D(DGZ1):"U",1:$P(DGZ1,U,4))
  1.  ; Determine if the Pending Adjudication is for MT(C) or GMT(G)
  1.  I DGX="P" D  G DGX
  1.  . I '+$P($G(DGZ1),U) S DGX="U" Q
  1.  . S DGX=$$PA^DGMTUTL($P(DGZ1,U)),DGX=$S('$D(DGX):"U",DGX="MT":"C",DGX="GMT":"G",1:"U")
  1.  ; sc < 50%, 0% non-comp, sc movements - DG*5.3*544
  1.  I DGX="A",$P(DGZEC,U,4)=3,$$SC^DGMTR(DFN),$$ANYSC^DGPTSCAN(PTF) S DGX="AS" G DGX
  1.  ;-- sc, >0%  - DG*5.3*544
  1.  I DGX="A","^1^3^"[("^"_$P(DGZEC,U,4)_"^"),$P($G(^DPT(DFN,.3)),U,2)>0 S DGX="AS" G DGX
  1.  S DGX=$S(DGX="A":"AN","BCGN"[DGX:DGX,1:"U") G AS:DGX="U" G DGX:DGX'="N"
  1. AS 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
  1.  S DGZ=$S($D(^DPT(DFN,.322)):^(.322),1:0) I $P(DGZ,U,13)="Y" S DGX="AS" G DGX
  1.  N DGNTARR S DGZ=$S($$GETCUR^DGNTAPI(DFN,"DGNTARR")>0:DGNTARR("NTR"),1:"") I $P(DGZ,U)="Y" S DGX="AS" G DGX
  1.  S DGZ=$$GETSTAT^DGMSTAPI(DFN) I $P(DGZ,U,2)="Y" S DGX="AS" G DGX
  1.  I $P(DGZEC,U,5)="Y",$P(DGZEC,U,4)<4,"^2^15^"'[(U_$P(DGZEC,U,9)_U) S DGX="AS" G DGX
  1.  S DGX="AN"
  1. DGX ;DG*5.3*817/Remove 101-Means Test indicator = 'U' xmit block for FEE BASIS PTF 
  1.  I DGVMT'=DGX,DGVMT'="U" 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")
  1.  K DGZEC,DGZ,DGZ1,DGT,DGX,DGVMT Q
  1.  ;
  1. DP I $P(DGV(701),"^",3)'=5 S DGERR=1 W !,"701 ",$E("TYPE OF DISPOSITION",1,18),?23," value inconsistent for discharge"
  1. OP I $P(DGV(701),"^",4)=1 S DGERR=1 W !,"701 ",$E("OUTPATIENT TREATMENT",1,18),?23," value inconsistent for discharge" Q:DGDP=""
  1.  I $P(DGV(701),"^",5)=2 S DGERR=1 W !,"701 VA AUSPICES",?23," value inconsistent for discharge"
  1.  Q
  1.  ;
  1. AO I DGPTFMT<2 D  Q
  1.  .S %=$S($D(^DGPT(PTF,101)):$P(^(101),"^",4),1:"")
  1.  .S %=$S($D(^DIC(45.82,+%,0)):$P(^(0),"^",1),1:"")
  1.  .S I=$S($D(^DPT(DFN,.321)):^(.321),1:"")
  1.  .S:$P(I,"^",2)="Y"&(%'=6) DGERR=1,DGV("E")=1
  1.  .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")
  1.  ;
  1.  N AO,AOL,TMP
  1.  S TMP=$G(^DPT(DFN,.321))
  1.  S AO=$S($P(TMP,"^",2)="Y":1,1:0)
  1.  S AOL=$P(TMP,"^",13)
  1.  Q:('AO)
  1.  Q:(AOL'="")
  1.  S DGERR=1,DGV("E")=1
  1.  W !,"101 AGENT ORANGE LOCATION",?23,"value required if exposure to Agent Orange claimed"
  1.  Q
  1. RACETHNC        ;Race and ethnicity check
  1.  ;Ensure that a value for ethnicity and at least one race is on file.
  1.  ;Ensure all active race/ethnicity values have a valid PTF value and an
  1.  ;associated collection method.  Ensure all collection methods have a
  1.  ;valid PTF value.  Ignore race/ethicity entries that are inactive or
  1.  ;invalid pointers.  Note: PTF sends first active ethnicity and first
  1.  ;six active races.
  1.  N REF,IEN,TYPE,TEXT,PTRVAL,PTRMTHD,NUM,MAX
  1.  N VALIDVAL,VALIDMTH,VALUE,VADM
  1.  D DEM^VADPT
  1.  F REF=11,12 D
  1.  .I REF=12 D
  1.  ..S MAX=6
  1.  ..S TYPE=1
  1.  ..S VALIDVAL=",3,8,9,A,B,C,D,"
  1.  ..S VALIDMTH=",S,P,O,U,"
  1.  ..S TEXT="RACE"
  1.  .I REF=11 D
  1.  ..S MAX=1
  1.  ..S TYPE=2
  1.  ..S TEXT="ETHNICITY"
  1.  ..S VALIDVAL=",H,N,D,U,"
  1.  ..S VALIDMTH=",S,P,O,U,"
  1.  .S NUM=1
  1.  .S IEN=0
  1.  .F  S IEN=+$O(VADM(REF,IEN)) Q:'IEN  D  Q:NUM>MAX
  1.  ..S PTRVAL=+VADM(REF,IEN)
  1.  ..S PTRMTHD=+$G(VADM(REF,IEN,1))
  1.  ..Q:'PTRVAL
  1.  ..Q:$$INACTIVE^DGUTL4(PTRVAL,TYPE)
  1.  ..S NUM=NUM+1
  1.  ..S VALUE=$$PTR2CODE^DGUTL4(PTRVAL,TYPE,4)
  1.  ..I (VALUE="")!(VALIDVAL'[VALUE) D  Q
  1.  ...W !,"701 ",TEXT,?23,"missing/invalid xmit value"
  1.  ...S DGERR=1
  1.  ..I ('PTRMTHD) D  Q
  1.  ...W !,"701 ",TEXT,?23,"method of collection missing/invalid"
  1.  ...S DGERR=1
  1.  ..S VALUE=$$PTR2CODE^DGUTL4(PTRMTHD,3,4)
  1.  ..I (VALUE="")!(VALIDMTH'[VALUE) D  Q
  1.  ...W !,"701 ",TEXT,?23,"missing/invalid xmit value for method of collection"
  1.  ...S DGERR=1
  1.  Q