ADGPTLC ; IHS/ADC/PDW/ENM - CALCULATE PATIENT LIST ; [ 03/25/1999 11:48 AM ]
;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999
;
K ^TMP("DGZPTL",$J)
; -- main
N DFN,NAME,WD,BED,RM,IFN,AD,DX,TS,PR,N,RMBD,RB,COM,X,Y
D AWD:'DGWST,OWD:DGWST
I $D(^ADGDS("CN"))!$D(^SRF("AIHS1","OB")) D ^ADGPTLC1
G:DGO=3 ^ADGPTLP1
G ^ADGPTLP
;
AWD ; -- all wards
I DGO'=3 D
. S WD=0 F S WD=$O(^DG(405.4,"W",WD)) Q:'WD D:'$$OOSW(WD)
.. S RB=0 F S RB=$O(^DG(405.4,"W",WD,RB)) Q:'RB D:'$$OOSB(RB)
... S WARD=$P($G(^DIC(42,+WD,0)),U),RMBD=$P($G(^DG(405.4,+RB,0)),U)
... S ^TMP("DGZPTL",$J,"BED",WD,RB)=WARD_"-"_RMBD
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 1
Q
;
OWD ; -- one ward
Q:$$OOSW(DGWST) I DGO'=3 D
. S RB=0 F S RB=$O(^DG(405.4,"W",DGWST,RB)) Q:'RB D:'$$OOSB(RB)
.. S WARD=$P($G(^DIC(42,+DGWST,0)),U),RMBD=$P($G(^DG(405.4,+RB,0)),U)
.. S ^TMP("DGZPTL",$J,"BED",DGWST,RB)=WARD_"-"_RMBD
S WARD=$P(^DIC(42,DGWST,0),U)
S DFN=0 F S DFN=$O(^DPT("CN",WARD,DFN)) Q:'DFN D 1
Q
;
1 S IFN=^DPT("CN",WARD,DFN),NAME=$P(^DPT(DFN,0),U),WD=$G(^DPT(DFN,.1))
S BED=$G(^DPT(DFN,.101)),TS=$G(^(.103)),PR=$G(^(.104))
S RM=WD_"-"_BED,COM=$P($G(^AUPNPAT(DFN,11)),U,18)
S N=$G(^DGPM(IFN,0)),AD=+N,DX=$S(DGO=2:TS,1:$P(N,U,10))
;--alpha list
I DGO=3 D Q
. S ^TMP("DGZPTL",$J,"A",NAME,DFN)=RM_U_AD_U_TS_U_PR_U_COM
;--no room-bed
I $P(RM,"-",2)="" D Q
. S ^TMP("DGZPTL",$J,"WD",RM,DFN)=DFN_U_NAME_U_AD_U_DX_U_PR_U_COM
;--with room-bed
S ^TMP("DGZPTL",$J,"WD",RM)=DFN_U_NAME_U_AD_U_DX_U_PR_U_COM
Q
;
Q ;--cleanup
K DFN,NAME,WD,BED,RM,IFN,AD,DX,TS,PR,N,RMBD,RB,COM Q
;
OOSB(Y) ; -- bed out of service
Q:'$D(^DG(405.4,Y,"I","AINV")) 0
N X S X=$G(^DG(405.4,Y,"I",+$O(^($O(^("AINV",0)),0)),0)) Q:'X 0
Q $S($P(X,U,4)=DT:0,$P(X,U,4)&($P(X,U,4)<DT):0,X=DT:0,X<DT:1,1:0)
;
OOSW(Y) ; -- ward out of service
Q:'$D(^DIC(42,Y,"OOS","AINV")) 0
N X S X=$G(^DIC(42,Y,"OOS",+$O(^($O(^("AINV",0)),0)),0)) Q:'X 0
Q $S($P(X,U,4)=DT:0,$P(X,U,4)&($P(X,U,4)<DT):0,X=DT:0,X<DT:1,1:0)
ADGPTLC ; IHS/ADC/PDW/ENM - CALCULATE PATIENT LIST ; [ 03/25/1999 11:48 AM ]
+1 ;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999
+2 ;
+3 KILL ^TMP("DGZPTL",$JOB)
+4 ; -- main
+5 NEW DFN,NAME,WD,BED,RM,IFN,AD,DX,TS,PR,N,RMBD,RB,COM,X,Y
+6 IF 'DGWST
DO AWD
IF DGWST
DO OWD
+7 IF $DATA(^ADGDS("CN"))!$DATA(^SRF("AIHS1","OB"))
DO ^ADGPTLC1
+8 IF DGO=3
GOTO ^ADGPTLP1
+9 GOTO ^ADGPTLP
+10 ;
AWD ; -- all wards
+1 IF DGO'=3
Begin DoDot:1
+2 SET WD=0
FOR
SET WD=$ORDER(^DG(405.4,"W",WD))
IF 'WD
QUIT
IF '$$OOSW(WD)
Begin DoDot:2
+3 SET RB=0
FOR
SET RB=$ORDER(^DG(405.4,"W",WD,RB))
IF 'RB
QUIT
IF '$$OOSB(RB)
Begin DoDot:3
+4 SET WARD=$PIECE($GET(^DIC(42,+WD,0)),U)
SET RMBD=$PIECE($GET(^DG(405.4,+RB,0)),U)
+5 SET ^TMP("DGZPTL",$JOB,"BED",WD,RB)=WARD_"-"_RMBD
End DoDot:3
End DoDot:2
End DoDot:1
+6 SET WARD=""
FOR
SET WARD=$ORDER(^DPT("CN",WARD))
IF WARD=""
QUIT
Begin DoDot:1
+7 SET DFN=0
FOR
SET DFN=$ORDER(^DPT("CN",WARD,DFN))
IF 'DFN
QUIT
DO 1
End DoDot:1
+8 QUIT
+9 ;
OWD ; -- one ward
+1 IF $$OOSW(DGWST)
QUIT
IF DGO'=3
Begin DoDot:1
+2 SET RB=0
FOR
SET RB=$ORDER(^DG(405.4,"W",DGWST,RB))
IF 'RB
QUIT
IF '$$OOSB(RB)
Begin DoDot:2
+3 SET WARD=$PIECE($GET(^DIC(42,+DGWST,0)),U)
SET RMBD=$PIECE($GET(^DG(405.4,+RB,0)),U)
+4 SET ^TMP("DGZPTL",$JOB,"BED",DGWST,RB)=WARD_"-"_RMBD
End DoDot:2
End DoDot:1
+5 SET WARD=$PIECE(^DIC(42,DGWST,0),U)
+6 SET DFN=0
FOR
SET DFN=$ORDER(^DPT("CN",WARD,DFN))
IF 'DFN
QUIT
DO 1
+7 QUIT
+8 ;
1 SET IFN=^DPT("CN",WARD,DFN)
SET NAME=$PIECE(^DPT(DFN,0),U)
SET WD=$GET(^DPT(DFN,.1))
+1 SET BED=$GET(^DPT(DFN,.101))
SET TS=$GET(^(.103))
SET PR=$GET(^(.104))
+2 SET RM=WD_"-"_BED
SET COM=$PIECE($GET(^AUPNPAT(DFN,11)),U,18)
+3 SET N=$GET(^DGPM(IFN,0))
SET AD=+N
SET DX=$SELECT(DGO=2:TS,1:$PIECE(N,U,10))
+4 ;--alpha list
+5 IF DGO=3
Begin DoDot:1
+6 SET ^TMP("DGZPTL",$JOB,"A",NAME,DFN)=RM_U_AD_U_TS_U_PR_U_COM
End DoDot:1
QUIT
+7 ;--no room-bed
+8 IF $PIECE(RM,"-",2)=""
Begin DoDot:1
+9 SET ^TMP("DGZPTL",$JOB,"WD",RM,DFN)=DFN_U_NAME_U_AD_U_DX_U_PR_U_COM
End DoDot:1
QUIT
+10 ;--with room-bed
+11 SET ^TMP("DGZPTL",$JOB,"WD",RM)=DFN_U_NAME_U_AD_U_DX_U_PR_U_COM
+12 QUIT
+13 ;
Q ;--cleanup
+1 KILL DFN,NAME,WD,BED,RM,IFN,AD,DX,TS,PR,N,RMBD,RB,COM
QUIT
+2 ;
OOSB(Y) ; -- bed out of service
+1 IF '$DATA(^DG(405.4,Y,"I","AINV"))
QUIT 0
+2 NEW X
SET X=$GET(^DG(405.4,Y,"I",+$ORDER(^($ORDER(^("AINV",0)),0)),0))
IF 'X
QUIT 0
+3 QUIT $SELECT($PIECE(X,U,4)=DT:0,$PIECE(X,U,4)&($PIECE(X,U,4)<DT):0,X=DT:0,X<DT:1,1:0)
+4 ;
OOSW(Y) ; -- ward out of service
+1 IF '$DATA(^DIC(42,Y,"OOS","AINV"))
QUIT 0
+2 NEW X
SET X=$GET(^DIC(42,Y,"OOS",+$ORDER(^($ORDER(^("AINV",0)),0)),0))
IF 'X
QUIT 0
+3 QUIT $SELECT($PIECE(X,U,4)=DT:0,$PIECE(X,U,4)&($PIECE(X,U,4)<DT):0,X=DT:0,X<DT:1,1:0)
