ADGAD3.m

ADGAD3 ; IHS/ADC/PDW/ENM - A&D DISCHARGES ; [ 05/19/2000  10:29 AM ]

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

 ;

 ; Variables GL, RD, FR, TO used by VA G&L routines.

 ;

 N DFN,IFN,DGDT,NAME,FAC,WD,COM,PR,TS,AGE,HRCN,CA,N,UTL,ID,Z

A ; -- main

 D L3 Q

 ;

L3 ; -- loop discharges 

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

 Q

 ;

1 S ID=9999999.9999999-DGDT

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

 S N=$G(^DGPM(+IFN,0)),FAC=$P(N,U,5),CA=$P(N,U,14)

 S N=$G(^DGPM(+$$MIP,0)),WD=$P(N,U,6)

 S N=$G(^DGPM(+$$MTSP,0)),TS=$P(N,U,9),PR=$P(N,U,8)

 S COM=$P($G(^AUPNPAT(DFN,11)),U,18),HRCN=$$HRCN^ADGF

 S UTL=PR_U_AGE_U_WD_U_TS_U_COM_U_FAC

 ; -- death, newborn or other

 I $D(^DPT(DFN,.35)),$P($P(^(.35),U),".")=RD D DEATH Q

 I $D(^DIC(45.7,"B","NEWBORN",TS)) D NWBRN Q

 D OTHER Q

 ;

2 ; -- ward

 ; -- newborn

 I $D(^DIC(45.7,"B","NEWBORN",TS)) D  Q

 . I $$ONE S $P(DGWD("NB",WD),U,6)=$P(DGWD("NB",WD),U,6)+1

 . S $P(DGWD("NB",WD),U,Z)=$P(DGWD("NB",WD),U,Z)+1

 . S DGLWD("NB",WD)=DGLWD("NB",WD)+$$LOS2

 ; -- all other

 I $$ONE S $P(DGWD(WD),U,6)=$P(DGWD(WD),U,6)+1

 S $P(DGWD(WD),U,Z)=$P(DGWD(WD),U,Z)+1

 S DGLWD(WD)=DGLWD(WD)+$$LOS2 Q

 ;

3 ; -- treating specialty

 ; -- peds

 I +AGE<DGADULT D  Q

 . S $P(DGTSP(TS),U,Z)=$P(DGTSP(TS),U,Z)+1

 . I $$ONE S $P(DGTSP(TS),U,6)=$P(DGTSP(TS),U,6)+1

 . S DGLTSP(TS)=DGLTSP(TS)+$$LOS6

 ; -- adults

 S $P(DGTSA(TS),U,Z)=$P(DGTSA(TS),U,Z)+1

 I $$ONE S $P(DGTSA(TS),U,6)=$P(DGTSA(TS),U,6)+1

 S DGLTSA(TS)=DGLTSA(TS)+$$LOS6 Q

 ;

DEATH ; -- deceased patients

 S:GL ^TMP("DGZADS",$J,"DT",NAME,HRCN,IFN)=UTL

 S DGT3D=DGT3D+1,Z=5 Q

 ;

NWBRN ; -- newborn patients

 S:GL ^TMP("DGZADS",$J,"DN",NAME,HRCN,IFN)=UTL

 S DGT3N=DGT3N+1,Z=2 Q

 ;

OTHER ; -- all other patients

 S:GL ^TMP("DGZADS",$J,"AD",NAME,HRCN,IFN)=UTL

 S DGT30=DGT30+1,Z=2 Q

 ;

MIP() ; --  movement, ifn, previous

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

 ;

MTSP() ; -- movement, ts, previous

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

 ;

ONE() ; -- one day patients

 Q $S($P(^DGPM($P(^DGPM(IFN,0),U,14),0),".")=RD:1,1:0)

 ;

AGE() ; -- age at admission

 ;N X,X1,X2 S X1=DGDT,X2=$P(N,U,3) D ^%DTC Q:'X "" Q X\365.25

 N X,X1,X2 S X1=+$G(^DGPM(+$P(^DGPM(IFN,0),U,14),0)),X2=$P(N,U,3) D ^%DTC Q:'X "" Q X\365.25 ;IHS/ANMC/LJF/ENM 3/22/99

 ;

LOS2() ; -- ward los

 N X,X1,X2 S X1=+^DGPM(+IFN,0),X2=+^DGPM(+$$MIP,0) D ^%DTC Q $S(X:X,1:1)

 ;

LOS6() ; -- t.s. los

 N X,X1,X2 S X1=+^DGPM(+IFN,0),X2=+^DGPM(+$$MTSP,0) D ^%DTC Q $S(X:X,1:1)

ADGAD3    ; IHS/ADC/PDW/ENM - A&D DISCHARGES ; [ 05/19/2000  10:29 AM ]

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

 +2       ;

 +3       ; Variables GL, RD, FR, TO used by VA G&L routines.

 +4       ;

 +5        NEW DFN,IFN,DGDT,NAME,FAC,WD,COM,PR,TS,AGE,HRCN,CA,N,UTL,ID,Z

A         ; -- main

 +1        DO L3

           QUIT 

 +2       ;

L3        ; -- loop discharges 

 +1        SET DGDT=FR

           FOR 

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

               IF 'DGDT!(DGDT>TO)

                   QUIT 

               Begin DoDot:1

 +2                SET DFN=0

                   FOR 

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

                       IF 'DFN

                           QUIT 

                       Begin DoDot:2

 +3                        SET IFN=0

                           FOR 

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

                               IF 'IFN

                                   QUIT 

                               DO 1

                               DO 2

                               DO 3

                       End DoDot:2

               End DoDot:1

 +4        QUIT 

 +5       ;

1          SET ID=9999999.9999999-DGDT

 +1        SET N=$GET(^DPT(+DFN,0))

           SET NAME=$PIECE(N,U)

           SET AGE=$$AGE

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

           SET FAC=$PIECE(N,U,5)

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

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

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

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

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

           SET PR=$PIECE(N,U,8)

 +5        SET COM=$PIECE($GET(^AUPNPAT(DFN,11)),U,18)

           SET HRCN=$$HRCN^ADGF

 +6        SET UTL=PR_U_AGE_U_WD_U_TS_U_COM_U_FAC

 +7       ; -- death, newborn or other

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

               IF $PIECE($PIECE(^(.35),U),".")=RD

                   DO DEATH

                   QUIT 

 +9        IF $DATA(^DIC(45.7,"B","NEWBORN",TS))

               DO NWBRN

               QUIT 

 +10       DO OTHER

           QUIT 

 +11      ;

2         ; -- ward

 +1       ; -- newborn

 +2        IF $DATA(^DIC(45.7,"B","NEWBORN",TS))

               Begin DoDot:1

 +3                IF $$ONE

                       SET $PIECE(DGWD("NB",WD),U,6)=$PIECE(DGWD("NB",WD),U,6)+1

 +4                SET $PIECE(DGWD("NB",WD),U,Z)=$PIECE(DGWD("NB",WD),U,Z)+1

 +5                SET DGLWD("NB",WD)=DGLWD("NB",WD)+$$LOS2

               End DoDot:1

               QUIT 

 +6       ; -- all other

 +7        IF $$ONE

               SET $PIECE(DGWD(WD),U,6)=$PIECE(DGWD(WD),U,6)+1

 +8        SET $PIECE(DGWD(WD),U,Z)=$PIECE(DGWD(WD),U,Z)+1

 +9        SET DGLWD(WD)=DGLWD(WD)+$$LOS2

           QUIT 

 +10      ;

3         ; -- treating specialty

 +1       ; -- peds

 +2        IF +AGE<DGADULT

               Begin DoDot:1

 +3                SET $PIECE(DGTSP(TS),U,Z)=$PIECE(DGTSP(TS),U,Z)+1

 +4                IF $$ONE

                       SET $PIECE(DGTSP(TS),U,6)=$PIECE(DGTSP(TS),U,6)+1

 +5                SET DGLTSP(TS)=DGLTSP(TS)+$$LOS6

               End DoDot:1

               QUIT 

 +6       ; -- adults

 +7        SET $PIECE(DGTSA(TS),U,Z)=$PIECE(DGTSA(TS),U,Z)+1

 +8        IF $$ONE

               SET $PIECE(DGTSA(TS),U,6)=$PIECE(DGTSA(TS),U,6)+1

 +9        SET DGLTSA(TS)=DGLTSA(TS)+$$LOS6

           QUIT 

 +10      ;

DEATH     ; -- deceased patients

 +1        IF GL

               SET ^TMP("DGZADS",$JOB,"DT",NAME,HRCN,IFN)=UTL

 +2        SET DGT3D=DGT3D+1

           SET Z=5

           QUIT 

 +3       ;

NWBRN     ; -- newborn patients

 +1        IF GL

               SET ^TMP("DGZADS",$JOB,"DN",NAME,HRCN,IFN)=UTL

 +2        SET DGT3N=DGT3N+1

           SET Z=2

           QUIT 

 +3       ;

OTHER     ; -- all other patients

 +1        IF GL

               SET ^TMP("DGZADS",$JOB,"AD",NAME,HRCN,IFN)=UTL

 +2        SET DGT30=DGT30+1

           SET Z=2

           QUIT 

 +3       ;

MIP()     ; --  movement, ifn, previous

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

 +2       ;

MTSP()    ; -- movement, ts, previous

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

 +2       ;

ONE()     ; -- one day patients

 +1        QUIT $SELECT($PIECE(^DGPM($PIECE(^DGPM(IFN,0),U,14),0),".")=RD:1,1:0)

 +2       ;

AGE()     ; -- age at admission

 +1       ;N X,X1,X2 S X1=DGDT,X2=$P(N,U,3) D ^%DTC Q:'X "" Q X\365.25

 +2       ;IHS/ANMC/LJF/ENM 3/22/99

           NEW X,X1,X2

           SET X1=+$GET(^DGPM(+$PIECE(^DGPM(IFN,0),U,14),0))

           SET X2=$PIECE(N,U,3)

           DO ^%DTC

           IF 'X

               QUIT ""

           QUIT X\365.25

 +3       ;

LOS2()    ; -- ward los

 +1        NEW X,X1,X2

           SET X1=+^DGPM(+IFN,0)

           SET X2=+^DGPM(+$$MIP,0)

           DO ^%DTC

           QUIT $SELECT(X:X,1:1)

 +2       ;

LOS6()    ; -- t.s. los

 +1        NEW X,X1,X2

           SET X1=+^DGPM(+IFN,0)

           SET X2=+^DGPM(+$$MTSP,0)

           DO ^%DTC

           QUIT $SELECT(X:X,1:1)