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

DGPTC1.m

Go to the documentation of this file. 
  1. DGPTC1 ;ALN/MJK - Census Record Processing; JAN 27, 2005
  1.  ;;5.3;Registration;**37,413,643,701,1015**;Aug 13, 1993;Build 21
  1.  ;
  1. CEN ; -- determine if PTF rec is current Census rec
  1.  ; input: PTF   := ptf rec #
  1.  ;     DGPMCA   := corres. adm           (non-fee)
  1.  ;     DGPMAN   := 0th node of corrs adm     "
  1.  ;output: DGCI  := census rec #
  1.  ;        DGCST := census rec status
  1.  ;        DGCN  := census date entry to 45.86
  1.  ;
  1.  K DGCST,DGCI,DGCN,DGCN0,DGFEE
  1.  S DGFEE=0
  1.  G CENQ:'$D(^DGPT(PTF,0)) N DFN S DGPTF0=^(0),DFN=+DGPTF0
  1.  ;G CENQ:$P(DGPTF0,U,4)
  1.  D CEN^DGPTUTL I DGCN0=""!(DT'>DGCN0) K DGCN G CENQ
  1.  ;I $P(DGPTF0,U,4) D FEE G CENQ  ;DG*701 reposition line 
  1.  S DGT=$P(DGCN0,U)_".9" I '$P(DGPTF0,U,4) D WARD I 'Y K DGCN G CENQ
  1.  ;if Fee Basis quit if admit > census date or admit < census date if disch
  1.  I $P(DGPTF0,U,4)=1,$P(DGPTF0,U,2)>DGT G CENQ
  1.  I $P(DGPTF0,U,4)=1,+$P($G(^DGPT(PTF,70)),U),$P(DGPTF0,U,2)<DGT G CENQ
  1.  I $P(DGPTF0,U,4)=1 D FEE G CENQ
  1.  S DGCST=0,DGCI=""
  1.  F  S DGCI=$O(^DGPT("ACENSUS",PTF,DGCI)) Q:'DGCI  I $D(^DGPT(DGCI,0)),$P(^(0),U,13)=DGCN S DGCST=$P(^(0),U,6) Q:DGCST'=0  D  Q
  1.  .S DGCI=$$RDGCI(DGCI),DGCST=1
  1. CENQ K DGCN0,DGA1,DGT,X,DGPTF0,DGFEE Q
  1.  ;
  1. KVAR K DGCN,DGCI,DGCST Q
  1.  ;
  1. FEE ;
  1.  S DGCST=0,DGCI="",DGFEE=1
  1.  F  S DGCI=$O(^DGPT("ACENSUS",PTF,DGCI)) Q:'DGCI  I $D(^DGPT(DGCI,0)),$P(^(0),U,13)=DGCN S DGCST=$P(^(0),U,6) Q:DGCST'=0  D  Q
  1.  . S DGCI=$$RDGCI(DGCI),DGCST=+$P(^DGPT(DGCI,0),U,6)
  1.  Q
  1. ACT ; -- census actions with input of X
  1.  Q:'$D(X)
  1.  S Y=2 D RTY^DGPTUTL
  1.  I X="L" D CLS G ACTQ
  1.  I X="P" D OPEN G ACTQ
  1.  I X="E" S DGPTFLE=1,DGPTIFN=DGCI D EN^DGPTFREL K DGRTY,DGRTY0 G ^DGPTF
  1. ACTQ K DGRTY,DGRTY0 G EN1^DGPTF4
  1.  ;
  1. RDGCI(DGCI) ;-- eliminating 'OPEN' status census record and duplicates
  1.  S DGDL=DGCI,DGCIR="" D
  1.  .F  S DGCIR=$O(^DGPT("ACENSUS",PTF,DGCIR),-1) Q:DGCIR<DGDL  D
  1.  ..I $D(^DGPT(DGCIR,0)),$P(^(0),U,13)=DGCN S:DGCI=DGDL DGCI=DGCIR D
  1.  ...I DGCIR<DGCI S DGPTIFN=DGCIR,DGRTY=2 D KDGP^DGPTFDEL,KDGPT^DGPTFDEL
  1.  Q DGCI
  1.  ;
  1. CLS ;
  1.  S DGFEE=0
  1.  I $P(^DGPT(DGPTF,0),U,4)'=1 W !,"Updating TRANSFER DRGs..." S DGADM=$P(^DGPT(PTF,0),U,2) D SUDO1^DGPTSUDO
  1.  S J=PTF,DGERR=-1,T2=^DG(45.86,DGCN,0)+.9,T1=$P(^(0),U,5)
  1.  S DGPTFMTX=DGPTFMT S Y=T2 D FMT^DGPTUTL
  1.  W !,"Performing edit checks..."
  1.  ;-- init for Austin Edits
  1.  K ^TMP("AEDIT",$J),^TMP("AERROR",$J) S DGACNT=0
  1.  ;
  1.  D LOG^DGPTFTR1:DGPTFMT=1,LOG^DGPTR1:DGPTFMT=2,COM1^DGPTFTR
  1.  K DGLOGIC,T1,T2,DGCCO D LO^DGUTL
  1.  I DGERR>0 K DGERR D ^DGPTF2 G CLSQ
  1.  ;-- do austin edits
  1.  ;
  1.  D ^DGPTAE I DGERR>0 K DGERR D ^DGPTF2 G CLSQ
  1.  K DGERR,^TMP("AEDIT",$J),DGACNT
  1.  I $P(^DGPT(PTF,0),U,4) S DGFEE=1 D FEE1 G CLSQ:'DGCI
  1.  I $P(^DGPT(PTF,0),U,4)'=1 D CREATE G CLSQ:'DGCI
  1.  S DR="7////"_DUZ_";8///T",DA=DGCI,DIE="^DGPT(" D ^DIE K DIE,DR
  1.  S (X,DINUM)=DGCI,DIC(0)="L",DIC="^DGP(45.84,",DIC("DR")="2///NOW;3////"_DUZ
  1.  K DD,DO D FILE^DICN K DIC,DINUM
  1.  F I=0,.11,.52,.321,.32,57,.3 S:$D(^DPT(DFN,I)) ^DGP(45.84,DGCI,$S(I=0:10,1:I))=^DPT(DFN,I)
  1.  W !,"****** CENSUS CLOSED OUT ******" D HANG^DGPTUTL
  1.  S DGCST=1
  1. CLSQ S DGPTFMT=DGPTFMTX K DGPTFMTX,DGFEE Q
  1.  ;
  1. CREATE ; -- create census record
  1.  W !,"Creating Census Record..."
  1.  S Y=$P(^DGPT(PTF,0),U,2) D CREATE^DGPTFCR G CREATEQ:Y<0 S DGCI=+Y W "#",DGCI
  1.  S DGEND=+^DG(45.86,DGCN,0)_".2359",DGBEG=+$P(^(0),U,5)
  1.  S ^DGPT(DGCI,0)=$P(^DGPT(PTF,0),U,1,10)_"^2^"_PTF_"^"_DGCN,DGCSUF=$P(^(0),U,5)
  1.  ;S ^DGPT(DGCI,0)=$P(^DGPT(PTF,0),U,1,5)_"^1^"_$P(^DGPT(PTF,0),U,7,10)_"^2^"_PTF_"^"_DGCN,DGCSUF=$P(^(0),U,5)
  1.  S Y=DGEND D BS^DGPTC2 S X="",$P(X,U)=DGEND,$P(X,U,14)=Y
  1.  I $D(^DGPT(PTF,70)) S Y=^(70) F I=8,9,10 S $P(X,U,I)=$P(Y,U,I)
  1.  S ^DGPT(DGCI,70)=X D ASIH
  1.  I $D(^DGPT(PTF,101)) S ^DGPT(DGCI,101)=^DGPT(PTF,101)
  1.  F NODE="M","P","S",535 F I=0:0 S I=$O(^DGPT(PTF,NODE,I)) Q:'I  I $D(^DGPT(PTF,NODE,I,0)) S X=^(0) D @("SET"_NODE_"^DGPTC2")
  1.  K DA,DIKLM S DA=DGCI,DIK="^DGPT(" D IX1^DIK
  1. CREATEQ K X,Y,DGCSUF,DGBEG,DGEND Q
  1.  ;
  1. FEE1 ; -- create census record for fee record
  1.  W !,"Creating Census Record..."
  1.  S Y=$P(^DGPT(PTF,0),U,2) D CREATE^DGPTFCR G CREATEQ:Y<0 S DGCI=+Y W "#",DGCI
  1.  S DGEND=+^DG(45.86,DGCN,0)_".2359",DGBEG=+$P(^(0),U,5)
  1.  S ^DGPT(DGCI,0)=$P(^DGPT(PTF,0),U,1,10)_"^2^"_PTF_"^"_DGCN,DGCSUF=$P(^(0),U,5)
  1.  I $D(^DGPT(PTF,70)) S ^DGPT(DGCI,70)=^DGPT(PTF,70)
  1.  S $P(^DGPT(DGCI,70),U)=DGEND
  1.  I $D(^DGPT(PTF,101)) S ^DGPT(DGCI,101)=^DGPT(PTF,101)
  1.  F NODE="M","P","S",535 F I=0:0 S I=$O(^DGPT(PTF,NODE,I)) Q:'I  I $D(^DGPT(PTF,NODE,I,0)) S X=^(0) D @("SET"_NODE_"^DGPTC2")
  1.  K DA,DIKLM S DA=DGCI,DIK="^DGPT(" D IX1^DIK
  1. FEE1Q K X,Y,DGCSUF,DGBEG,DGEND Q
  1. OPEN ; -- re-open census rec by deleting
  1.  S DGPTIFN=DGCI D OPEN^DGPTFDEL S (DGCI,DGCST)=0
  1.  K DGPTIFN Q
  1.  ;
  1. WARD ; -- ward @ census d/t for an adm(even if nhcu/dom adm that is ASIH)
  1.  ;  input:  DGPMCA := corres adm
  1.  ;          DGPMAN := corres adm 0th node
  1.  ; output:       Y := ward ptr or null
  1.  ;
  1.  N MVT,M
  1.  S Y=""
  1.  I +DGPMAN>DGT Q
  1.  I $D(^DGPM(+$P(DGPMAN,U,17),0)),+^(0)<DGT Q
  1.  F %=(9999999.9999999-DGT):0 S %=$O(^DGPM("APMV",DFN,DGPMCA,%)) Q:'%  F MVT=0:0 S MVT=$O(^DGPM("APMV",DFN,DGPMCA,%,MVT)) Q:'MVT  I $D(^DGPM(MVT,0)) S M=^(0) I "^13^43^44^45^"'[(U_$P(M,U,18)_U),$D(^DIC(42,+$P(M,U,6),0)) S Y=+$P(M,U,6) G WARDQ
  1. WARDQ Q
  1.  ;
  1. ASIH ; -- calc asih days
  1.  N DGADM,DGREC,DGBDT,DGEDT,DGMVTP
  1.  S X1=DGBEG,X2=-1 D C^%DTC S DGBDT=X
  1.  S X1=$P(DGEND,"."),X2=1 D C^%DTC S DGEDT=X
  1.  S DGADM=$P(^DGPT(DGCI,0),U,2) D ASIH^DGUTL2
  1.  S $P(^DGPT(DGCI,70),U,8)=DGREC
  1.  Q