- 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)
