- ADGFTRC ; IHS/ADC/PDW/ENM - TRANS BETWEEN FAC(CALC) ; [ 03/25/1999 11:48 AM ]
- ;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999
- ;
- A ; -- driver
- D INI,LP1,LP3 G ^ADGFTRP
- ;
- INI ; -- initialize variables
- K ^TMP("DGZFTRA",$J),^TMP("DGZFTRD",$J)
- ; -- DGI1 & DGI2 = transfer in types
- S DGI1=$O(^DG(405.1,"AIHS1","A2",0))
- S DGI2=$O(^DG(405.1,"AIHS1","A3",0))
- ; -- DGO1 = transfer out type
- S DGO1=$O(^DG(405.1,"AIHS1","D2",0))
- Q
- ;
- LP1 ; -- loop admissions
- N DFN,IFN,N
- S DGDT=DGBDT-.0001,DGEND=DGEDT+.2400
- F S DGDT=$O(^DGPM("AMV1",DGDT)) Q:'DGDT!(DGDT>DGEND) 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=^DGPM(IFN,0),DGT=$P(N,U,4)
- I DGT'=DGI1&(DGT'=DGI2) Q ;admit type not transfer
- S DGX=$P(N,U,5) Q:DGX="" ;return if no facility
- S DGX1=U_$P(DGX,";",2)_$P(DGX,";")_",0)" ;set ref from var pntr
- I $D(@DGX1) S DGFAC=$P(@DGX1,U) ;facility name
- I '$D(@DGX1) Q ;no facility name entry
- S DGSV=$O(^DGPM("APHY",IFN,0)) Q:'DGSV
- Q:'$D(^DGPM(DGSV,0)) S DGSV=$P(^(0),U,9)
- S DGSRV=$S(DGSV="":"NO SERVICE",1:$P(^DIC(45.7,DGSV,0),U)) ;service
- ;***> increment counts
- G PAT:DGTYP=1 ;type 1 is listing only
- I '$D(DGCT(DGFAC,DGSRV)) S DGCT(DGFAC,DGSRV)=1 Q:DGTYP=2 G PAT
- S $P(DGCT(DGFAC,DGSRV),U)=$P(DGCT(DGFAC,DGSRV),U)+1 Q:DGTYP=2
- PAT ;***> store patient data for types 1 and 3
- S ^TMP("DGZFTRA",$J,DGDT,DGSRV,DGFAC,DFN)=""
- Q
- ;
- LP3 ; -- loop discharges
- N DFN,IFN,N
- S DGDT=DGBDT-.0001,DGEND=DGEDT+.2400
- F S DGDT=$O(^DGPM("AMV3",DGDT)) Q:'DGDT!(DGDT>DGEND) D
- . S DFN=0 F S DFN=$O(^DGPM("AMV3",DGDT,DFN)) Q:'DFN D
- .. S IFN=0 F S IFN=$O(^DGPM("AMV3",DGDT,DFN,IFN)) Q:'IFN D 3
- Q
- ;
- 3 S N=^DGPM(IFN,0),DGT=$P(N,U,4)
- I DGT'=DGO1 Q ;discharge type not transfer
- S DGX=$P(N,U,5) Q:DGX="" ;return if no facility
- S DGX1=U_$P(DGX,";",2)_$P(DGX,";")_",0)" ;set ref from var pntr
- I $D(@DGX1) S DGFAC=$P(@DGX1,U) ;facility name
- I '$D(@DGX1) Q ;no facility name entry
- S DGSRV=$P($G(^DIC(45.7,+$$DTS,0)),U)
- ;***> increment counts
- G PAT1:DGTYP=1 ;type 1 is listing only
- I '$D(DGCT(DGFAC,DGSRV)) S DGCT(DGFAC,DGSRV)="^1" Q:DGTYP=2 G PAT1
- S $P(DGCT(DGFAC,DGSRV),U,2)=$P(DGCT(DGFAC,DGSRV),U,2)+1 Q:DGTYP=2
- PAT1 ;***> store patient data for types 1 & 3
- S ^TMP("DGZFTRD",$J,DGDT,DGSRV,DGFAC,DFN)=""
- Q
- ;
- DTS() ; -- discharge treating specialty
- Q $O(^($O(^DGPM("ATS",DFN,+$P(^DGPM(IFN,0),U,14),9999999.9999999-N)),0))
- ADGFTRC ; IHS/ADC/PDW/ENM - TRANS BETWEEN FAC(CALC) ; [ 03/25/1999 11:48 AM ]
- +1 ;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999
- +2 ;
- A ; -- driver
- +1 DO INI
- DO LP1
- DO LP3
- GOTO ^ADGFTRP
- +2 ;
- INI ; -- initialize variables
- +1 KILL ^TMP("DGZFTRA",$JOB),^TMP("DGZFTRD",$JOB)
- +2 ; -- DGI1 & DGI2 = transfer in types
- +3 SET DGI1=$ORDER(^DG(405.1,"AIHS1","A2",0))
- +4 SET DGI2=$ORDER(^DG(405.1,"AIHS1","A3",0))
- +5 ; -- DGO1 = transfer out type
- +6 SET DGO1=$ORDER(^DG(405.1,"AIHS1","D2",0))
- +7 QUIT
- +8 ;
- LP1 ; -- loop admissions
- +1 NEW DFN,IFN,N
- +2 SET DGDT=DGBDT-.0001
- SET DGEND=DGEDT+.2400
- +3 FOR
- SET DGDT=$ORDER(^DGPM("AMV1",DGDT))
- IF 'DGDT!(DGDT>DGEND)
- 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 SET N=^DGPM(IFN,0)
- SET DGT=$PIECE(N,U,4)
- +1 ;admit type not transfer
- IF DGT'=DGI1&(DGT'=DGI2)
- QUIT
- +2 ;return if no facility
- SET DGX=$PIECE(N,U,5)
- IF DGX=""
- QUIT
- +3 ;set ref from var pntr
- SET DGX1=U_$PIECE(DGX,";",2)_$PIECE(DGX,";")_",0)"
- +4 ;facility name
- IF $DATA(@DGX1)
- SET DGFAC=$PIECE(@DGX1,U)
- +5 ;no facility name entry
- IF '$DATA(@DGX1)
- QUIT
- +6 SET DGSV=$ORDER(^DGPM("APHY",IFN,0))
- IF 'DGSV
- QUIT
- +7 IF '$DATA(^DGPM(DGSV,0))
- QUIT
- SET DGSV=$PIECE(^(0),U,9)
- +8 ;service
- SET DGSRV=$SELECT(DGSV="":"NO SERVICE",1:$PIECE(^DIC(45.7,DGSV,0),U))
- +9 ;***> increment counts
- +10 ;type 1 is listing only
- IF DGTYP=1
- GOTO PAT
- +11 IF '$DATA(DGCT(DGFAC,DGSRV))
- SET DGCT(DGFAC,DGSRV)=1
- IF DGTYP=2
- QUIT
- GOTO PAT
- +12 SET $PIECE(DGCT(DGFAC,DGSRV),U)=$PIECE(DGCT(DGFAC,DGSRV),U)+1
- IF DGTYP=2
- QUIT
- PAT ;***> store patient data for types 1 and 3
- +1 SET ^TMP("DGZFTRA",$JOB,DGDT,DGSRV,DGFAC,DFN)=""
- +2 QUIT
- +3 ;
- LP3 ; -- loop discharges
- +1 NEW DFN,IFN,N
- +2 SET DGDT=DGBDT-.0001
- SET DGEND=DGEDT+.2400
- +3 FOR
- SET DGDT=$ORDER(^DGPM("AMV3",DGDT))
- IF 'DGDT!(DGDT>DGEND)
- QUIT
- Begin DoDot:1
- +4 SET DFN=0
- FOR
- SET DFN=$ORDER(^DGPM("AMV3",DGDT,DFN))
- IF 'DFN
- QUIT
- Begin DoDot:2
- +5 SET IFN=0
- FOR
- SET IFN=$ORDER(^DGPM("AMV3",DGDT,DFN,IFN))
- IF 'IFN
- QUIT
- DO 3
- End DoDot:2
- End DoDot:1
- +6 QUIT
- +7 ;
- 3 SET N=^DGPM(IFN,0)
- SET DGT=$PIECE(N,U,4)
- +1 ;discharge type not transfer
- IF DGT'=DGO1
- QUIT
- +2 ;return if no facility
- SET DGX=$PIECE(N,U,5)
- IF DGX=""
- QUIT
- +3 ;set ref from var pntr
- SET DGX1=U_$PIECE(DGX,";",2)_$PIECE(DGX,";")_",0)"
- +4 ;facility name
- IF $DATA(@DGX1)
- SET DGFAC=$PIECE(@DGX1,U)
- +5 ;no facility name entry
- IF '$DATA(@DGX1)
- QUIT
- +6 SET DGSRV=$PIECE($GET(^DIC(45.7,+$$DTS,0)),U)
- +7 ;***> increment counts
- +8 ;type 1 is listing only
- IF DGTYP=1
- GOTO PAT1
- +9 IF '$DATA(DGCT(DGFAC,DGSRV))
- SET DGCT(DGFAC,DGSRV)="^1"
- IF DGTYP=2
- QUIT
- GOTO PAT1
- +10 SET $PIECE(DGCT(DGFAC,DGSRV),U,2)=$PIECE(DGCT(DGFAC,DGSRV),U,2)+1
- IF DGTYP=2
- QUIT
- PAT1 ;***> store patient data for types 1 & 3
- +1 SET ^TMP("DGZFTRD",$JOB,DGDT,DGSRV,DGFAC,DFN)=""
- +2 QUIT
- +3 ;
- DTS() ; -- discharge treating specialty
- +1 QUIT $ORDER(^($ORDER(^DGPM("ATS",DFN,+$PIECE(^DGPM(IFN,0),U,14),9999999.9999999-N)),0))