ADGAD2.m

ADGAD2 ; IHS/ADC/PDW/ENM - A&D WARD XFR ; [ 05/19/2000  10:26 AM ]

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

 ;

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

 ;

 N WD,IFN,WARD,DFN,TS,PR,N,NAME,AGE,COM,HRCN,UTL,ID,DGDT,TY,CA,TYP,WDP

 N TSP

A ; -- main

 D SI,L2 Q

 ;

SI ; -- loop "CN" x-ref

 S WARD="" F  S WARD=$O(^DPT("CN",WARD)) Q:WARD=""  D

 . S DFN=0 F  S DFN=$O(^DPT("CN",WARD,DFN)) Q:'DFN  D SI1

 Q

 ;

SI1 ; -- seriously ill

 Q:'$D(^DPT(DFN,"DAC"))  Q:$P(^("DAC"),U)=""

 S WD=$O(^DIC(42,"B",WARD,0)),IFN=^DPT("CN",WARD,DFN)

 S TS=$G(^DPT(DFN,.103)),PR=$G(^DPT(DFN,.104))

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

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

 S UTL=PR_U_AGE_U_WD_U_TS_U_COM,DGTSI=DGTSI+1

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

 Q

 ;

L2 ; -- loop ward transfers

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

 Q

 ;

1 S N=^DPT(DFN,0),NAME=$P(N,U),AGE=$$AGE,ID=9999999.9999999-DGDT

 S N=$G(^DGPM(+IFN,0)),TY=+$P(N,U,4),WD=+$P(N,U,6),CA=+$P(N,U,14)

 S N=$G(^DGPM(+$$MR,0)),TS=$S($P(N,U,9):$P(N,U,9),1:$$TSP),TSP=$$TSP

 S N=$G(^DGPM(+$$MP,0)),TYP=$S($P(N,U,2)=2:$P(N,U,4),1:0),WDP=$P(N,U,6)

 ; -- utility nodes

 Q:'GL

 ; -- absences

 I TY>11 S ^TMP("DGZADS",$J,"AB",NAME,DFN,IFN)=WDP_U_TY Q

 I TYP>11 S ^TMP("DGZADS",$J,"AB1",NAME,DFN,IFN)=TYP_U_WD Q

 ; -- ward transfers

 S ^TMP("DGZADS",$J,"WT",NAME,DFN,IFN)=WDP_U_WD Q

 ;

2 ; -- census counts   

 S DGT2=DGT2+1

 ; -- newborn

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

 . S DGLWD("NB",WDP)=DGLWD("NB",WDP)+$$LOS

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

 . S $P(DGWD("NB",WDP),U,4)=$P(DGWD("NB",WDP),U,4)+1

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

 . S DGLWD("NB",WDP)=DGLWD("NB",WDP)+$$LOS

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

 . S $P(DGWD("NB",WDP),U,4)=$P(DGWD("NB",WDP),U,4)+1

 ; -- other

 S DGLWD(WDP)=DGLWD(WDP)+$$LOS

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

 S $P(DGWD(WDP),U,4)=$P(DGWD(WDP),U,4)+1 Q

 ;

AGE() ; -- age at admission

 ;N X,X1,X2 S X1=+^DGPM(+IFN,0),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

 ;

MR() ; -- movement, related, ien

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

 ;

MP() ; -- movement, previous, ien

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

 ;

TSP() ; -- treating specialty, previous

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

 ;

LOS() ; -- ward los

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

ADGAD2    ; IHS/ADC/PDW/ENM - A&D WARD XFR ; [ 05/19/2000  10:26 AM ]

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

 +2       ;

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

 +4       ;

 +5        NEW WD,IFN,WARD,DFN,TS,PR,N,NAME,AGE,COM,HRCN,UTL,ID,DGDT,TY,CA,TYP,WDP

 +6        NEW TSP

A         ; -- main

 +1        DO SI

           DO L2

           QUIT 

 +2       ;

SI        ; -- loop "CN" x-ref

 +1        SET WARD=""

           FOR 

               SET WARD=$ORDER(^DPT("CN",WARD))

               IF WARD=""

                   QUIT 

               Begin DoDot:1

 +2                SET DFN=0

                   FOR 

                       SET DFN=$ORDER(^DPT("CN",WARD,DFN))

                       IF 'DFN

                           QUIT 

                       DO SI1

               End DoDot:1

 +3        QUIT 

 +4       ;

SI1       ; -- seriously ill

 +1        IF '$DATA(^DPT(DFN,"DAC"))

               QUIT 

           IF $PIECE(^("DAC"),U)=""

               QUIT 

 +2        SET WD=$ORDER(^DIC(42,"B",WARD,0))

           SET IFN=^DPT("CN",WARD,DFN)

 +3        SET TS=$GET(^DPT(DFN,.103))

           SET PR=$GET(^DPT(DFN,.104))

 +4        SET N=^DPT(DFN,0)

           SET NAME=$PIECE(N,U)

           SET AGE=$$AGE

 +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

           SET DGTSI=DGTSI+1

 +7        IF GL

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

 +8        QUIT 

 +9       ;

L2        ; -- loop ward transfers

 +1        SET DGDT=FR

           FOR 

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

               IF 'DGDT!(DGDT>TO)

                   QUIT 

               Begin DoDot:1

 +2                SET DFN=0

                   FOR 

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

                       IF 'DFN

                           QUIT 

                       Begin DoDot:2

 +3                        SET IFN=0

                           FOR 

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

                               IF 'IFN

                                   QUIT 

                               DO 1

                               DO 2

                       End DoDot:2

               End DoDot:1

 +4        QUIT 

 +5       ;

1          SET N=^DPT(DFN,0)

           SET NAME=$PIECE(N,U)

           SET AGE=$$AGE

           SET ID=9999999.9999999-DGDT

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

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

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

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

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

           SET TS=$SELECT($PIECE(N,U,9):$PIECE(N,U,9),1:$$TSP)

           SET TSP=$$TSP

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

           SET TYP=$SELECT($PIECE(N,U,2)=2:$PIECE(N,U,4),1:0)

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

 +4       ; -- utility nodes

 +5        IF 'GL

               QUIT 

 +6       ; -- absences

 +7        IF TY>11

               SET ^TMP("DGZADS",$JOB,"AB",NAME,DFN,IFN)=WDP_U_TY

               QUIT 

 +8        IF TYP>11

               SET ^TMP("DGZADS",$JOB,"AB1",NAME,DFN,IFN)=TYP_U_WD

               QUIT 

 +9       ; -- ward transfers

 +10       SET ^TMP("DGZADS",$JOB,"WT",NAME,DFN,IFN)=WDP_U_WD

           QUIT 

 +11      ;

2         ; -- census counts   

 +1        SET DGT2=DGT2+1

 +2       ; -- newborn

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

               Begin DoDot:1

 +4                SET DGLWD("NB",WDP)=DGLWD("NB",WDP)+$$LOS

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

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

               End DoDot:1

               QUIT 

 +7        IF $DATA(^DIC(45.7,"B","NEWBORN",+TSP))

               Begin DoDot:1

 +8                SET DGLWD("NB",WDP)=DGLWD("NB",WDP)+$$LOS

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

 +10               SET $PIECE(DGWD("NB",WDP),U,4)=$PIECE(DGWD("NB",WDP),U,4)+1

               End DoDot:1

               QUIT 

 +11      ; -- other

 +12       SET DGLWD(WDP)=DGLWD(WDP)+$$LOS

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

 +14       SET $PIECE(DGWD(WDP),U,4)=$PIECE(DGWD(WDP),U,4)+1

           QUIT 

 +15      ;

AGE()     ; -- age at admission

 +1       ;N X,X1,X2 S X1=+^DGPM(+IFN,0),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       ;

MR()      ; -- movement, related, ien

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

 +2       ;

MP()      ; -- movement, previous, ien

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

 +2       ;

TSP()     ; -- treating specialty, previous

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

 +2       ;

LOS()     ; -- ward los

 +1        NEW X,X1,X2

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

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

           DO ^%DTC

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