ADGAD6.m

ADGAD6 ; IHS/ADC/PDW/ENM - A&D TS XFR ; [ 03/25/1999  11:48 AM ]

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

 ;

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

 ;

 N IFN,DFN,DGDT,NAME,CA,ID,TS,TSP,AGE,N

A ; -- main

 D L6,UTL Q

 ;

L6 ; -- loop ts

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

 Q

 ;

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

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

 ; -- a screen of some sort to check for a null ts should be here maw

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

 ; -- ts

 S:GL ^TMP("DGZADS",$J,"TS",NAME,DFN,IFN)=TSP_U_TS

 S DGT6=DGT6+1

 ; -- peds

 I +AGE<DGADULT D  Q

 . S DGLTSP(+TSP)=DGLTSP(+TSP)+$$LOS

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

 . S $P(DGTSP(+TSP),U,4)=$P(DGTSP(+TSP),U,4)+1

 ; -- adult

 S DGLTSA(+TSP)=DGLTSA(TSP)+$$LOS

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

 S $P(DGTSA(+TSP),U,4)=$P(DGTSA(+TSP),U,4)+1 Q

 ;

UTL ; -- days total (adm,dis,trn,...)

 S ^TMP("DGZADS",$J,"ZZ")=DGT10_U_DGT30_U_DGT1N_U_DGT3N_U_DGT3D_U_DGTSI_U_DGT2_U_DGT6 Q

 ;

AGE() ; -- age at admission

 N X1,X2,X S X1=+^DGPM(CA,0),X2=+$P(^DPT(DFN,0),U,3) D ^%DTC Q X\365.25

 ;

MP() ; -- movement, previous

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

 ;

M6P() ; -- movement, ts, previous

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

 ;

LOS() ; -- ts los

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

 ;

T() ; -- related movement transaction type

 Q $P($G(^DGPM(+$P($G(^DGPM(IFN,0)),U,24),0)),U,2)

ADGAD6    ; IHS/ADC/PDW/ENM - A&D TS XFR ; [ 03/25/1999  11:48 AM ]

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

 +2       ;

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

 +4       ;

 +5        NEW IFN,DFN,DGDT,NAME,CA,ID,TS,TSP,AGE,N

A         ; -- main

 +1        DO L6

           DO UTL

           QUIT 

 +2       ;

L6        ; -- loop ts

 +1        SET DGDT=FR

           FOR 

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

               IF 'DGDT!(DGDT>TO)

                   QUIT 

               Begin DoDot:1

 +2                SET DFN=0

                   FOR 

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

                       IF 'DFN

                           QUIT 

                       Begin DoDot:2

 +3                        SET IFN=0

                           FOR 

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

                               IF 'IFN

                                   QUIT 

                               IF $$T=1

                                   QUIT 

                               DO 1

                       End DoDot:2

               End DoDot:1

 +4        QUIT 

 +5       ;

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

           SET ID=9999999.9999999-DGDT

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

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

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

           SET AGE=$$AGE

 +2       ; -- a screen of some sort to check for a null ts should be here maw

 +3        SET TSP=$PIECE($GET(^DGPM(+$$M6P,0)),U,9)

 +4       ; -- ts

 +5        IF GL

               SET ^TMP("DGZADS",$JOB,"TS",NAME,DFN,IFN)=TSP_U_TS

 +6        SET DGT6=DGT6+1

 +7       ; -- peds

 +8        IF +AGE<DGADULT

               Begin DoDot:1

 +9                SET DGLTSP(+TSP)=DGLTSP(+TSP)+$$LOS

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

 +11               SET $PIECE(DGTSP(+TSP),U,4)=$PIECE(DGTSP(+TSP),U,4)+1

               End DoDot:1

               QUIT 

 +12      ; -- adult

 +13       SET DGLTSA(+TSP)=DGLTSA(TSP)+$$LOS

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

 +15       SET $PIECE(DGTSA(+TSP),U,4)=$PIECE(DGTSA(+TSP),U,4)+1

           QUIT 

 +16      ;

UTL       ; -- days total (adm,dis,trn,...)

 +1        SET ^TMP("DGZADS",$JOB,"ZZ")=DGT10_U_DGT30_U_DGT1N_U_DGT3N_U_DGT3D_U_DGTSI_U_DGT2_U_DGT6

           QUIT 

 +2       ;

AGE()     ; -- age at admission

 +1        NEW X1,X2,X

           SET X1=+^DGPM(CA,0)

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

           DO ^%DTC

           QUIT X\365.25

 +2       ;

MP()      ; -- movement, previous

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

 +2       ;

M6P()     ; -- movement, ts, previous

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

 +2       ;

LOS()     ; -- ts los

 +1        NEW X,X1,X2

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

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

           DO ^%DTC

           QUIT X

 +2       ;

T()       ; -- related movement transaction type

 +1        QUIT $PIECE($GET(^DGPM(+$PIECE($GET(^DGPM(IFN,0)),U,24),0)),U,2)