Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ADGFTRC

ADGFTRC.m

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