ADGLADC.m

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

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

 ;

 K ^TMP("DGZLAD",$J)

A ; -- driver

 D L1 G ^ADGLADP

 ;

L1 ; -- loop admissions

 N DFN,IFN,DGDT

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

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

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

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

 Q

 ;

1 ;

 N NAME,N,WD,WARD,DX,TS

 S NAME=$P($G(^DPT(DFN,0)),U),N=$G(^DGPM(+IFN,0)),WD=$P(N,U,6)

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

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

 I DGTYP=3,DGSRT'="A" Q:TS'=$P($G(^DIC(45.7,+DGSRT,0)),U)

 S TS=$S(TS="":"NO SERVICE",1:TS)

 ;--sort by

 ;--date, alpha 

 I DGTYP=1 D  Q

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

 ;--ward, date, alpha

 I DGTYP=2 D  Q

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

 ;--service, date, alpha

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

 Q

 ;

TS() ; -- treating specialty

 Q $P($G(^DIC(45.7,+$P($G(^DGPM(+$O(^DGPM("APHY",IFN,0)),0)),U,9),0)),U)

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

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

 +2       ;

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

A         ; -- driver

 +1        DO L1

           GOTO ^ADGLADP

 +2       ;

L1        ; -- loop admissions

 +1        NEW DFN,IFN,DGDT

 +2        SET DGDT=DGBDT-.0001

           SET DGEND=DGEDT+.2400

 +3        FOR 

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

               IF 'DGDT!(DGDT>DGEND)

                   QUIT 

               Begin DoDot:1

 +4                SET DFN=0

                   FOR 

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

                       IF 'DFN

                           QUIT 

                       Begin DoDot:2

 +5                        SET IFN=0

                           FOR 

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

                               IF 'IFN

                                   QUIT 

                               DO 1

                       End DoDot:2

               End DoDot:1

 +6        QUIT 

 +7       ;

1         ;

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

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

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

           SET WD=$PIECE(N,U,6)

 +3        IF DGTYP=2

               IF DGSRT'="A"

                   IF WD'=+DGSRT

                       QUIT 

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

           SET DX=$PIECE(N,U,10)

           SET TS=$$TS

 +5        IF DGTYP=3

               IF DGSRT'="A"

                   IF TS'=$PIECE($GET(^DIC(45.7,+DGSRT,0)),U)

                       QUIT 

 +6        SET TS=$SELECT(TS="":"NO SERVICE",1:TS)

 +7       ;--sort by

 +8       ;--date, alpha 

 +9        IF DGTYP=1

               Begin DoDot:1

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

               End DoDot:1

               QUIT 

 +11      ;--ward, date, alpha

 +12       IF DGTYP=2

               Begin DoDot:1

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

               End DoDot:1

               QUIT 

 +14      ;--service, date, alpha

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

 +16       QUIT 

 +17      ;

TS()      ; -- treating specialty

 +1        QUIT $PIECE($GET(^DIC(45.7,+$PIECE($GET(^DGPM(+$ORDER(^DGPM("APHY",IFN,0)),0)),U,9),0)),U)