- DGPTFD ;ALB/MTC/ADL,HIOFO/FT,WOIFO/PMK - Sets Required Variables for DRG on 701 Screen ;6/2/15 11:28am
- ;;5.3;Registration;**60,441,510,785,850,884**;Aug 13, 1993;Build 31
- ;;ADL;Update for CSV Project;;Mar 24, 2003
- ;
- ; XLFSTR APIs - #10104
- ; ICDEX APIs - #5747
- ; ICDGTDRG APIs - #4052
- ; ICDXCODE APIs - #5699
- ;
- 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.
- ; DRP DG*5.3*850 If not discharged and census is open then use System Date, else get effective date.
- S DGDAT=$S(($G(DISDATE)="")!$G(DGCST,0)>0:DT,1:$$GETDATE^ICDGTDRG(PTF))
- ;-- build diagnosis string
- D EFFDATE^DGPTIC10(PTF)
- ;DRP If not discharged, and Effective date is valid and Census status is open then use Effective date
- I $G(DISDATE)="",+$G(EFFDATE),$G(DGCST,0)<1 S DGDAT=EFFDATE
- N DGPOA,DGPOACNT,DGDXPOA,DG701
- S DGDX="",DGDXPOA=""
- ;-- new record after 10/1/86
- S DGPOA=$$STR701P^DGPTFUT(PTF) ;returns string with POAs
- S DGPOACNT=1
- I '+DGPT(70)!(+DGPT(70)>2861000) D
- . S DG701=$$STR701^DGPTFUT(PTF) ;returns string with DX codes
- . ;F DGI=2:1:25 I $P(DG701,U,DGI)]"" S DGPOACNT=$G(DGPOACNT)+1 D
- . F DGI=2:1:25 I $P(DG701,U,DGI)]"" D
- .. S DGPTTMP=$$ICDDATA^ICDXCODE("DIAG",+$P(DG701,U,DGI),EFFDATE)
- .. I +DGPTTMP>0,$P(DGPTTMP,U,10) D
- ... S DGDX=DGDX_U_$P(DG701,U,DGI)
- ... ;I EFFDATE'<$$IMPDATE^LEXU("10D") S DGDXPOA=DGDXPOA_U_$$POA($P(DGPOA,U,DGPOACNT))
- ... I EFFDATE'<$$IMPDATE^LEXU("10D") S DGDXPOA=DGDXPOA_U_$$POA($P(DGPOA,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 DGTMP=$S($P(DGPT(70),U,10):$P(DGPT(70),"^",10),1:$P(DGPT(70),U,11))
- S DGPTTMP=$$ICDDATA^ICDXCODE("DIAG",DGTMP,EFFDATE)
- I +DGPTTMP>0,$P(DGPTTMP,U,10) S DGDX=DGTMP_DGDX,DGDXPOA=$$POA($P(DGPOA,U,1))_DGDXPOA
- ;
- ;-- 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 D
- .S X=$$STR401^DGPTFUT(PTF,DGI) ;returns string with procedure codes
- .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
- ;-- 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:25 S Y=$P(X,U,I) Q:Y="" D
- ..;Q:$L(DGSURG)>240 ; - no longer needed
- ..S Z=U_Y_U
- ..S ICDSURG(I)=Y
- ..S DGSURG=DGSURG_Y_U
- ..S DGPTTMP=$$ICDDATA^ICDXCODE("DIAG",Y,EFFDATE) ; added this line of code - PMK
- ..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=$$ICDDATA^ICDXCODE("PROC",$P(X,U,DGI),EFFDATE) 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 D
- .S X=$$STR601^DGPTFUT(PTF,DGI) ;returns string with procedure codes
- .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
- ;-- 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:25 S Y=$P(X,U,I) Q:Y="" D
- ..;Q:$L(DGPROC)>240 ; - no longer needed
- ..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)]"",$P($$CODEC^ICDEX(80,$P(DGNODE,"^",DGJ)),U,1)'=-1 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: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
- Q
- POA(POA) ; Calculate of POA should be used in DRG
- ; coordinate with POA^DGPTRI4
- ;
- ; -- On 8/9/2012 the ADT SME Determined that null POA should be defaulted to Yes
- ; Due to the fact that the COTS PTF software was not uploading POA information.
- ;
- S POA=$G(POA)
- Q $S(POA="Y":"Y",POA="N":"N",POA="":"Y",POA="U":"U",POA="W":"W",1:"Y")
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPTFD 5085 printed Jan 18, 2025@03:52:49 Page 2
- 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
- +2 ;;ADL;Update for CSV Project;;Mar 24, 2003
- +3 ;
- +4 ; XLFSTR APIs - #10104
- +5 ; ICDEX APIs - #5747
- +6 ; ICDGTDRG APIs - #4052
- +7 ; ICDXCODE APIs - #5699
- +8 ;
- 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 ; DRP DG*5.3*850 If not discharged and census is open then use System Date, else get effective date.
- +14 SET DGDAT=$SELECT(($GET(DISDATE)="")!$GET(DGCST,0)>0:DT,1:$$GETDATE^ICDGTDRG(PTF))
- +15 ;-- build diagnosis string
- +16 DO EFFDATE^DGPTIC10(PTF)
- +17 ;DRP If not discharged, and Effective date is valid and Census status is open then use Effective date
- +18 IF $GET(DISDATE)=""
- IF +$GET(EFFDATE)
- IF $GET(DGCST,0)<1
- SET DGDAT=EFFDATE
- +19 NEW DGPOA,DGPOACNT,DGDXPOA,DG701
- +20 SET DGDX=""
- SET DGDXPOA=""
- +21 ;-- new record after 10/1/86
- +22 ;returns string with POAs
- SET DGPOA=$$STR701P^DGPTFUT(PTF)
- +23 SET DGPOACNT=1
- +24 IF '+DGPT(70)!(+DGPT(70)>2861000)
- Begin DoDot:1
- +25 ;returns string with DX codes
- SET DG701=$$STR701^DGPTFUT(PTF)
- +26 ;F DGI=2:1:25 I $P(DG701,U,DGI)]"" S DGPOACNT=$G(DGPOACNT)+1 D
- +27 FOR DGI=2:1:25
- IF $PIECE(DG701,U,DGI)]""
- Begin DoDot:2
- +28 SET DGPTTMP=$$ICDDATA^ICDXCODE("DIAG",+$PIECE(DG701,U,DGI),EFFDATE)
- +29 IF +DGPTTMP>0
- IF $PIECE(DGPTTMP,U,10)
- Begin DoDot:3
- +30 SET DGDX=DGDX_U_$PIECE(DG701,U,DGI)
- +31 ;I EFFDATE'<$$IMPDATE^LEXU("10D") S DGDXPOA=DGDXPOA_U_$$POA($P(DGPOA,U,DGPOACNT))
- +32 IF EFFDATE'<$$IMPDATE^LEXU("10D")
- SET DGDXPOA=DGDXPOA_U_$$POA($PIECE(DGPOA,U,DGI))
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +33 ;-- old record format
- +34 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
- +35 ;
- +36 SET DGTMP=$SELECT($PIECE(DGPT(70),U,10):$PIECE(DGPT(70),"^",10),1:$PIECE(DGPT(70),U,11))
- +37 SET DGPTTMP=$$ICDDATA^ICDXCODE("DIAG",DGTMP,EFFDATE)
- +38 IF +DGPTTMP>0
- IF $PIECE(DGPTTMP,U,10)
- SET DGDX=DGTMP_DGDX
- SET DGDXPOA=$$POA($PIECE(DGPOA,U,1))_DGDXPOA
- +39 ;
- +40 ;-- build surgery and procedure strings
- +41 KILL DGSURG,DGPROC
- +42 ;-- start with surgeries (401)
- +43 FOR DGI=0:0
- SET DGI=$ORDER(^DGPT(PTF,"S",DGI))
- if DGI'>0
- QUIT
- Begin DoDot:1
- +44 ;returns string with procedure codes
- SET X=$$STR401^DGPTFUT(PTF,DGI)
- +45 IF $$STRIP^XLFSTR(X,"^")'=""
- SET K=+^DGPT(PTF,"S",DGI,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
- End DoDot:1
- +46 ;-- build DGSURG
- +47 ; eliminate duplicates as we go
- NEW I,X,Y,Z
- +48 NEW SUB
- SET SUB=0
- +49 IF $DATA(DGSURG)
- SET DGSURG=U
- FOR DGI=0:0
- SET DGI=$ORDER(DGSURG(DGI))
- if DGI'>0
- QUIT
- Begin DoDot:1
- +50 SET X=DGSURG(DGI)
- +51 FOR I=1:1:25
- SET Y=$PIECE(X,U,I)
- if Y=""
- QUIT
- Begin DoDot:2
- +52 ;Q:$L(DGSURG)>240 ; - no longer needed
- +53 SET Z=U_Y_U
- +54 SET ICDSURG(I)=Y
- +55 SET DGSURG=DGSURG_Y_U
- +56 ; added this line of code - PMK
- SET DGPTTMP=$$ICDDATA^ICDXCODE("DIAG",Y,EFFDATE)
- +57 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
- +58 ;-- procedures next old records before 10/1/87
- +59 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
- +60 FOR DGI=1:1:5
- IF $PIECE(X,U,DGI)]""
- SET DGPTTMP=$$ICDDATA^ICDXCODE("PROC",$PIECE(X,U,DGI),EFFDATE)
- IF +DGPTTMP>0
- IF $PIECE(DGPTTMP,U,10)
- SET DGPROC=DGPROC_$PIECE(X,U,DGI)_U
- End DoDot:1
- GOTO DRG
- +61 ;-- get 601 (procedures)
- +62 FOR DGI=0:0
- SET DGI=$ORDER(^DGPT(PTF,"P",DGI))
- if DGI'>0
- QUIT
- Begin DoDot:1
- +63 ;returns string with procedure codes
- SET X=$$STR601^DGPTFUT(PTF,DGI)
- +64 IF $$STRIP^XLFSTR(X,"^")'=""
- SET K=+^DGPT(PTF,"P",DGI,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
- End DoDot:1
- +65 ;-- build DGPROC and eliminate duplicates as we go
- +66 IF $DATA(DGPROC)
- SET DGPROC=U
- FOR DGI=0:0
- SET DGI=$ORDER(DGPROC(DGI))
- if DGI'>0
- QUIT
- Begin DoDot:1
- +67 SET X=DGPROC(DGI)
- +68 FOR I=1:1:25
- SET Y=$PIECE(X,U,I)
- if Y=""
- QUIT
- Begin DoDot:2
- +69 ;Q:$L(DGPROC)>240 ; - no longer needed
- +70 SET Z=U_Y_U
- +71 SET DGPROC(I)=Y
- +72 ;Q:DGPROC[Z
- +73 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 $PIECE($$CODEC^ICDEX(80,$PIECE(DGNODE,"^",DGJ)),U,1)'=-1
- 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:25
- IF $PIECE(X,U,DGJ)]""
- SET DGPTTMP=$$ICDDATA^ICDXCODE("PROC",$PIECE(X,U,DGJ),EFFDATE)
- 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
- POA(POA) ; Calculate of POA should be used in DRG
- +1 ; coordinate with POA^DGPTRI4
- +2 ;
- +3 ; -- On 8/9/2012 the ADT SME Determined that null POA should be defaulted to Yes
- +4 ; Due to the fact that the COTS PTF software was not uploading POA information.
- +5 ;
- +6 SET POA=$GET(POA)
- +7 QUIT $SELECT(POA="Y":"Y",POA="N":"N",POA="":"Y",POA="U":"U",POA="W":"W",1:"Y")
- +8 ;