Routine: ADGLDCC

ADGLDCC ; IHS/ADC/PDW/ENM - DISCHARGES LISTINGS (CALC) ; [ 03/25/1999  11:48 AM ]

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

 K ^TMP("DGZLDC",$J)

A ; -- driver

 D LP3 G ^ADGLDCP

LP3 ; -- loop discharges

 N DGDT,ED,DFN,IFN

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

 F  S DGDT=$O(^DGPM("AMV3",DGDT)) Q:'DGDT!(DGDT>ED)  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 1

1 ;

 N NAME,N,CA,ID,WD,WARD,DX,TS

 S NAME=$P($G(^DPT(DFN,0)),U),N=$G(^DGPM(IFN,0)),CA=$P(N,U,14)

 S ID=9999999.9999999-DGDT,WD=$P($G(^DGPM(+$$MP,0)),U,6)

 I DGTYP=2,DGSRT'="A" Q:WD'=+DGSRT

 S WARD=$P($G(^DIC(42,+WD,0)),U),DX=$P($G(^DGPM(+CA,0)),U,10),TS=$$TS

 I DGTYP=3,DGSRT'="A" Q:TS'=+DGSRT

 S TS=$S(TS="":"NO SERVICE",1:$P($G(^DIC(45.7,+TS,0)),U))

UTL ; -- sort by

 ; -- date, alpha

 I DGTYP=1 D  Q

 . S ^TMP("DGZLDC",$J,$P(DGDT,"."),DGDT,DFN)=WARD_U_TS_U_DX

 ; -- ward, date, alpha

 I DGTYP=2 D  Q

 . S ^TMP("DGZLDC",$J,WARD,DGDT,NAME,DFN)=TS_U_DX

 ; -- service, date, alpha

 S ^TMP("DGZLDC",$J,TS,DGDT,NAME,DFN)=WARD_U_DX

MP() ; -- movement, previous

 Q $O(^DGPM("APMV",DFN,CA,$O(^DGPM("APMV",DFN,CA,ID)),0))

TS() ; -- movement, previous, ts

 Q $O(^DGPM("ATS",DFN,CA,+$O(^DGPM("ATS",DFN,CA,ID)),0))

ADGLDCC   ; IHS/ADC/PDW/ENM - DISCHARGES LISTINGS (CALC) ; [ 03/25/1999  11:48 AM ]

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

 +2       ;

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

A         ; -- driver

 +1        DO LP3

           GOTO ^ADGLDCP

 +2       ;

LP3       ; -- loop discharges

 +1        NEW DGDT,ED,DFN,IFN

 +2        SET DGDT=DGBDT-.0001

           SET ED=DGEDT+.2400

 +3        FOR

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

               IF 'DGDT!(DGDT>ED)

                   QUIT

               Begin DoDot:1

 +4                SET DFN=0

FOR

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

                       IF 'DFN

                           QUIT

                       Begin DoDot:2

 +5                        SET IFN=0

FOR

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

                               IF 'IFN

                                   QUIT

                               DO 1

                       End DoDot:2

               End DoDot:1

 +6        QUIT

 +7       ;

1         ;

 +1        NEW NAME,N,CA,ID,WD,WARD,DX,TS

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

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

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

 +3        SET ID=9999999.9999999-DGDT

           SET WD=$PIECE($GET(^DGPM(+$$MP,0)),U,6)

 +4        IF DGTYP=2

               IF DGSRT'="A"

                   IF WD'=+DGSRT

                       QUIT

 +5        SET WARD=$PIECE($GET(^DIC(42,+WD,0)),U)

           SET DX=$PIECE($GET(^DGPM(+CA,0)),U,10)

           SET TS=$$TS

 +6        IF DGTYP=3

               IF DGSRT'="A"

                   IF TS'=+DGSRT

                       QUIT

 +7        SET TS=$SELECT(TS="":"NO SERVICE",1:$PIECE($GET(^DIC(45.7,+TS,0)),U))

UTL       ; -- sort by

 +1       ; -- date, alpha

 +2        IF DGTYP=1

               Begin DoDot:1

 +3                SET ^TMP("DGZLDC",$JOB,$PIECE(DGDT,"."),DGDT,DFN)=WARD_U_TS_U_DX

               End DoDot:1

               QUIT

 +4       ; -- ward, date, alpha

 +5        IF DGTYP=2

               Begin DoDot:1

 +6                SET ^TMP("DGZLDC",$JOB,WARD,DGDT,NAME,DFN)=TS_U_DX

               End DoDot:1

               QUIT

 +7       ; -- service, date, alpha

 +8        SET ^TMP("DGZLDC",$JOB,TS,DGDT,NAME,DFN)=WARD_U_DX

 +9        QUIT

 +10      ;

MP()      ; -- movement, previous

 +1        QUIT $ORDER(^DGPM("APMV",DFN,CA,$ORDER(^DGPM("APMV",DFN,CA,ID)),0))

 +2       ;

TS()      ; -- movement, previous, ts

 +1        QUIT $ORDER(^DGPM("ATS",DFN,CA,+$ORDER(^DGPM("ATS",DFN,CA,ID)),0))

ADGLDCC.m