- ADGAD1 ; IHS/ADC/PDW/ENM - A&D ADMISSIONS ; [ 02/26/2004 11:24 AM ]
- ;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999
- ;
- ; RD,GL is defined by VA routine.
- ;
- N FR,TO,IFN,DFN,N,NAME,AGE,WD,FAC,COM,HRCN,UTL,PR,TS,X,X1,X2,DGDT
- A ;--main
- D INI,LP1,^ADGAD3,^ADGAD2,^ADGAD6,^ADGAD4,^ADGAD5,Q Q
- ;
- INI ;--initialize variables
- S DGDATE=RD,DGADULT=$P($G(^DG(43,1,9999999)),U,5)
- S X1=RD,X2=-1 D C^%DTC S FR=X_".999999",TO=$P(RD,".",1)_".999999"
- S (DGT10,DGT1N,DGT30,DGT3N,DGT3D,DGTSI,DGT2,DGT6)=0
- S WD=0 F S WD=$O(^DIC(42,WD)) Q:'WD D
- . S (DGWD(WD),DGLWD(WD),DGWD("NB",WD),DGLWD("NB",WD))=0
- S TS=0 F S TS=$O(^DIC(45.7,TS)) Q:'TS D
- . S (DGTSA(TS),DGTSP(TS),DGLTSA(TS),DGLTSP(TS))=0
- Q
- ;
- LP1 ;--loop admissions
- S DGDT=FR F S DGDT=$O(^DGPM("AMV1",DGDT)) Q:'DGDT!(DGDT>TO) 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 1
- Q
- ;
- 1 S N=^DPT(DFN,0),NAME=$P(N,U),AGE=$$AGE
- S N=^DGPM(IFN,0),WD=$P(N,U,6),FAC=$P(N,U,5)
- S N=$$RPM,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
- ; -- census counts
- ; -- ward (newborn vs all others)
- I $D(^DIC(45.7,"B","NEWBORN",+TS)) D
- . S:GL ^TMP("DGZADS",$J,"AN",NAME,HRCN,IFN)=UTL
- . S DGT1N=DGT1N+1,DGWD("NB",WD)=DGWD("NB",WD)+1
- I '$D(^DIC(45.7,"B","NEWBORN",+TS)) D
- . S:GL ^TMP("DGZADS",$J,"AA",NAME,HRCN,IFN)=UTL
- . S DGT10=DGT10+1,DGWD(WD)=DGWD(WD)+1
- ; -- treating specialty
- ; -- peds counts
- I +AGE<DGADULT,TS]"" S DGTSP(TS)=DGTSP(TS)+1 Q
- ; -- adult counts
- I TS]"" S DGTSA(TS)=DGTSA(TS)+1 Q
- Q ;IHS/DSD/ENM 03/15/99
- ;
- Q ;--cleanup all
- K DGT10,DGT1N,DGT30,DGT3N,DGT3D,DGTSI,DGT2,DGT6
- K DGADULT,DGLWD,DGLTSA,DGLTSP,DGWD,DGTSA,DGTSP
- ;--unlock census files
- L -^ADGWD L -^ADGTX Q
- ;
- RPM() ;--related mvmnt
- N X S X=$O(^DGPM("APHY",IFN,0)) Q $G(^DGPM(+X,0))
- ;
- AGE() ;--age at admit
- N X,X1,X2 S X1=DGDT,X2=$P(N,U,3) D ^%DTC Q:'X "" Q X\365.25
- ;
- AS() ;--admitting service (yes=1,no=0)
- Q $S($P($G(^DIC(45.7,+TS,9999999)),U,3)="Y":1,1:0)
- ADGAD1 ; IHS/ADC/PDW/ENM - A&D ADMISSIONS ; [ 02/26/2004 11:24 AM ]
- +1 ;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999
- +2 ;
- +3 ; RD,GL is defined by VA routine.
- +4 ;
- +5 NEW FR,TO,IFN,DFN,N,NAME,AGE,WD,FAC,COM,HRCN,UTL,PR,TS,X,X1,X2,DGDT
- A ;--main
- +1 DO INI
- DO LP1
- DO ^ADGAD3
- DO ^ADGAD2
- DO ^ADGAD6
- DO ^ADGAD4
- DO ^ADGAD5
- DO Q
- QUIT
- +2 ;
- INI ;--initialize variables
- +1 SET DGDATE=RD
- SET DGADULT=$PIECE($GET(^DG(43,1,9999999)),U,5)
- +2 SET X1=RD
- SET X2=-1
- DO C^%DTC
- SET FR=X_".999999"
- SET TO=$PIECE(RD,".",1)_".999999"
- +3 SET (DGT10,DGT1N,DGT30,DGT3N,DGT3D,DGTSI,DGT2,DGT6)=0
- +4 SET WD=0
- FOR
- SET WD=$ORDER(^DIC(42,WD))
- IF 'WD
- QUIT
- Begin DoDot:1
- +5 SET (DGWD(WD),DGLWD(WD),DGWD("NB",WD),DGLWD("NB",WD))=0
- End DoDot:1
- +6 SET TS=0
- FOR
- SET TS=$ORDER(^DIC(45.7,TS))
- IF 'TS
- QUIT
- Begin DoDot:1
- +7 SET (DGTSA(TS),DGTSP(TS),DGLTSA(TS),DGLTSP(TS))=0
- End DoDot:1
- +8 QUIT
- +9 ;
- LP1 ;--loop admissions
- +1 SET DGDT=FR
- FOR
- SET DGDT=$ORDER(^DGPM("AMV1",DGDT))
- IF 'DGDT!(DGDT>TO)
- QUIT
- Begin DoDot:1
- +2 SET DFN=0
- FOR
- SET DFN=$ORDER(^DGPM("AMV1",DGDT,DFN))
- IF 'DFN
- QUIT
- Begin DoDot:2
- +3 SET IFN=0
- FOR
- SET IFN=$ORDER(^DGPM("AMV1",DGDT,DFN,IFN))
- IF 'IFN
- QUIT
- DO 1
- End DoDot:2
- End DoDot:1
- +4 QUIT
- +5 ;
- 1 SET N=^DPT(DFN,0)
- SET NAME=$PIECE(N,U)
- SET AGE=$$AGE
- +1 SET N=^DGPM(IFN,0)
- SET WD=$PIECE(N,U,6)
- SET FAC=$PIECE(N,U,5)
- +2 SET N=$$RPM
- SET TS=$PIECE(N,U,9)
- SET PR=$PIECE(N,U,8)
- +3 SET COM=$PIECE($GET(^AUPNPAT(DFN,11)),U,18)
- SET HRCN=$$HRCN^ADGF
- +4 SET UTL=PR_U_AGE_U_WD_U_TS_U_COM_U_FAC
- +5 ; -- census counts
- +6 ; -- ward (newborn vs all others)
- +7 IF $DATA(^DIC(45.7,"B","NEWBORN",+TS))
- Begin DoDot:1
- +8 IF GL
- SET ^TMP("DGZADS",$JOB,"AN",NAME,HRCN,IFN)=UTL
- +9 SET DGT1N=DGT1N+1
- SET DGWD("NB",WD)=DGWD("NB",WD)+1
- End DoDot:1
- +10 IF '$DATA(^DIC(45.7,"B","NEWBORN",+TS))
- Begin DoDot:1
- +11 IF GL
- SET ^TMP("DGZADS",$JOB,"AA",NAME,HRCN,IFN)=UTL
- +12 SET DGT10=DGT10+1
- SET DGWD(WD)=DGWD(WD)+1
- End DoDot:1
- +13 ; -- treating specialty
- +14 ; -- peds counts
- +15 IF +AGE<DGADULT
- IF TS]""
- SET DGTSP(TS)=DGTSP(TS)+1
- QUIT
- +16 ; -- adult counts
- +17 IF TS]""
- SET DGTSA(TS)=DGTSA(TS)+1
- QUIT
- +18 ;IHS/DSD/ENM 03/15/99
- QUIT
- +19 ;
- Q ;--cleanup all
- +1 KILL DGT10,DGT1N,DGT30,DGT3N,DGT3D,DGTSI,DGT2,DGT6
- +2 KILL DGADULT,DGLWD,DGLTSA,DGLTSP,DGWD,DGTSA,DGTSP
- +3 ;--unlock census files
- +4 LOCK -^ADGWD
- LOCK -^ADGTX
- QUIT
- +5 ;
- RPM() ;--related mvmnt
- +1 NEW X
- SET X=$ORDER(^DGPM("APHY",IFN,0))
- QUIT $GET(^DGPM(+X,0))
- +2 ;
- AGE() ;--age at admit
- +1 NEW X,X1,X2
- SET X1=DGDT
- SET X2=$PIECE(N,U,3)
- DO ^%DTC
- IF 'X
- QUIT ""
- QUIT X\365.25
- +2 ;
- AS() ;--admitting service (yes=1,no=0)
- +1 QUIT $SELECT($PIECE($GET(^DIC(45.7,+TS,9999999)),U,3)="Y":1,1:0)
