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