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