- 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 Feb 19, 2025@00:26:30 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(DFN,(DGDOCFL-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