ADGDODC.m

ADGDODC ; IHS/ADC/PDW/ENM - INPATIENT DEATHS LISTING(CALC) ; [ 03/25/1999  11:48 AM ]

 ;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999

 ;

 K ^TMP("DGZDOD",$J)

A ; -- driver

 D LP3,Q G ^ADGDODP

 ;

LP3 ;--loop discharges for specified date range

 S DGDT=DGBDT-.0001,DGED=DGEDT+.2400

 F  S DGDT=$O(^DGPM("AMV3",DGDT)) Q:'DGDT!(DGDT>DGED)  D

 . S DFN=0 F  S DFN=$O(^DGPM("AMV3",DGDT,DFN)) Q:'DFN  D

 .. S IFN=0 F  S IFN=$O(^DGPM("AMV3",DGDT,DFN,IFN)) Q:'IFN  D 3

 Q

 ;

3 ;

 N N,NAME,ID,CA,TS

 Q:'$D(^DPT(DFN,.35))  S N=$G(^DGPM(+IFN,0)) Q:$$DEATH

 S NAME=$P($G(^DPT(+DFN,0)),U),ID=9999999.9999999-DGDT,CA=$P(N,U,14)

 S TS=$$TS

 I DGTYP=1 S ^TMP("DGZDOD",$J,DGDT,NAME,DFN)=$$IHS_U_TS Q

 I DGTYP=2 S ^TMP("DGZDOD",$J,TS,DGDT,NAME,DFN)=$$IHS Q

 S ^TMP("DGZDOD",$J,NAME,DFN,DGDT)=$$IHS_U_TS

 Q

 ;

Q ; -- cleanup

 K IFN,DFN,DGED Q

 ;

DEATH() ; -- type of discharge death

 Q $S($$IHS<4&($$IHS<7):1,1:0)

 ;

IHS() ; -- ihs code type of discharge

 Q $G(^DG(405.1,+$P(N,U,4),"IHS"))

 ;

TS() ; -- discharge treating specialty

 Q $P($G(^DIC(45.7,+$O(^DGPM("ATS",DFN,CA,+$O(^DGPM("ATS",DFN,CA,ID)),0)),0)),U)

ADGDODC   ; IHS/ADC/PDW/ENM - INPATIENT DEATHS LISTING(CALC) ; [ 03/25/1999  11:48 AM ]

 +1       ;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999

 +2       ;

 +3        KILL ^TMP("DGZDOD",$JOB)

A         ; -- driver

 +1        DO LP3

           DO Q

           GOTO ^ADGDODP

 +2       ;

LP3       ;--loop discharges for specified date range

 +1        SET DGDT=DGBDT-.0001

           SET DGED=DGEDT+.2400

 +2        FOR 

               SET DGDT=$ORDER(^DGPM("AMV3",DGDT))

               IF 'DGDT!(DGDT>DGED)

                   QUIT 

               Begin DoDot:1

 +3                SET DFN=0

                   FOR 

                       SET DFN=$ORDER(^DGPM("AMV3",DGDT,DFN))

                       IF 'DFN

                           QUIT 

                       Begin DoDot:2

 +4                        SET IFN=0

                           FOR 

                               SET IFN=$ORDER(^DGPM("AMV3",DGDT,DFN,IFN))

                               IF 'IFN

                                   QUIT 

                               DO 3

                       End DoDot:2

               End DoDot:1

 +5        QUIT 

 +6       ;

3         ;

 +1        NEW N,NAME,ID,CA,TS

 +2        IF '$DATA(^DPT(DFN,.35))

               QUIT 

           SET N=$GET(^DGPM(+IFN,0))

           IF $$DEATH

               QUIT 

 +3        SET NAME=$PIECE($GET(^DPT(+DFN,0)),U)

           SET ID=9999999.9999999-DGDT

           SET CA=$PIECE(N,U,14)

 +4        SET TS=$$TS

 +5        IF DGTYP=1

               SET ^TMP("DGZDOD",$JOB,DGDT,NAME,DFN)=$$IHS_U_TS

               QUIT 

 +6        IF DGTYP=2

               SET ^TMP("DGZDOD",$JOB,TS,DGDT,NAME,DFN)=$$IHS

               QUIT 

 +7        SET ^TMP("DGZDOD",$JOB,NAME,DFN,DGDT)=$$IHS_U_TS

 +8        QUIT 

 +9       ;

Q         ; -- cleanup

 +1        KILL IFN,DFN,DGED

           QUIT 

 +2       ;

DEATH()   ; -- type of discharge death

 +1        QUIT $SELECT($$IHS<4&($$IHS<7):1,1:0)

 +2       ;

IHS()     ; -- ihs code type of discharge

 +1        QUIT $GET(^DG(405.1,+$PIECE(N,U,4),"IHS"))

 +2       ;

TS()      ; -- discharge treating specialty

 +1        QUIT $PIECE($GET(^DIC(45.7,+$ORDER(^DGPM("ATS",DFN,CA,+$ORDER(^DGPM("ATS",DFN,CA,ID)),0)),0)),U)