- ADGRALC ; IHS/ADC/PDW/ENM - READMISSION LISTINGS (CALC) ; [ 03/25/1999 11:48 AM ]
- ;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999
- ;
- K ^TMP("DGZRAL",$J)
- A ; -- driver
- D LP1 G ^ADGRALP
- ;
- LP1 ; -- loop admissions
- N WARD,DX,DGRE,DGDSA,DGDS,NAME,DGDT,TS,DFN,IFN,UTL,WD,N,ED
- S DGDT=DGBDT-.0001,ED=DGEDT+.2400
- F S DGDT=$O(^DGPM("AMV1",DGDT)) Q:'DGDT!(DGDT>ED) 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 ; -- check for readmission
- NEW DGPMDA,NAME,WARD,TS,DX,UTL
- S DGPMDA=IFN D ^ADGREADM Q:'$D(DGRE)
- S NAME=$P($G(^DPT(DFN,0)),U)
- S N=$G(^DGPM(IFN,0)),WD=$P(N,U,6),DX=$P(N,U,10)
- I DGTYP=2,DGSRT'="A" Q:WD'=+DGSRT
- S WARD=$P($G(^DIC(42,+WD,0)),U),TS=$$TS
- I DGTYP=3,DGSRT'="A" Q:TS'=+DGSRT
- S TS=$S('TS:"NO SERVICE",1:$P($G(^DIC(45.7,+TS,0)),U))
- ; -- date, alpha
- I DGTYP=1 D Q
- . S UTL=WARD_U_TS_U_DX_U_DGRE_U_DGDSA_U_DGDS_U_$$M1PD_U_$$M1P
- . S ^TMP("DGZRAL",$J,$P(DGDT,"."),DGDT,DFN)=UTL
- ; -- ward, date, alpha
- I DGTYP=2 D Q
- . S UTL=TS_U_DX_U_DGRE_U_DGDSA_U_DGDS_U_$$M1PD_U_$$M1P
- . S ^TMP("DGZRAL",$J,WARD,DGDT,NAME,DFN)=UTL
- ; -- service, date, alpha
- S UTL=WARD_U_DX_U_DGRE_U_DGDSA_U_DGDS_U_$$M1PD_U_$$M1P
- S ^TMP("DGZRAL",$J,TS,DGDT,NAME,DFN)=UTL
- Q
- ;
- Q ; -- cleanup
- K WARD,DX,DGRE,DGDSA,DGDS,NAME,DGDT,TS,DFN,IFN,UTL,WD,N,ED Q
- ;
- M1P() ; -- movement, admission, previous
- Q $O(^DGPM("ATID1",DFN,+$O(^DGPM("ATID1",DFN,9999999.9999999-DGDT)),0))
- ;
- M1PD() ; -- movement, admission, previous, date
- Q +$G(^DGPM(+$$M1P,0))
- ;
- TS() ; -- treating specialty
- Q $P($G(^DGPM(+$O(^DGPM("APHY",IFN,0)),0)),U,9)
- ADGRALC ; IHS/ADC/PDW/ENM - READMISSION LISTINGS (CALC) ; [ 03/25/1999 11:48 AM ]
- +1 ;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999
- +2 ;
- +3 KILL ^TMP("DGZRAL",$JOB)
- A ; -- driver
- +1 DO LP1
- GOTO ^ADGRALP
- +2 ;
- LP1 ; -- loop admissions
- +1 NEW WARD,DX,DGRE,DGDSA,DGDS,NAME,DGDT,TS,DFN,IFN,UTL,WD,N,ED
- +2 SET DGDT=DGBDT-.0001
- SET ED=DGEDT+.2400
- +3 FOR
- SET DGDT=$ORDER(^DGPM("AMV1",DGDT))
- IF 'DGDT!(DGDT>ED)
- QUIT
- Begin DoDot:1
- +4 SET DFN=0
- FOR
- SET DFN=$ORDER(^DGPM("AMV1",DGDT,DFN))
- IF 'DFN
- QUIT
- Begin DoDot:2
- +5 SET IFN=0
- FOR
- SET IFN=$ORDER(^DGPM("AMV1",DGDT,DFN,IFN))
- IF 'IFN
- QUIT
- DO 1
- End DoDot:2
- End DoDot:1
- +6 QUIT
- +7 ;
- 1 ; -- check for readmission
- +1 NEW DGPMDA,NAME,WARD,TS,DX,UTL
- +2 SET DGPMDA=IFN
- DO ^ADGREADM
- IF '$DATA(DGRE)
- QUIT
- +3 SET NAME=$PIECE($GET(^DPT(DFN,0)),U)
- +4 SET N=$GET(^DGPM(IFN,0))
- SET WD=$PIECE(N,U,6)
- SET DX=$PIECE(N,U,10)
- +5 IF DGTYP=2
- IF DGSRT'="A"
- IF WD'=+DGSRT
- QUIT
- +6 SET WARD=$PIECE($GET(^DIC(42,+WD,0)),U)
- SET TS=$$TS
- +7 IF DGTYP=3
- IF DGSRT'="A"
- IF TS'=+DGSRT
- QUIT
- +8 SET TS=$SELECT('TS:"NO SERVICE",1:$PIECE($GET(^DIC(45.7,+TS,0)),U))
- +9 ; -- date, alpha
- +10 IF DGTYP=1
- Begin DoDot:1
- +11 SET UTL=WARD_U_TS_U_DX_U_DGRE_U_DGDSA_U_DGDS_U_$$M1PD_U_$$M1P
- +12 SET ^TMP("DGZRAL",$JOB,$PIECE(DGDT,"."),DGDT,DFN)=UTL
- End DoDot:1
- QUIT
- +13 ; -- ward, date, alpha
- +14 IF DGTYP=2
- Begin DoDot:1
- +15 SET UTL=TS_U_DX_U_DGRE_U_DGDSA_U_DGDS_U_$$M1PD_U_$$M1P
- +16 SET ^TMP("DGZRAL",$JOB,WARD,DGDT,NAME,DFN)=UTL
- End DoDot:1
- QUIT
- +17 ; -- service, date, alpha
- +18 SET UTL=WARD_U_DX_U_DGRE_U_DGDSA_U_DGDS_U_$$M1PD_U_$$M1P
- +19 SET ^TMP("DGZRAL",$JOB,TS,DGDT,NAME,DFN)=UTL
- +20 QUIT
- +21 ;
- Q ; -- cleanup
- +1 KILL WARD,DX,DGRE,DGDSA,DGDS,NAME,DGDT,TS,DFN,IFN,UTL,WD,N,ED
- QUIT
- +2 ;
- M1P() ; -- movement, admission, previous
- +1 QUIT $ORDER(^DGPM("ATID1",DFN,+$ORDER(^DGPM("ATID1",DFN,9999999.9999999-DGDT)),0))
- +2 ;
- M1PD() ; -- movement, admission, previous, date
- +1 QUIT +$GET(^DGPM(+$$M1P,0))
- +2 ;
- TS() ; -- treating specialty
- +1 QUIT $PIECE($GET(^DGPM(+$ORDER(^DGPM("APHY",IFN,0)),0)),U,9)
