DGPTFD ;ALB/MTC/ADL - Sets Required Variables for DRG on 701 Screen ; 2/19/02 12:52pm
;;5.3;PIMS;**60,441,510,785,1015,1016**;JUN 30, 2012;Build 20
;;ADL;Update for CSV Project;;Mar 24, 2003
;
EN1 ;-- entry point from 701
Q:'$D(^DGPT(PTF,70)) S DGPT(70)=^(70)
;
;-- check for DXLS
I $P(DGPT(70),U,10)="",$P(DGPT(70),U,11)="" G Q
;-- did patient die during care
S DGEXP=$S($P(DGPT(70),U,3)>5:1,1:0)
;-- discharged against med advice
S DGDMS=$S($P(DGPT(70),U,3)=4:1,1:0)
;-- transfer to acute care facility
S DGTRS=$S($P(DGPT(70),U,13):1,1:0)
;-- sex,age
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.
S DGDAT=$$GETDATE^ICDGTDRG(PTF)
;-- build diagnosis string
S DGDX=""
;-- new record after 10/1/86
I '+DGPT(70)!(+DGPT(70)>2861000) F DGI=16:1:24 I $P(DGPT(70),U,DGI)]"" S DGPTTMP=$$ICDDX^ICDCODE(+$P(DGPT(70),U,DGI),$$GETDATE^ICDGTDRG(PTF)) I +DGPTTMP>0,$P(DGPTTMP,U,10) S DGDX=DGDX_U_$P(DGPT(70),U,DGI)
;-- old record format
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
S DGDX=$S($P(DGPT(70),U,10):$P(DGPT(70),"^",10),1:$P(DGPT(70),U,11))_DGDX
;-- build surgery and procedure strings
K DGSURG,DGPROC
;-- start with surgeries (401)
F DGI=0:0 S DGI=$O(^DGPT(PTF,"S",DGI)) Q:DGI'>0 S X=$P(^(DGI,0),U,8,12) I X]"",X'="^^^^" S K=+^(0),K=$S('$D(DGSURG(K)):K,K[".":K_DGI_1,1:K_".0000"_DGI_1),DGSURG(K)="" S DGVAR=0 D TAG
;-- build DGSURG
N I,X,Y,Z ; eliminate duplicates as we go
N SUB S SUB=0
I $D(DGSURG) S DGSURG=U F DGI=0:0 S DGI=$O(DGSURG(DGI)) Q:DGI'>0 D
.S X=DGSURG(DGI)
.F I=1:1:5 S Y=$P(X,U,I) Q:Y="" D
..Q:$L(DGSURG)>240
..S Z=U_Y_U
..S ICDSURG(I)=Y
..;Q:DGSURG[Z
..S DGSURG=DGSURG_Y_U
..I +DGPTTMP>0,($P(DGPTTMP,U,10)) S SUB=SUB+1,DGSURG(SUB)=$P(DGPTTMP,U,2)
;-- procedures next old records before 10/1/87
I +DGPT(70),+DGPT(70)<2871000 G DRG:'$D(^DGPT(PTF,"401P")) S DGPROC="",X=^("401P") D:X]""&(X'="^^^^") G DRG
. F DGI=1:1:5 I $P(X,U,DGI)]"" S DGPTTMP=$$ICDOP^ICDCODE($P(X,U,DGI),$$GETDATE^ICDGTDRG(PTF)) I +DGPTTMP>0,$P(DGPTTMP,U,10) S DGPROC=DGPROC_$P(X,U,DGI)_U
;-- get 601 (procedures)
F DGI=0:0 S DGI=$O(^DGPT(PTF,"P",DGI)) Q:DGI'>0 S X=$P(^(DGI,0),U,5,9) I X]"",X'="^^^^" S K=+^(0),K=$S('$D(DGPROC(K)):K,K[".":K_DGI_1,1:K_".0000"_DGI_1),DGPROC(K)="" S DGVAR=1 D TAG
;-- build DGPROC and eliminate duplicates as we go
I $D(DGPROC) S DGPROC=U F DGI=0:0 S DGI=$O(DGPROC(DGI)) Q:DGI'>0 D
.S X=DGPROC(DGI)
.F I=1:1:5 S Y=$P(X,U,I) Q:Y="" D
..Q:$L(DGPROC)>240
..S Z=U_Y_U
..S DGPROC(I)=Y
..;Q:DGPROC[Z
..S DGPROC=DGPROC_Y_U
DRG ;
S:'$D(DGCPT) DGDRGPRT=1 D ^DGPTICD ;return DRG code even if inactive
;
Q K AGE,SEX,DGEXP,DGDMS,DGPT,DGTRS,DGDX,DGNODE,DGPROC,DGSURG,DGDRGPRT,DGI,DGJ,K,DOB,ICDSURG Q
;
OLD ;-- used to format diagnostic codes for old PTF records
S X="" F DGJ=1:1:5 I $P(DGNODE,"^",DGJ)]"",$D(^ICD9($P(DGNODE,"^",DGJ),0)) S X=X_"^"_$P(DGNODE,"^",DGJ)
S DGDX=X_$P(DGDX,"^",1,40)
Q
TAG ;-- used to build sur/proc string date
F DGJ=1:1:5 I $P(X,U,DGJ)]"" S DGPTTMP=$$ICDOP^ICDCODE($P(X,U,DGJ),$P(DGPT(70),".")) 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
Q
DGPTFD ;ALB/MTC/ADL - Sets Required Variables for DRG on 701 Screen ; 2/19/02 12:52pm
+1 ;;5.3;PIMS;**60,441,510,785,1015,1016**;JUN 30, 2012;Build 20
+2 ;;ADL;Update for CSV Project;;Mar 24, 2003
+3 ;
EN1 ;-- entry point from 701
+1 IF '$DATA(^DGPT(PTF,70))
QUIT
SET DGPT(70)=^(70)
+2 ;
+3 ;-- check for DXLS
+4 IF $PIECE(DGPT(70),U,10)=""
IF $PIECE(DGPT(70),U,11)=""
GOTO Q
+5 ;-- did patient die during care
+6 SET DGEXP=$SELECT($PIECE(DGPT(70),U,3)>5:1,1:0)
+7 ;-- discharged against med advice
+8 SET DGDMS=$SELECT($PIECE(DGPT(70),U,3)=4:1,1:0)
+9 ;-- transfer to acute care facility
+10 SET DGTRS=$SELECT($PIECE(DGPT(70),U,13):1,1:0)
+11 ;-- sex,age
+12 ; DOB added by abr for ICD calc.
SET SEX=$PIECE(^DPT(DFN,0),U,2)
SET AGE=$SELECT(+DGPT(70):+DGPT(70),1:DT)-$PIECE(^(0),U,3)\10000
SET DOB=$PIECE(^(0),U,3)
+13 SET DGDAT=$$GETDATE^ICDGTDRG(PTF)
+14 ;-- build diagnosis string
+15 SET DGDX=""
+16 ;-- new record after 10/1/86
+17 IF '+DGPT(70)!(+DGPT(70)>2861000)
FOR DGI=16:1:24
IF $PIECE(DGPT(70),U,DGI)]""
SET DGPTTMP=$$ICDDX^ICDCODE(+$PIECE(DGPT(70),U,DGI),$$GETDATE^ICDGTDRG(PTF))
IF +DGPTTMP>0
IF $PIECE(DGPTTMP,U,10)
SET DGDX=DGDX_U_$PIECE(DGPT(70),U,DGI)
+18 ;-- old record format
+19 IF +DGPT(70)
IF +DGPT(70)<2861000
FOR DGI=0:0
SET DGI=$ORDER(^DGPT(PTF,"M","AM",DGI))
IF DGI'>0
QUIT
SET DGJ=$ORDER(^DGPT(PTF,"M","AM",DGI,0))
IF $DATA(^DGPT(PTF,"M",+DGJ,0))
SET DGNODE=$PIECE(^(0),U,5,9)
IF DGNODE'="^^^^"
DO OLD
+20 SET DGDX=$SELECT($PIECE(DGPT(70),U,10):$PIECE(DGPT(70),"^",10),1:$PIECE(DGPT(70),U,11))_DGDX
+21 ;-- build surgery and procedure strings
+22 KILL DGSURG,DGPROC
+23 ;-- start with surgeries (401)
+24 FOR DGI=0:0
SET DGI=$ORDER(^DGPT(PTF,"S",DGI))
IF DGI'>0
QUIT
SET X=$PIECE(^(DGI,0),U,8,12)
IF X]""
IF X'="^^^^"
SET K=+^(0)
SET K=$SELECT('$DATA(DGSURG(K)):K,K[".":K_DGI_1,1:K_".0000"_DGI_1)
SET DGSURG(K)=""
SET DGVAR=0
DO TAG
+25 ;-- build DGSURG
+26 ; eliminate duplicates as we go
NEW I,X,Y,Z
+27 NEW SUB
SET SUB=0
+28 IF $DATA(DGSURG)
SET DGSURG=U
FOR DGI=0:0
SET DGI=$ORDER(DGSURG(DGI))
IF DGI'>0
QUIT
Begin DoDot:1
+29 SET X=DGSURG(DGI)
+30 FOR I=1:1:5
SET Y=$PIECE(X,U,I)
IF Y=""
QUIT
Begin DoDot:2
+31 IF $LENGTH(DGSURG)>240
QUIT
+32 SET Z=U_Y_U
+33 SET ICDSURG(I)=Y
+34 ;Q:DGSURG[Z
+35 SET DGSURG=DGSURG_Y_U
+36 IF +DGPTTMP>0
IF ($PIECE(DGPTTMP,U,10))
SET SUB=SUB+1
SET DGSURG(SUB)=$PIECE(DGPTTMP,U,2)
End DoDot:2
End DoDot:1
+37 ;-- procedures next old records before 10/1/87
+38 IF +DGPT(70)
IF +DGPT(70)<2871000
IF '$DATA(^DGPT(PTF,"401P"))
GOTO DRG
SET DGPROC=""
SET X=^("401P")
IF X]""&(X'="^^^^")
Begin DoDot:1
+39 FOR DGI=1:1:5
IF $PIECE(X,U,DGI)]""
SET DGPTTMP=$$ICDOP^ICDCODE($PIECE(X,U,DGI),$$GETDATE^ICDGTDRG(PTF))
IF +DGPTTMP>0
IF $PIECE(DGPTTMP,U,10)
SET DGPROC=DGPROC_$PIECE(X,U,DGI)_U
End DoDot:1
GOTO DRG
+40 ;-- get 601 (procedures)
+41 FOR DGI=0:0
SET DGI=$ORDER(^DGPT(PTF,"P",DGI))
IF DGI'>0
QUIT
SET X=$PIECE(^(DGI,0),U,5,9)
IF X]""
IF X'="^^^^"
SET K=+^(0)
SET K=$SELECT('$DATA(DGPROC(K)):K,K[".":K_DGI_1,1:K_".0000"_DGI_1)
SET DGPROC(K)=""
SET DGVAR=1
DO TAG
+42 ;-- build DGPROC and eliminate duplicates as we go
+43 IF $DATA(DGPROC)
SET DGPROC=U
FOR DGI=0:0
SET DGI=$ORDER(DGPROC(DGI))
IF DGI'>0
QUIT
Begin DoDot:1
+44 SET X=DGPROC(DGI)
+45 FOR I=1:1:5
SET Y=$PIECE(X,U,I)
IF Y=""
QUIT
Begin DoDot:2
+46 IF $LENGTH(DGPROC)>240
QUIT
+47 SET Z=U_Y_U
+48 SET DGPROC(I)=Y
+49 ;Q:DGPROC[Z
+50 SET DGPROC=DGPROC_Y_U
End DoDot:2
End DoDot:1
DRG ;
+1 ;return DRG code even if inactive
IF '$DATA(DGCPT)
SET DGDRGPRT=1
DO ^DGPTICD
+2 ;
Q KILL AGE,SEX,DGEXP,DGDMS,DGPT,DGTRS,DGDX,DGNODE,DGPROC,DGSURG,DGDRGPRT,DGI,DGJ,K,DOB,ICDSURG
QUIT
+1 ;
OLD ;-- used to format diagnostic codes for old PTF records
+1 SET X=""
FOR DGJ=1:1:5
IF $PIECE(DGNODE,"^",DGJ)]""
IF $DATA(^ICD9($PIECE(DGNODE,"^",DGJ),0))
SET X=X_"^"_$PIECE(DGNODE,"^",DGJ)
+2 SET DGDX=X_$PIECE(DGDX,"^",1,40)
+3 QUIT
TAG ;-- used to build sur/proc string date
+1 FOR DGJ=1:1:5
IF $PIECE(X,U,DGJ)]""
SET DGPTTMP=$$ICDOP^ICDCODE($PIECE(X,U,DGJ),$PIECE(DGPT(70),"."))
IF +DGPTTMP>0
IF $PIECE(DGPTTMP,U,10)
IF DGVAR=0
SET DGSURG(K)=DGSURG(K)_$PIECE(X,U,DGJ)_U
IF DGVAR=1
SET DGPROC(K)=DGPROC(K)_$PIECE(X,U,DGJ)_U
+2 QUIT
