ADGRALC.m

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

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

 ;

 K ^TMP("DGZRAL",$J)

A ; -- driver

 D LP1 G ^ADGRALP

 ;

LP1 ; -- loop admissions

 N WARD,DX,DGRE,DGDSA,DGDS,NAME,DGDT,TS,DFN,IFN,UTL,WD,N,ED

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

 F  S DGDT=$O(^DGPM("AMV1",DGDT)) Q:'DGDT!(DGDT>ED)  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 ; -- check for readmission

 NEW DGPMDA,NAME,WARD,TS,DX,UTL

 S DGPMDA=IFN D ^ADGREADM Q:'$D(DGRE)

 S NAME=$P($G(^DPT(DFN,0)),U)

 S N=$G(^DGPM(IFN,0)),WD=$P(N,U,6),DX=$P(N,U,10)

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

 S WARD=$P($G(^DIC(42,+WD,0)),U),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))

 ; -- date, alpha

 I DGTYP=1 D  Q

 . S UTL=WARD_U_TS_U_DX_U_DGRE_U_DGDSA_U_DGDS_U_$$M1PD_U_$$M1P

 . S ^TMP("DGZRAL",$J,$P(DGDT,"."),DGDT,DFN)=UTL

 ; -- ward, date, alpha

 I DGTYP=2 D  Q

 . S UTL=TS_U_DX_U_DGRE_U_DGDSA_U_DGDS_U_$$M1PD_U_$$M1P

 . S ^TMP("DGZRAL",$J,WARD,DGDT,NAME,DFN)=UTL

 ; -- service, date, alpha

 S UTL=WARD_U_DX_U_DGRE_U_DGDSA_U_DGDS_U_$$M1PD_U_$$M1P

 S ^TMP("DGZRAL",$J,TS,DGDT,NAME,DFN)=UTL

 Q

 ;

Q ; -- cleanup

 K WARD,DX,DGRE,DGDSA,DGDS,NAME,DGDT,TS,DFN,IFN,UTL,WD,N,ED Q

 ;

M1P() ; -- movement, admission, previous

 Q $O(^DGPM("ATID1",DFN,+$O(^DGPM("ATID1",DFN,9999999.9999999-DGDT)),0))

 ;

M1PD() ; -- movement, admission, previous, date

 Q +$G(^DGPM(+$$M1P,0))

 ;

TS() ; -- treating specialty

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

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

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

 +2       ;

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

A         ; -- driver

 +1        DO LP1

           GOTO ^ADGRALP

 +2       ;

LP1       ; -- loop admissions

 +1        NEW WARD,DX,DGRE,DGDSA,DGDS,NAME,DGDT,TS,DFN,IFN,UTL,WD,N,ED

 +2        SET DGDT=DGBDT-.0001

           SET ED=DGEDT+.2400

 +3        FOR 

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

               IF 'DGDT!(DGDT>ED)

                   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         ; -- check for readmission

 +1        NEW DGPMDA,NAME,WARD,TS,DX,UTL

 +2        SET DGPMDA=IFN

           DO ^ADGREADM

           IF '$DATA(DGRE)

               QUIT 

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

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

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

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

 +5        IF DGTYP=2

               IF DGSRT'="A"

                   IF WD'=+DGSRT

                       QUIT 

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

           SET TS=$$TS

 +7        IF DGTYP=3

               IF DGSRT'="A"

                   IF TS'=+DGSRT

                       QUIT 

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

 +9       ; -- date, alpha

 +10       IF DGTYP=1

               Begin DoDot:1

 +11               SET UTL=WARD_U_TS_U_DX_U_DGRE_U_DGDSA_U_DGDS_U_$$M1PD_U_$$M1P

 +12               SET ^TMP("DGZRAL",$JOB,$PIECE(DGDT,"."),DGDT,DFN)=UTL

               End DoDot:1

               QUIT 

 +13      ; -- ward, date, alpha

 +14       IF DGTYP=2

               Begin DoDot:1

 +15               SET UTL=TS_U_DX_U_DGRE_U_DGDSA_U_DGDS_U_$$M1PD_U_$$M1P

 +16               SET ^TMP("DGZRAL",$JOB,WARD,DGDT,NAME,DFN)=UTL

               End DoDot:1

               QUIT 

 +17      ; -- service, date, alpha

 +18       SET UTL=WARD_U_DX_U_DGRE_U_DGDSA_U_DGDS_U_$$M1PD_U_$$M1P

 +19       SET ^TMP("DGZRAL",$JOB,TS,DGDT,NAME,DFN)=UTL

 +20       QUIT 

 +21      ;

Q         ; -- cleanup

 +1        KILL WARD,DX,DGRE,DGDSA,DGDS,NAME,DGDT,TS,DFN,IFN,UTL,WD,N,ED

           QUIT 

 +2       ;

M1P()     ; -- movement, admission, previous

 +1        QUIT $ORDER(^DGPM("ATID1",DFN,+$ORDER(^DGPM("ATID1",DFN,9999999.9999999-DGDT)),0))

 +2       ;

M1PD()    ; -- movement, admission, previous, date

 +1        QUIT +$GET(^DGPM(+$$M1P,0))

 +2       ;

TS()      ; -- treating specialty

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