- 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
