VAFHCDG ;ALB/CM OUTPATIENT DG1 SEGMENT GENERATOR ;3/30/95
;;5.3;Registration;**91,151,606**;Jun 06, 1996
;
;This routine generates the Outpatient DG1 segment
;for the Philly project
;
ODG1(DFN,EVENT,EVDT,VPTR,PSTR,PNUM) ;
;
;DFN - Patient File
;EVENT - event number from pivot file
;EVDT - event date/time FileMan
;VPTR - variable pointer
;PSTSR - string of fields
;(if null - required fields, if "A" - supported
;fields, or string of fields seperated by commas")
;PNUM - ID # (optional)
;
I '$D(DFN)!('$D(EVENT))!('$D(EVDT))!('$D(VPTR)) Q "-1^Missing parameters, unable to generate DG1 segment"
I $D(EVENT) I EVENT'="" S NODE=$$PIVX^VAFHPIVT(EVENT,DFN,EVDT)
I $D(EVENT) I EVENT="" K EVENT
I '$D(EVENT) S NODE=$$PIVNW^VAFHPIVT(DFN,EVDT,2,VPTR),EVENT=$P(NODE,":")
I EVENT<1 Q "-1^Bad event number, unable to generate DG1 segment"
S NODE=$P(NODE,":",2)
;
EN1 ;
N HLD,DG1,TD,CODMET,CODE,LOOP,ICD
S (CODE,ICD,DG1,ICD,TD,CODMET)=""
S QUOT=""""""
I '$D(PNUM) S PNUM=1
I '$D(PSTR) S PSTR=",2,6,"
;I PSTR="A" S PSTR=$$GETF^VAFHUTL("DG1")
I PSTR="A" S PSTR=",2,3,4,5,6,"
I PSTR="" S PSTR=",2,6,"
I +PSTR=-1 Q "-1^Unable to get fields, can't generate DG1 segment"
;S LOOP=0
;F S LOOP=LOOP+1,HLD=$P(PSTR,",",LOOP) Q:HLD="" D
;.I HLD=2 S CODMET="I9-ICD9"
;.I HLD=3 S CODE=$$COD(NODE) I CODE="" S CODE=QUOT
;.I HLD=4 D
;..I '$D(CODE) S CODE=$$COD(NODE)
;..I +CODE>0 S ICD=$$DES(CODE) I ICD="" S ICD=QUOT
;..I +CODE=0 S ICD=QUOT
;.I HLD=5 S TD=$$HLDATE^HLFNC(EVDT) I TD="" S TD=QUOT
;
I PSTR[",2," S CODMET="I9-ICD9"
I PSTR[",3," S CODE=$$COD(NODE) I CODE="" S CODE=QUOT
I PSTR[",4," DO
. I '$D(CODE) S CODE=$$COD(NODE)
. I +CODE>0 S ICD=$$DES(CODE) I ICD="" S ICD=QUOT
. I +CODE=0 S ICD=QUOT
I PSTR[",5," S TD=$$HLDATE^HLFNC(EVDT) I TD="" S TD=QUOT
;
S DG1=HLFS_CODE_HLFS_ICD_HLFS_TD
I DG1?1"^"."^" Q "-1^Unable to populate fields "_PSTR_" - can't generate DG1 segment"
S DG1="DG1"_HLFS_PNUM_HLFS_CODMET_DG1
K NODE,QUOT
Q DG1
;
COD(ZNODE) ;
N OPTR,CDX,PTR,FILE
;
S OPTR=$P(ZNODE,"^",5),PTR=+OPTR,FILE=$P(OPTR,";",2)
I PTR=""!(FILE'="SCE(") Q QUOT
;
;try get primary dx first
S CDX=$$GETPDX(PTR) I CDX DO Q CDX
. S CDX=+$P($G(^ICD9(CDX,0)),"^")
. I 'CDX S CDX=QUOT
;
Q QUOT
;
DES(CDX) ;
;Get description/name of diagnosis from diagnostic code
;
I CDX="" Q QUOT
I CDX'?.N1".".N S CDX=CDX_"."
I '$D(^ICD9("AB",CDX)) D
.I $D(^ICD9("AB",CDX_" ")) S CDX=CDX_" " Q
.I $D(^ICD9("AB",CDX_"0")) S CDX=CDX_"0" Q
.I $D(^ICD9("AB",CDX_"0 ")) S CDX=CDX_"0 " Q
.I $D(^ICD9("AB",CDX_"00")) S CDX=CDX_"00" Q
.I $D(^ICD9("AB",CDX_"00 ")) S CDX=CDX_"00 " Q
I '$D(^ICD9("AB",CDX)) Q QUOT
S CDX=$O(^ICD9("AB",CDX,""))
I CDX="" Q QUOT
I '$D(^ICD9(CDX,0)) Q QUOT
S CDX=$$ICDDX^ICDCODE(CDX,$G(EVDT))
S CDX=$S(+CDX<1:QUOT,1:$P(CDX,"^",4))
Q CDX
;
GETPDX(PTR) ;returns first primary diagnois or 0
N VAENC0,VADX
S VAENC0=$$SCE^DGSDU(PTR)
I PTR,+VAENC0,$$DATE^SCDXUTL(+VAENC0)
E Q 0
S CDX=0
D GETDX^SDOE(PTR,"VADX")
S VADX=0
F S VADX=$O(VADX(VADX)) Q:'VADX DO Q:CDX["^P"
. I $P(VADX(VADX),"^",12)="P" S CDX=+VADX(VADX)_"^P"
Q +CDX
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVAFHCDG 3193 printed Apr 09, 2024@21:46:18 Page 2
VAFHCDG ;ALB/CM OUTPATIENT DG1 SEGMENT GENERATOR ;3/30/95
+1 ;;5.3;Registration;**91,151,606**;Jun 06, 1996
+2 ;
+3 ;This routine generates the Outpatient DG1 segment
+4 ;for the Philly project
+5 ;
ODG1(DFN,EVENT,EVDT,VPTR,PSTR,PNUM) ;
+1 ;
+2 ;DFN - Patient File
+3 ;EVENT - event number from pivot file
+4 ;EVDT - event date/time FileMan
+5 ;VPTR - variable pointer
+6 ;PSTSR - string of fields
+7 ;(if null - required fields, if "A" - supported
+8 ;fields, or string of fields seperated by commas")
+9 ;PNUM - ID # (optional)
+10 ;
+11 IF '$DATA(DFN)!('$DATA(EVENT))!('$DATA(EVDT))!('$DATA(VPTR))
QUIT "-1^Missing parameters, unable to generate DG1 segment"
+12 IF $DATA(EVENT)
IF EVENT'=""
SET NODE=$$PIVX^VAFHPIVT(EVENT,DFN,EVDT)
+13 IF $DATA(EVENT)
IF EVENT=""
KILL EVENT
+14 IF '$DATA(EVENT)
SET NODE=$$PIVNW^VAFHPIVT(DFN,EVDT,2,VPTR)
SET EVENT=$PIECE(NODE,":")
+15 IF EVENT<1
QUIT "-1^Bad event number, unable to generate DG1 segment"
+16 SET NODE=$PIECE(NODE,":",2)
+17 ;
EN1 ;
+1 NEW HLD,DG1,TD,CODMET,CODE,LOOP,ICD
+2 SET (CODE,ICD,DG1,ICD,TD,CODMET)=""
+3 SET QUOT=""""""
+4 IF '$DATA(PNUM)
SET PNUM=1
+5 IF '$DATA(PSTR)
SET PSTR=",2,6,"
+6 ;I PSTR="A" S PSTR=$$GETF^VAFHUTL("DG1")
+7 IF PSTR="A"
SET PSTR=",2,3,4,5,6,"
+8 IF PSTR=""
SET PSTR=",2,6,"
+9 IF +PSTR=-1
QUIT "-1^Unable to get fields, can't generate DG1 segment"
+10 ;S LOOP=0
+11 ;F S LOOP=LOOP+1,HLD=$P(PSTR,",",LOOP) Q:HLD="" D
+12 ;.I HLD=2 S CODMET="I9-ICD9"
+13 ;.I HLD=3 S CODE=$$COD(NODE) I CODE="" S CODE=QUOT
+14 ;.I HLD=4 D
+15 ;..I '$D(CODE) S CODE=$$COD(NODE)
+16 ;..I +CODE>0 S ICD=$$DES(CODE) I ICD="" S ICD=QUOT
+17 ;..I +CODE=0 S ICD=QUOT
+18 ;.I HLD=5 S TD=$$HLDATE^HLFNC(EVDT) I TD="" S TD=QUOT
+19 ;
+20 IF PSTR[",2,"
SET CODMET="I9-ICD9"
+21 IF PSTR[",3,"
SET CODE=$$COD(NODE)
IF CODE=""
SET CODE=QUOT
+22 IF PSTR[",4,"
Begin DoDot:1
+23 IF '$DATA(CODE)
SET CODE=$$COD(NODE)
+24 IF +CODE>0
SET ICD=$$DES(CODE)
IF ICD=""
SET ICD=QUOT
+25 IF +CODE=0
SET ICD=QUOT
End DoDot:1
+26 IF PSTR[",5,"
SET TD=$$HLDATE^HLFNC(EVDT)
IF TD=""
SET TD=QUOT
+27 ;
+28 SET DG1=HLFS_CODE_HLFS_ICD_HLFS_TD
+29 IF DG1?1"^"."^"
QUIT "-1^Unable to populate fields "_PSTR_" - can't generate DG1 segment"
+30 SET DG1="DG1"_HLFS_PNUM_HLFS_CODMET_DG1
+31 KILL NODE,QUOT
+32 QUIT DG1
+33 ;
COD(ZNODE) ;
+1 NEW OPTR,CDX,PTR,FILE
+2 ;
+3 SET OPTR=$PIECE(ZNODE,"^",5)
SET PTR=+OPTR
SET FILE=$PIECE(OPTR,";",2)
+4 IF PTR=""!(FILE'="SCE(")
QUIT QUOT
+5 ;
+6 ;try get primary dx first
+7 SET CDX=$$GETPDX(PTR)
IF CDX
Begin DoDot:1
+8 SET CDX=+$PIECE($GET(^ICD9(CDX,0)),"^")
+9 IF 'CDX
SET CDX=QUOT
End DoDot:1
QUIT CDX
+10 ;
+11 QUIT QUOT
+12 ;
DES(CDX) ;
+1 ;Get description/name of diagnosis from diagnostic code
+2 ;
+3 IF CDX=""
QUIT QUOT
+4 IF CDX'?.N1".".N
SET CDX=CDX_"."
+5 IF '$DATA(^ICD9("AB",CDX))
Begin DoDot:1
+6 IF $DATA(^ICD9("AB",CDX_" "))
SET CDX=CDX_" "
QUIT
+7 IF $DATA(^ICD9("AB",CDX_"0"))
SET CDX=CDX_"0"
QUIT
+8 IF $DATA(^ICD9("AB",CDX_"0 "))
SET CDX=CDX_"0 "
QUIT
+9 IF $DATA(^ICD9("AB",CDX_"00"))
SET CDX=CDX_"00"
QUIT
+10 IF $DATA(^ICD9("AB",CDX_"00 "))
SET CDX=CDX_"00 "
QUIT
End DoDot:1
+11 IF '$DATA(^ICD9("AB",CDX))
QUIT QUOT
+12 SET CDX=$ORDER(^ICD9("AB",CDX,""))
+13 IF CDX=""
QUIT QUOT
+14 IF '$DATA(^ICD9(CDX,0))
QUIT QUOT
+15 SET CDX=$$ICDDX^ICDCODE(CDX,$GET(EVDT))
+16 SET CDX=$SELECT(+CDX<1:QUOT,1:$PIECE(CDX,"^",4))
+17 QUIT CDX
+18 ;
GETPDX(PTR) ;returns first primary diagnois or 0
+1 NEW VAENC0,VADX
+2 SET VAENC0=$$SCE^DGSDU(PTR)
+3 IF PTR
IF +VAENC0
IF $$DATE^SCDXUTL(+VAENC0)
+4 IF '$TEST
QUIT 0
+5 SET CDX=0
+6 DO GETDX^SDOE(PTR,"VADX")
+7 SET VADX=0
+8 FOR
SET VADX=$ORDER(VADX(VADX))
if 'VADX
QUIT
Begin DoDot:1
+9 IF $PIECE(VADX(VADX),"^",12)="P"
SET CDX=+VADX(VADX)_"^P"
End DoDot:1
if CDX["^P"
QUIT
+10 QUIT +CDX
