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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGYPREG 4047 printed Apr 09, 2024@22:03:41 Page 2
DGYPREG ;ALB/REW - POST-INIT CONVERSION ROUTINES OF PATIENT FILE ;12-MAR-93
+1 ;;5.3;Registration;;Aug 13, 1993
+2 ;
EN1(DGDOMB,DGDOCFL) ;
+1 ; INPUT:
+2 ; DGDOMB - 0=NOTHING, 1=REPORT, 2=REPORT & CONVERSION
+3 ; DGDOCFL- "
EN ;
+1 NEW CT,DGCFLBD,DGCFLCN,DGDAY,DGDJ,DGTOTBD,DGTOTCN,X,XCNP,XMZ
+2 if ('$DATA(DGDOMB))&('$DATA(DGDOCFL))
SET (DGDOMB,DGDOCFL)=1
+3 NEW DGSTDT,DGENDT,Y,%
+4 DO STTIME("Patient File Loop")
DO LOOP
DO ENDTIME("Patient File Loop")
+5 QUIT
STTIME(DGDESC) IF '$DATA(ZTQUEUED)
DO NOW^%DTC
SET DGSTDT=$HOROLOG
SET DT=X
SET Y=%
WRITE !!,">>> "_DGDESC_" started: "
DO DT^DIQ
WRITE !!
+1 QUIT
ENDTIME(DGDESC) ; -get stop time
+1 IF '$DATA(ZTQUEUED)
DO NOW^%DTC
SET DGENDT=$HOROLOG
if '$DATA(ZTQUEUED)
WRITE !!,">>> "_DGDESC_" complete at "
SET Y=%
DO DT^DIQ
+2 IF $DATA(DGENDT)
Begin DoDot:1
+3 ;additional seconds of over midnight
SET DGDAY=+DGENDT-(+DGSTDT)*86400
+4 SET X=DGDAY+$PIECE(DGENDT,",",2)-$PIECE(DGSTDT,",",2)
if '$DATA(ZTQUEUED)
WRITE !," Elapse time for loop was: ",X\3600," Hours, ",X\60-(X\3600*60)," Minutes, ",X#60," Seconds"
End DoDot:1
+5 QUIT
INITLOOP ;
+1 SET (DGCFLCN,DGCFLBD,DGTOTCN,DGTOTBD)=0
+2 if '$DATA(DGDOMB)&('$DATA(DGDOCFL))
SET (DGDOMB,DGDOCFL)=2
+3 QUIT
LOOP ;
+1 DO INITLOOP
+2 NEW DIRUT,DFN,RWVCOM,RWEND,RWSKIP,RWSTOP
+3 SET RWSKIP=1
SET RWSTOP=99999999
+4 FOR DFN=0:0
SET DFN=$ORDER(^DPT(DFN))
if DFN'>0!(DFN>RWSTOP)
QUIT
IF '(DFN#RWSKIP)
Begin DoDot:1
+5 if '$DATA(ZTQUEUED)&('(DFN#100))
WRITE "."
+6 if '$DATA(^DPT(DFN,0))
QUIT
+7 ;:'$G(^DPT(DFN,.35))
if $GET(DGDOMB)
DO TOTVAAMT(DFN,(DGDOMB-1))
+8 ;:'$G(^DPT(DFN,.35)) - CAN BE ADDED TO NOT HANDLE DEAD
if $GET(DGDOCFL)
DO CFL">CFL(DFN,(DGDOCFL">CFL-1))
End DoDot:1
+9 DO ENDLOOP^DGYPREG3
+10 KILL ^TMP("DGGDCFL",$JOB),^TMP("DGBDCFL",$JOB),^TMP("DGGDMB",$JOB),^TMP("DGBDMB",$JOB),^TMP("DGCFLREP",$JOB),^TMP("DGTOTVA",$JOB)
+11 QUIT
NOREC(DA,PC) ;RE-STUFFS NO ANSWER TO ACTIVATE DELETION TRIGGER
+1 NEW DIE,DR,DGFLDN
+2 if '$GET(DA)!('$GET(PC))
GOTO QTNOREC
+3 SET DIE=2
+4 SET DGFLDN=$SELECT(PC=1:.36205,(PC=2):.36215,(PC=3):.3025,(PC=4):.36235,1:"")
+5 if 'DGFLDN
GOTO QTNOREC
+6 SET DR=DGFLDN_"////N"
+7 DO ^DIE
QTNOREC QUIT
TOTVAAMT(DFN,DGOKPOP) ;Populates TOTAL ANNUAL VA CHECK AMOUNT IGNORES 0nnnnn entries
+1 ; DGOKPOP = FLAG TO POPULATE FIELD
+2 NEW AMT,CT,DGNODE,DGPCN,DGRECN,PC,X
+3 SET DGNODE=$GET(^DPT(DFN,.362))
+4 SET DGPCN="12^13^11^14"
+5 if $PIECE(DGNODE,U,20)]""
GOTO QTTVMT
+6 SET AMT(3)=$PIECE($GET(^DPT(DFN,.3)),U,3)
+7 IF $EXTRACT(AMT(3))
IF AMT(3)<99999
Begin DoDot:1
+8 IF $PIECE(^DPT(DFN,.3),U,11)["N"
Begin DoDot:2
+9 if $GET(DGOKPOP)
DO NOREC(DFN,3)
End DoDot:2
+10 IF '$TEST
SET CT=1
if $GET(DGOKPOP)
SET $PIECE(^DPT(DFN,.362),U,20)=AMT(3)
End DoDot:1
+11 FOR PC=1,2,4
SET AMT(PC)=$PIECE(DGNODE,U,PC)
IF $EXTRACT(AMT(PC))
IF AMT(PC)<99999
Begin DoDot:1
+12 IF $PIECE(DGNODE,U,($PIECE(DGPCN,U,PC)))["N"
Begin DoDot:2
+13 if $GET(DGOKPOP)
DO NOREC(DFN,PC)
End DoDot:2
+14 IF '$TEST
Begin DoDot:2
+15 SET CT=$GET(CT)+1
+16 if $GET(DGOKPOP)
SET $PIECE(^DPT(DFN,.362),U,20)=AMT(PC)
End DoDot:2
End DoDot:1
+17 IF $GET(CT)>1
Begin DoDot:1
+18 if $GET(DGOKPOP)
SET $PIECE(^DPT(DFN,.362),U,20)=""
+19 SET ^TMP("DGBDMB",$JOB,(9999999-$$ACTDT(DFN)),DFN)=AMT(1)_U_AMT(2)_U_AMT(3)_U_AMT(4)
+20 SET DGTOTBD=$GET(DGTOTBD)+1
End DoDot:1
+21 IF $GET(CT)=1
SET DGTOTCN=$GET(DGTOTCN)+1
SET ^TMP("DGGDMB",$JOB,(9999999-$$ACTDT(DFN)),DFN)=""
QTTVMT QUIT
CFL(DFN,DGOKPOP) ;SORT ENTRIES AS BAD, NO CONVERSION NEEDED, AND CONVERTIBLE
+1 ; DGOKPOP = FLAG TO POPULATE FIELD
+2 NEW DGPTR4
+3 SET DGPTR4=$$GOODCFL(DFN)
+4 if 'DGPTR4
GOTO QTCFL
+5 IF DGPTR4<0
Begin DoDot:1
+6 SET ^TMP("DGBDCFL",$JOB,(9999999-$$ACTDT(DFN)),DFN)=DGPTR4
+7 SET DGCFLBD=$GET(DGCFLBD)+1
End DoDot:1
+8 IF DGPTR4>0
Begin DoDot:1
+9 SET ^TMP("DGGDCFL",$JOB,(9999999-$$ACTDT(DFN)),DFN)=DGPTR4
+10 SET DGCFLCN=$GET(DGCFLCN)+1
+11 ;THIS POPULATES NEW FIELD
if $GET(DGOKPOP)
SET $PIECE(^DPT(DFN,.31),U,4)=+DGPTR4
End DoDot:1
QTCFL QUIT
GOODCFL(DFN) ;RETURNS POINTER^DESC (TO INSTITUTION FILE),-1 (BAD),0 (NO CHNG)
+1 NEW DGCFL,DGNODE,X
+2 ; OUTPUT [RETURNED]POINTER^DGCFL(CLAIM FOLDER LOCATION)
+3 SET DGNODE=$GET(^DPT(DFN,.31))
+4 SET DGCFL=$PIECE(DGNODE,U,2)
+5 IF (DGCFL']"")!($PIECE(DGNODE,U,4)]"")
SET X=0
GOTO QTGCFL
+6 IF $EXTRACT(DGCFL,1,3)="000"
SET X=0
GOTO QTGCFL
+7 IF 'DGCFL
SET X=-1
GOTO QTGCFL
+8 SET X=$ORDER(^DIC(4,"D",+DGCFL,0))
+9 IF 'X
SET X=-1
QTGCFL QUIT X_U_DGCFL
ACTDT(DFN) ;RETURNS LAST ACTIVE DATE
+1 NEW A,ACTDT,X,Y
+2 SET ACTDT=0
+3 ;REG
SET X=$ORDER(^DPT(DFN,"DIS",0))
if X
SET ACTDT=9999999-X
+4 ;INPATIENT
if $GET(^DPT(DFN,.105))
SET ACTDT=DT
+5 ;ADM
FOR A=0:0
SET A=$ORDER(^DGS(41.1,"B",DFN,A))
if A'>0
QUIT
SET X=$PIECE($GET(^DGS(41.1,+A,0)),U,2)
if X>ACTDT
SET ACTDT=X
+6 ;CLIN
SET X=ACTDT
FOR
SET X=$ORDER(^DPT(DFN,"S",X))
if X
SET Y=X
IF 'X
if $GET(Y)>ACTDT
SET ACTDT=Y
QUIT
+7 ;PM
SET X=ACTDT
FOR
SET X=$ORDER(^DGPM("APRD",DFN,X))
if X
SET Y=X
IF 'X
if $GET(Y)>ACTDT
SET ACTDT=Y
QUIT
QTACTDT QUIT ACTDT
