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)
