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

DGPTFD.m

Go to the documentation of this file.
  1. DGPTFD ;ALB/MTC/ADL,HIOFO/FT,WOIFO/PMK - Sets Required Variables for DRG on 701 Screen ;6/2/15 11:28am
  1. ;;5.3;Registration;**60,441,510,785,850,884**;Aug 13, 1993;Build 31
  1. ;;ADL;Update for CSV Project;;Mar 24, 2003
  1. ;
  1. ; XLFSTR APIs - #10104
  1. ; ICDEX APIs - #5747
  1. ; ICDGTDRG APIs - #4052
  1. ; ICDXCODE APIs - #5699
  1. ;
  1. EN1 ;-- entry point from 701
  1. Q:'$D(^DGPT(PTF,70)) S DGPT(70)=^(70)
  1. ;
  1. ;-- check for DXLS
  1. I $P(DGPT(70),U,10)="",$P(DGPT(70),U,11)="" G Q
  1. ;-- did patient die during care
  1. S DGEXP=$S($P(DGPT(70),U,3)>5:1,1:0)
  1. ;-- discharged against med advice
  1. S DGDMS=$S($P(DGPT(70),U,3)=4:1,1:0)
  1. ;-- transfer to acute care facility
  1. S DGTRS=$S($P(DGPT(70),U,13):1,1:0)
  1. ;-- sex,age
  1. S SEX=$P(^DPT(DFN,0),U,2),AGE=$S(+DGPT(70):+DGPT(70),1:DT)-$P(^(0),U,3)\10000,DOB=$P(^(0),U,3) ; DOB added by abr for ICD calc.
  1. ; DRP DG*5.3*850 If not discharged and census is open then use System Date, else get effective date.
  1. S DGDAT=$S(($G(DISDATE)="")!$G(DGCST,0)>0:DT,1:$$GETDATE^ICDGTDRG(PTF))
  1. ;-- build diagnosis string
  1. D EFFDATE^DGPTIC10(PTF)
  1. ;DRP If not discharged, and Effective date is valid and Census status is open then use Effective date
  1. I $G(DISDATE)="",+$G(EFFDATE),$G(DGCST,0)<1 S DGDAT=EFFDATE
  1. N DGPOA,DGPOACNT,DGDXPOA,DG701
  1. S DGDX="",DGDXPOA=""
  1. ;-- new record after 10/1/86
  1. S DGPOA=$$STR701P^DGPTFUT(PTF) ;returns string with POAs
  1. S DGPOACNT=1
  1. I '+DGPT(70)!(+DGPT(70)>2861000) D
  1. . S DG701=$$STR701^DGPTFUT(PTF) ;returns string with DX codes
  1. . ;F DGI=2:1:25 I $P(DG701,U,DGI)]"" S DGPOACNT=$G(DGPOACNT)+1 D
  1. . F DGI=2:1:25 I $P(DG701,U,DGI)]"" D
  1. .. S DGPTTMP=$$ICDDATA^ICDXCODE("DIAG",+$P(DG701,U,DGI),EFFDATE)
  1. .. I +DGPTTMP>0,$P(DGPTTMP,U,10) D
  1. ... S DGDX=DGDX_U_$P(DG701,U,DGI)
  1. ... ;I EFFDATE'<$$IMPDATE^LEXU("10D") S DGDXPOA=DGDXPOA_U_$$POA($P(DGPOA,U,DGPOACNT))
  1. ... I EFFDATE'<$$IMPDATE^LEXU("10D") S DGDXPOA=DGDXPOA_U_$$POA($P(DGPOA,U,DGI))
  1. ;-- old record format
  1. I +DGPT(70),+DGPT(70)<2861000 F DGI=0:0 S DGI=$O(^DGPT(PTF,"M","AM",DGI)) Q:DGI'>0 S DGJ=$O(^DGPT(PTF,"M","AM",DGI,0)) I $D(^DGPT(PTF,"M",+DGJ,0)) S DGNODE=$P(^(0),U,5,9) I DGNODE'="^^^^" D OLD
  1. ;
  1. S DGTMP=$S($P(DGPT(70),U,10):$P(DGPT(70),"^",10),1:$P(DGPT(70),U,11))
  1. S DGPTTMP=$$ICDDATA^ICDXCODE("DIAG",DGTMP,EFFDATE)
  1. I +DGPTTMP>0,$P(DGPTTMP,U,10) S DGDX=DGTMP_DGDX,DGDXPOA=$$POA($P(DGPOA,U,1))_DGDXPOA
  1. ;
  1. ;-- build surgery and procedure strings
  1. K DGSURG,DGPROC
  1. ;-- start with surgeries (401)
  1. F DGI=0:0 S DGI=$O(^DGPT(PTF,"S",DGI)) Q:DGI'>0 D
  1. .S X=$$STR401^DGPTFUT(PTF,DGI) ;returns string with procedure codes
  1. .I $$STRIP^XLFSTR(X,"^")'="" S K=+^DGPT(PTF,"S",DGI,0),K=$S('$D(DGSURG(K)):K,K[".":K_DGI_1,1:K_".0000"_DGI_1),DGSURG(K)="" S DGVAR=0 D TAG
  1. ;-- build DGSURG
  1. N I,X,Y,Z ; eliminate duplicates as we go
  1. N SUB S SUB=0
  1. I $D(DGSURG) S DGSURG=U F DGI=0:0 S DGI=$O(DGSURG(DGI)) Q:DGI'>0 D
  1. .S X=DGSURG(DGI)
  1. .F I=1:1:25 S Y=$P(X,U,I) Q:Y="" D
  1. ..;Q:$L(DGSURG)>240 ; - no longer needed
  1. ..S Z=U_Y_U
  1. ..S ICDSURG(I)=Y
  1. ..S DGSURG=DGSURG_Y_U
  1. ..S DGPTTMP=$$ICDDATA^ICDXCODE("DIAG",Y,EFFDATE) ; added this line of code - PMK
  1. ..I +DGPTTMP>0,($P(DGPTTMP,U,10)) S SUB=SUB+1,DGSURG(SUB)=$P(DGPTTMP,U,2)
  1. ;-- procedures next old records before 10/1/87
  1. I +DGPT(70),+DGPT(70)<2871000 G DRG:'$D(^DGPT(PTF,"401P")) S DGPROC="",X=^("401P") D:X]""&(X'="^^^^") G DRG
  1. . F DGI=1:1:5 I $P(X,U,DGI)]"" S DGPTTMP=$$ICDDATA^ICDXCODE("PROC",$P(X,U,DGI),EFFDATE) I +DGPTTMP>0,$P(DGPTTMP,U,10) S DGPROC=DGPROC_$P(X,U,DGI)_U
  1. ;-- get 601 (procedures)
  1. F DGI=0:0 S DGI=$O(^DGPT(PTF,"P",DGI)) Q:DGI'>0 D
  1. .S X=$$STR601^DGPTFUT(PTF,DGI) ;returns string with procedure codes
  1. .I $$STRIP^XLFSTR(X,"^")'="" S K=+^DGPT(PTF,"P",DGI,0),K=$S('$D(DGPROC(K)):K,K[".":K_DGI_1,1:K_".0000"_DGI_1),DGPROC(K)="" S DGVAR=1 D TAG
  1. ;-- build DGPROC and eliminate duplicates as we go
  1. I $D(DGPROC) S DGPROC=U F DGI=0:0 S DGI=$O(DGPROC(DGI)) Q:DGI'>0 D
  1. .S X=DGPROC(DGI)
  1. .F I=1:1:25 S Y=$P(X,U,I) Q:Y="" D
  1. ..;Q:$L(DGPROC)>240 ; - no longer needed
  1. ..S Z=U_Y_U
  1. ..S DGPROC(I)=Y
  1. ..;Q:DGPROC[Z
  1. ..S DGPROC=DGPROC_Y_U
  1. DRG ;
  1. S:'$D(DGCPT) DGDRGPRT=1 D ^DGPTICD ;return DRG code even if inactive
  1. ;
  1. Q K AGE,SEX,DGEXP,DGDMS,DGPT,DGTRS,DGDX,DGNODE,DGPROC,DGSURG,DGDRGPRT,DGI,DGJ,K,DOB,ICDSURG Q
  1. ;
  1. OLD ;-- used to format diagnostic codes for old PTF records
  1. S X="" F DGJ=1:1:5 I $P(DGNODE,"^",DGJ)]"",$P($$CODEC^ICDEX(80,$P(DGNODE,"^",DGJ)),U,1)'=-1 S X=X_"^"_$P(DGNODE,"^",DGJ)
  1. S DGDX=X_$P(DGDX,"^",1,40)
  1. Q
  1. TAG ;-- used to build sur/proc string date
  1. F DGJ=1:1:25 I $P(X,U,DGJ)]"" S DGPTTMP=$$ICDDATA^ICDXCODE("PROC",$P(X,U,DGJ),EFFDATE) I +DGPTTMP>0,$P(DGPTTMP,U,10) S:DGVAR=0 DGSURG(K)=DGSURG(K)_$P(X,U,DGJ)_U S:DGVAR=1 DGPROC(K)=DGPROC(K)_$P(X,U,DGJ)_U
  1. Q
  1. POA(POA) ; Calculate of POA should be used in DRG
  1. ; coordinate with POA^DGPTRI4
  1. ;
  1. ; -- On 8/9/2012 the ADT SME Determined that null POA should be defaulted to Yes
  1. ; Due to the fact that the COTS PTF software was not uploading POA information.
  1. ;
  1. S POA=$G(POA)
  1. Q $S(POA="Y":"Y",POA="N":"N",POA="":"Y",POA="U":"U",POA="W":"W",1:"Y")
  1. ;