source: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGYPREG.m@ 691

DGYPREG ;ALB/REW - POST-INIT CONVERSION ROUTINES OF PATIENT FILE ;12-MAR-93

 ;;5.3;Registration;;Aug 13, 1993

 ;

EN1(DGDOMB,DGDOCFL) ;

 ;  INPUT:

 ;     DGDOMB - 0=NOTHING, 1=REPORT, 2=REPORT & CONVERSION

 ;     DGDOCFL- "

EN ;

 N CT,DGCFLBD,DGCFLCN,DGDAY,DGDJ,DGTOTBD,DGTOTCN,X,XCNP,XMZ

 S:('$D(DGDOMB))&('$D(DGDOCFL)) (DGDOMB,DGDOCFL)=1

 N DGSTDT,DGENDT,Y,%

 D STTIME("Patient File Loop"),LOOP,ENDTIME("Patient File Loop")

 Q

STTIME(DGDESC) I '$D(ZTQUEUED) D NOW^%DTC S DGSTDT=$H,DT=X,Y=% W !!,">>> "_DGDESC_" started: " D DT^DIQ W !!

 Q

ENDTIME(DGDESC) ; -get stop time

 I '$D(ZTQUEUED) D NOW^%DTC S DGENDT=$H W:'$D(ZTQUEUED) !!,">>> "_DGDESC_" complete at " S Y=% D DT^DIQ

 I $D(DGENDT) D

 .S DGDAY=+DGENDT-(+DGSTDT)*86400 ;additional seconds of over midnight

 .S X=DGDAY+$P(DGENDT,",",2)-$P(DGSTDT,",",2) W:'$D(ZTQUEUED) !,"    Elapse time for loop was: ",X\3600," Hours,  ",X\60-(X\3600*60)," Minutes,  ",X#60," Seconds"

 Q

INITLOOP ;

 S (DGCFLCN,DGCFLBD,DGTOTCN,DGTOTBD)=0

 S:'$D(DGDOMB)&('$D(DGDOCFL)) (DGDOMB,DGDOCFL)=2

 Q

LOOP ;

 D INITLOOP

 N DIRUT,DFN,RWVCOM,RWEND,RWSKIP,RWSTOP

 S RWSKIP=1,RWSTOP=99999999

 F DFN=0:0 S DFN=$O(^DPT(DFN)) Q:DFN'>0!(DFN>RWSTOP)  I '(DFN#RWSKIP) D

 .W:'$D(ZTQUEUED)&('(DFN#100)) "."

 .Q:'$D(^DPT(DFN,0))

 .D:$G(DGDOMB) TOTVAAMT(DFN,(DGDOMB-1)) ;:'$G(^DPT(DFN,.35))

 .D:$G(DGDOCFL) CFL(DFN,(DGDOCFL-1)) ;:'$G(^DPT(DFN,.35)) - CAN BE ADDED TO NOT HANDLE DEAD

 D ENDLOOP^DGYPREG3

 K ^TMP("DGGDCFL",$J),^TMP("DGBDCFL",$J),^TMP("DGGDMB",$J),^TMP("DGBDMB",$J),^TMP("DGCFLREP",$J),^TMP("DGTOTVA",$J)

 Q

NOREC(DA,PC) ;RE-STUFFS NO ANSWER TO ACTIVATE DELETION TRIGGER

 N DIE,DR,DGFLDN

 G:'$G(DA)!('$G(PC)) QTNOREC

 S DIE=2

 S DGFLDN=$S(PC=1:.36205,(PC=2):.36215,(PC=3):.3025,(PC=4):.36235,1:"")

 G:'DGFLDN QTNOREC

 S DR=DGFLDN_"////N"

 D ^DIE

QTNOREC Q

TOTVAAMT(DFN,DGOKPOP) ;Populates TOTAL ANNUAL VA CHECK AMOUNT IGNORES 0nnnnn entries

 ; DGOKPOP = FLAG TO POPULATE FIELD

 N AMT,CT,DGNODE,DGPCN,DGRECN,PC,X

 S DGNODE=$G(^DPT(DFN,.362))

 S DGPCN="12^13^11^14"

 G:$P(DGNODE,U,20)]"" QTTVMT

 S AMT(3)=$P($G(^DPT(DFN,.3)),U,3)

 I $E(AMT(3)) I AMT(3)<99999 D

 .I $P(^DPT(DFN,.3),U,11)["N" D

 ..D:$G(DGOKPOP) NOREC(DFN,3)

 .E  S CT=1 S:$G(DGOKPOP) $P(^DPT(DFN,.362),U,20)=AMT(3)

 F PC=1,2,4 S AMT(PC)=$P(DGNODE,U,PC) I $E(AMT(PC)) I AMT(PC)<99999 D

 .I $P(DGNODE,U,($P(DGPCN,U,PC)))["N" D

 ..D:$G(DGOKPOP) NOREC(DFN,PC)

 .E  D

 ..S CT=$G(CT)+1

 ..S:$G(DGOKPOP) $P(^DPT(DFN,.362),U,20)=AMT(PC)

 I $G(CT)>1 D

 .S:$G(DGOKPOP) $P(^DPT(DFN,.362),U,20)=""

 .S ^TMP("DGBDMB",$J,(9999999-$$ACTDT(DFN)),DFN)=AMT(1)_U_AMT(2)_U_AMT(3)_U_AMT(4)

 .S DGTOTBD=$G(DGTOTBD)+1

 I $G(CT)=1 S DGTOTCN=$G(DGTOTCN)+1 S ^TMP("DGGDMB",$J,(9999999-$$ACTDT(DFN)),DFN)=""

QTTVMT Q

CFL(DFN,DGOKPOP) ;SORT ENTRIES AS BAD, NO CONVERSION NEEDED, AND CONVERTIBLE

 ; DGOKPOP = FLAG TO POPULATE FIELD

 N DGPTR4

 S DGPTR4=$$GOODCFL(DFN)

 G:'DGPTR4 QTCFL

 I DGPTR4<0 D

 .S ^TMP("DGBDCFL",$J,(9999999-$$ACTDT(DFN)),DFN)=DGPTR4

 .S DGCFLBD=$G(DGCFLBD)+1

 I DGPTR4>0 D

 .S ^TMP("DGGDCFL",$J,(9999999-$$ACTDT(DFN)),DFN)=DGPTR4

 .S DGCFLCN=$G(DGCFLCN)+1

 .S:$G(DGOKPOP) $P(^DPT(DFN,.31),U,4)=+DGPTR4 ;THIS POPULATES NEW FIELD

QTCFL Q

GOODCFL(DFN) ;RETURNS POINTER^DESC (TO INSTITUTION FILE),-1 (BAD),0 (NO CHNG)

 N DGCFL,DGNODE,X

 ;  OUTPUT [RETURNED]POINTER^DGCFL(CLAIM FOLDER LOCATION)

 S DGNODE=$G(^DPT(DFN,.31))

 S DGCFL=$P(DGNODE,U,2)

 I (DGCFL']"")!($P(DGNODE,U,4)]"") S X=0 G QTGCFL

 I $E(DGCFL,1,3)="000" S X=0 G QTGCFL

 I 'DGCFL S X=-1 G QTGCFL

 S X=$O(^DIC(4,"D",+DGCFL,0))

 I 'X S X=-1

QTGCFL Q X_U_DGCFL

ACTDT(DFN) ;RETURNS LAST ACTIVE DATE

 N A,ACTDT,X,Y

 S ACTDT=0

 S X=$O(^DPT(DFN,"DIS",0)) S:X ACTDT=9999999-X ;REG

 S:$G(^DPT(DFN,.105)) ACTDT=DT ;INPATIENT

 F A=0:0 S A=$O(^DGS(41.1,"B",DFN,A)) Q:A'>0  S X=$P($G(^DGS(41.1,+A,0)),U,2) S:X>ACTDT ACTDT=X ;ADM

 S X=ACTDT F  S X=$O(^DPT(DFN,"S",X)) S:X Y=X I 'X S:$G(Y)>ACTDT ACTDT=Y Q  ;CLIN

 S X=ACTDT F  S X=$O(^DGPM("APRD",DFN,X)) S:X Y=X I 'X S:$G(Y)>ACTDT ACTDT=Y Q  ;PM

QTACTDT Q ACTDT