ADGCEN30.m

ADGCEN30 ; IHS/ADC/PDW/ENM - CENSUS AID-PATIENT LIST ; [ 03/25/1999  11:48 AM ]

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

 ;

 N N,N0,N6,NAME,WARD,DGDT,DFN,IFN,TS,TY,TSNB

 K ^TMP($J)

 S TSNB=$S($O(^DIC(45.7,"B","NEWBORN",0)):$O(^(0)),1:"NEW")

A ; -- main

 D LP1,LP3,LP2,LP6

 G ^ADGCEN31  ;print report

 Q

 ;

LP1 ; -- loop admissions

 S DGDT=DGBDT-.0001

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

 Q

 ;

ADM ; -- admission

 S N=$G(^DGPM(IFN,0)),N0=$G(^DPT(DFN,0)),N6=$G(^DGPM(+$$TS,0))

 S NAME=$P(N0,U),WARD=$P($G(^DIC(42,+$P(N,U,6),0)),U),TS=$P(N6,U,9)

 ; -- screen (selected ward? "A"=all wards)

 I DGWD'="A",$P(N,U,6)'=DGWD Q

 ; -- newborn

 I TS=TSNB D  Q

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

 ; -- other

 S ^TMP($J,"AA",WARD,DGDT,NAME,DFN)=""

 Q

 ;

LP3 ; -- loop discharges

 S DGDT=DGBDT-.0001

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

 Q

 ;

DSC ; -- discharge

 S N=$G(^DGPM(IFN,0)),N0=$G(^DPT(DFN,0)),N6=$G(^DGPM(+$$TS,0))

 S NAME=$P(N0,U),WARD=$P($G(^DIC(42,+$P($G(^DGPM(+$$MP,0)),U,6),0)),U)

 S TY=$P(N,U,4),TS=$P(N6,U,9)

 ; -- screen (selected ward? "A"=all wards)

 I DGWD'="A",$P($G(^DGPM(+$$MP,0)),U,6)'=DGWD Q

 ; -- newborn

 I TS=TSNB D  Q

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

 ; -- death

 I $$DEATH D  Q

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

 ; -- other

 S ^TMP($J,"AD",WARD,DGDT,NAME,DFN)=""

 Q

 ;

LP2 ; -- loop ward transfers

 S DGDT=DGBDT-.0001

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

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

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

 Q

 ;

TRN ; -- ward transfers

 S N=$G(^DGPM(IFN,0)),N0=$G(^DPT(DFN,0)),N6=$G(^DGPM(+$$TS,0))

 S NAME=$P(N0,U),WARD=$P($G(^DIC(42,+$P(N,U,6),0)),U),TS=$P(N6,U,9)

 ; -- screen (selected ward? "A"=all wards)

 ; -- xfr in

 I DGWD="A"!($P(N,U,6)=DGWD) D  Q:DGWD'="A"

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

 ; -- ward transfer, previous

 S CA=$P(N,U,14),ID=9999999.9999999-N

 S N6=$G(^DGPM(+$$TSP,0)),TS=$P(N6,U,9)

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

 S N=$G(^DGPM($$MP,0)),WARD=$P($G(^DIC(42,+$P(N,U,6),0)),U)

 I DGWD'="A",$P(N,U,6)'=DGWD Q

 ; -- xfr out

 S ^TMP($J,"TO",WARD,DGDT,NAME,DFN)=""

 Q

 ;

LP6 ; -- loop treating specialty transfers

 S DGDT=DGBDT-.0001

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

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

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

 Q

 ;

TSC ; -- transfers from newborn service

 S N=$G(^DGPM(IFN,0)),TS=$P(N,U,9)

 I TS'=TSNB Q

 Q:'$$M6A

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

 S WARD=$P($G(^DIC(42,+$P($G(^DGPM(+$P(N,U,24),0)),U,6),0)),U)

 S ^TMP($J,"NEWT",WARD,DGDT,NAME,DFN)=""

 ; -- ward xfr too?

 I +$P($G(^DGPM(+N,0)),U,24) S ^TMP($J,"TI",WARD,DGDT,NAME,DFN)=""

 Q

 ;

MP() ; -- movement, previous

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

 ;

DEATH() ; -- type of discharge death

 Q $S((+$G(^DG(405.1,+TY,"IHS"))>3)&(+$G(^DG(405.1,+TY,"IHS"))<8):1,1:0)

 ;

M6A() ; -- movement, ts, next

 Q $O(^DGPM("APTT6",DFN,+$O(^DGPM("APTT6",DFN,DGDT)),0))

 ;

TS() ; -- t.s. ifn

 Q:$O(^DGPM("APHY",+IFN,0)) $O(^DGPM("APHY",+IFN,0))

 Q $O(^($O(^DGPM("ATS",DFN,+$P(N,U,14),9999999.9999999-N)),0))

 ;

TSP() ; -- t.s, previous

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

ADGCEN30  ; IHS/ADC/PDW/ENM - CENSUS AID-PATIENT LIST ; [ 03/25/1999  11:48 AM ]

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

 +2       ;

 +3        NEW N,N0,N6,NAME,WARD,DGDT,DFN,IFN,TS,TY,TSNB

 +4        KILL ^TMP($JOB)

 +5        SET TSNB=$SELECT($ORDER(^DIC(45.7,"B","NEWBORN",0)):$ORDER(^(0)),1:"NEW")

A         ; -- main

 +1        DO LP1

           DO LP3

           DO LP2

           DO LP6

 +2       ;print report

           GOTO ^ADGCEN31

 +3        QUIT 

 +4       ;

LP1       ; -- loop admissions

 +1        SET DGDT=DGBDT-.0001

 +2        FOR 

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

               IF 'DGDT!(DGDT>DGEDT)

                   QUIT 

               Begin DoDot:1

 +3                SET DFN=0

                   FOR 

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

                       IF 'DFN

                           QUIT 

                       Begin DoDot:2

 +4                        SET IFN=0

                           FOR 

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

                               IF 'IFN

                                   QUIT 

                               DO ADM

                       End DoDot:2

               End DoDot:1

 +5        QUIT 

 +6       ;

ADM       ; -- admission

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

           SET N0=$GET(^DPT(DFN,0))

           SET N6=$GET(^DGPM(+$$TS,0))

 +2        SET NAME=$PIECE(N0,U)

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

           SET TS=$PIECE(N6,U,9)

 +3       ; -- screen (selected ward? "A"=all wards)

 +4        IF DGWD'="A"

               IF $PIECE(N,U,6)'=DGWD

                   QUIT 

 +5       ; -- newborn

 +6        IF TS=TSNB

               Begin DoDot:1

 +7                SET ^TMP($JOB,"NEWA",WARD,DGDT,NAME,DFN)=""

               End DoDot:1

               QUIT 

 +8       ; -- other

 +9        SET ^TMP($JOB,"AA",WARD,DGDT,NAME,DFN)=""

 +10       QUIT 

 +11      ;

LP3       ; -- loop discharges

 +1        SET DGDT=DGBDT-.0001

 +2        FOR 

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

               IF 'DGDT!(DGDT>DGEDT)

                   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 DSC

                       End DoDot:2

               End DoDot:1

 +5        QUIT 

 +6       ;

DSC       ; -- discharge

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

           SET N0=$GET(^DPT(DFN,0))

           SET N6=$GET(^DGPM(+$$TS,0))

 +2        SET NAME=$PIECE(N0,U)

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

 +3        SET TY=$PIECE(N,U,4)

           SET TS=$PIECE(N6,U,9)

 +4       ; -- screen (selected ward? "A"=all wards)

 +5        IF DGWD'="A"

               IF $PIECE($GET(^DGPM(+$$MP,0)),U,6)'=DGWD

                   QUIT 

 +6       ; -- newborn

 +7        IF TS=TSNB

               Begin DoDot:1

 +8                SET ^TMP($JOB,"NEWD",WARD,DGDT,NAME,DFN)=""

               End DoDot:1

               QUIT 

 +9       ; -- death

 +10       IF $$DEATH

               Begin DoDot:1

 +11               SET ^TMP($JOB,"DT",WARD,DGDT,NAME,DFN)=""

               End DoDot:1

               QUIT 

 +12      ; -- other

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

 +14       QUIT 

 +15      ;

LP2       ; -- loop ward transfers

 +1        SET DGDT=DGBDT-.0001

 +2        FOR 

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

               IF 'DGDT!(DGDT>DGEDT)

                   QUIT 

               Begin DoDot:1

 +3                SET DFN=0

                   FOR 

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

                       IF 'DFN

                           QUIT 

                       Begin DoDot:2

 +4                        SET IFN=0

                           FOR 

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

                               IF 'IFN

                                   QUIT 

                               DO TRN

                       End DoDot:2

               End DoDot:1

 +5        QUIT 

 +6       ;

TRN       ; -- ward transfers

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

           SET N0=$GET(^DPT(DFN,0))

           SET N6=$GET(^DGPM(+$$TS,0))

 +2        SET NAME=$PIECE(N0,U)

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

           SET TS=$PIECE(N6,U,9)

 +3       ; -- screen (selected ward? "A"=all wards)

 +4       ; -- xfr in

 +5        IF DGWD="A"!($PIECE(N,U,6)=DGWD)

               Begin DoDot:1

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

               End DoDot:1

               IF DGWD'="A"

                   QUIT 

 +7       ; -- ward transfer, previous

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

           SET ID=9999999.9999999-N

 +9        SET N6=$GET(^DGPM(+$$TSP,0))

           SET TS=$PIECE(N6,U,9)

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

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

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

 +12       IF DGWD'="A"

               IF $PIECE(N,U,6)'=DGWD

                   QUIT 

 +13      ; -- xfr out

 +14       SET ^TMP($JOB,"TO",WARD,DGDT,NAME,DFN)=""

 +15       QUIT 

 +16      ;

LP6       ; -- loop treating specialty transfers

 +1        SET DGDT=DGBDT-.0001

 +2        FOR 

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

               IF 'DGDT!(DGDT>DGEDT)

                   QUIT 

               Begin DoDot:1

 +3                SET DFN=0

                   FOR 

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

                       IF 'DFN

                           QUIT 

                       Begin DoDot:2

 +4                        SET IFN=0

                           FOR 

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

                               IF 'IFN

                                   QUIT 

                               DO TSC

                       End DoDot:2

               End DoDot:1

 +5        QUIT 

 +6       ;

TSC       ; -- transfers from newborn service

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

           SET TS=$PIECE(N,U,9)

 +2        IF TS'=TSNB

               QUIT 

 +3        IF '$$M6A

               QUIT 

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

 +5        SET WARD=$PIECE($GET(^DIC(42,+$PIECE($GET(^DGPM(+$PIECE(N,U,24),0)),U,6),0)),U)

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

 +7       ; -- ward xfr too?

 +8        IF +$PIECE($GET(^DGPM(+N,0)),U,24)

               SET ^TMP($JOB,"TI",WARD,DGDT,NAME,DFN)=""

 +9        QUIT 

 +10      ;

MP()      ; -- movement, previous

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

 +2       ;

DEATH()   ; -- type of discharge death

 +1        QUIT $SELECT((+$GET(^DG(405.1,+TY,"IHS"))>3)&(+$GET(^DG(405.1,+TY,"IHS"))<8):1,1:0)

 +2       ;

M6A()     ; -- movement, ts, next

 +1        QUIT $ORDER(^DGPM("APTT6",DFN,+$ORDER(^DGPM("APTT6",DFN,DGDT)),0))

 +2       ;

TS()      ; -- t.s. ifn

 +1        IF $ORDER(^DGPM("APHY",+IFN,0))

               QUIT $ORDER(^DGPM("APHY",+IFN,0))

 +2        QUIT $ORDER(^($ORDER(^DGPM("ATS",DFN,+$PIECE(N,U,14),9999999.9999999-N)),0))

 +3       ;

TSP()     ; -- t.s, previous

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