DGYPREG1 ;ALB/REW - POST-INIT PATIENT FILE POST-INIT CONT'D ;1-APR-93
;;5.3;Registration;;Aug 13, 1993
CFLREP ;End of Patient File Loop: Problem CFL Fields
N DGDJ
D SETUP(1) ; 1=CFL 2=TOTVACHK
D CSUM(1),CDET
D END
Q
TOTVAREP ;End of Patient File Loop: Problem MB Fields
S DGDJ=$G(DGDJ)
N FROM,REP,SUB,TEXT,TO
N DGACT,DGDJ,DGFSTINT,DGL4,DGLPCT,DGPTNM,DGX,DGTEXT,X
S DGLPCT=0
D SETUP(2) ;1=CFL 2=TOTVA
D CSUM(2)
S DGFSTINT=+(9999999-$G(DGFSTDT)) ;INTERNAL FIRST DATE TO PRINT
I $G(DGFSTDT) D
.D MESS(" Only patients whose Last Activity Date is AFTER "_$E(DGFSTDT,4,5)_"/"_$E(DGFSTDT,6,7)_"/"_$E(DGFSTDT,2,3)_" will be listed.",1)
I $G(DGTOTBD)>DGMAXPT D
.D MESS(" Only "_DGMAXPT_" patients will be listed.",2)
.D MESS(" To see more, run the PIMS Monetary Benefit Amounts Conversion Report",1)
D MESS("PATIENT NAME LAST ACTIVITY A&A H.B. Dis. Pension")
D MESS($E(DGSPACE,1,17)_"4-ID DATE AMOUNT AMOUNT AMOUNT AMOUNT")
D MESS(DGUND)
F DGACT=0:0 S DGACT=$O(^TMP("DGBDMB",$J,DGACT)) Q:'DGACT F DFN=0:0 S DFN=$O(^TMP("DGBDMB",$J,DGACT,DFN)) Q:'DFN!(DGLPCT'<DGMAXPT)!(DGACT>DGFSTINT) S DGX=$G(^(DFN)) D
.D GETID
.S X=9999999-DGACT
.S DGTEXT=DGPTNM_$E(DGSPACE,$L(DGPTNM),16)_DGL4_" "_$E(X,4,5)_"-"_$E(X,6,7)_"-"_$E(X,2,3)_$E(DGSPACE,$L(X),6)_" "
.F X=1:1:4 S DGTEXT=DGTEXT_$J($P(DGX,U,X),10,2)
.D MESS(DGTEXT)
.S DGLPCT=DGLPCT+1
D END
Q
END ;
N DIFROM
D ^XMD
;K @DGROOT
K DGFSTDT,DGMAXPT,DGROOT,DGSPACE,DGTEXT,DGUCCT,DGUND,DGX,DGXM,DIR,XMDUZ,XMSUB,XMTEXT,XMY
Q
SETUP(REP) ;
Q:'$G(REP)
S DGDJ=$S($G(DGDJ):DGDJ,1:$J)
S $P(DGUND,"=",76)=""
S $P(DGSPACE," ",81)=""
S:'$G(DGMAXPT) DGMAXPT=1999
S XMSUB=$S(REP=1:"Claims Folder Location Conversion Report",(REP=2):"Total Annual VA Check Amount Conversion Report",1:"PATIENT File ZIP+4 Population Complete")
S XMDUZ=.5
S XMY(DUZ)=""
S XMY(.5)=""
S DGROOT="^TMP("_$S(REP=1:"""DGCFLREP""",(REP=2):"""DGTOTVA""",1:"""DGZIP4""")_","_$J
S XMTEXT=DGROOT_","
S DGROOT=DGROOT_")"
K @DGROOT
D:(REP<3) HEAD^DGYPREG2(REP)
Q
CSUM(REP) ;PRINTS SUMMARY
;OUTPUT: DGUCCT = #Un-Convertible Patients
N ACT,ACTCT,CT,DFN,SUB,Z
D MESS(" "_($E(DGSPACE,1,23)_"TOTAL ACTIVE INACTIVE"))
S Z=9999999-(DT-10000)
S DGUCCT=0
I REP=1 F SUB="DGBDCFL","DGGDCFL" S (CT,ACTCT)=0 D SUM S:SUB="DGBDCFL" DGUCCT=CT
I REP=2 F SUB="DGBDMB","DGGDMB" S (CT,ACTCT)=0 D SUM S:SUB="DGBDMB" DGUCCT=CT
D MESS("")
Q
SUM ;
F ACT=0:0 S ACT=$O(^TMP(SUB,$J,ACT)) Q:'ACT D
.S DFN=0 F CT=CT:1 S DFN=$O(^TMP(SUB,$J,ACT,DFN)) Q:'DFN S:ACT<Z ACTCT=ACTCT+1
D MESS(" "_$S(SUB["DGBD":"Un-Convertible:",1:"Convertible:")_$E(DGSPACE,$S(SUB["DGGD":12,1:15),19)_$J(CT,8)_" "_$J(ACTCT,8)_" "_$J((CT-ACTCT),8))
Q
CDET ;
N DGCT,DGDT,DGACT,DGFSTINT,DGL4,DGPTNM,X
Q:'$G(DGMAXPT)
Q:'$G(DGUCCT)
D MESS("")
S DGFSTINT=+(9999999-$G(DGFSTDT)) ;INTERNAL FIRST DATE TO PRINT
I $G(DGFSTDT) D
.D MESS(" Only patients whose Last Activity Date is AFTER "_$E(DGFSTDT,4,5)_"/"_$E(DGFSTDT,6,7)_"/"_$E(DGFSTDT,2,3)_" will be listed.",1)
I DGUCCT>DGMAXPT D
.D MESS(" Only "_DGMAXPT_" patients will be listed.",2)
.D MESS(" To see more, run the PIMS Claim Folder Location Conversion Report",1)
D MESS("PATIENT NAME LAST ACTIVITY CLAIM FOLDER")
D MESS($E(DGSPACE,1,18)_"4-ID DATE LOCATION")
D MESS(DGUND)
S CT=0
F DGACT=0:0 S DGACT=$O(^TMP("DGBDCFL",$J,DGACT)) Q:('DGACT)!(DGMAXPT'>CT)!(DGACT>DGFSTINT) S DFN=0 F CT=CT:1:DGMAXPT S DFN=$O(^TMP("DGBDCFL",$J,DGACT,DFN)) Q:'DFN S DGX=$G(^(DFN)) D
.D GETID
.S X=9999999-DGACT
.D MESS(DGPTNM_$E(DGSPACE,$L(DGPTNM),17)_DGL4_" "_$E(X,4,5)_"-"_$E(X,6,7)_"-"_$E(X,2,3)_$E(DGSPACE,$L(X),6)_" "_$P(DGX,U,2))
Q
GETID ;
N DGPNODE
S DGPNODE=$G(^DPT(DFN,0))
S DGPTNM=$E($P(DGPNODE,U,1),1,15),DGL4=$E($P(DGPNODE,U,9),6,9)
Q
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
MESS(TEXT,LINES) ;ADD TO MAIL TEXT
;
; INPUT VARIABLES:
; DGROOT - ARRAY HOLDING MAIL TEXT (NEEDS TO BE DEFINED)
; TEXT - CONTENT OF NEXT LINE (PARAMETER)
; LINES - [Optional] Parameter to do following line feed(s)
; DGXM - LINE COUNT (NEEDS TO BE DEFINED)
Q:'$G(DGXM)!'$D(TEXT)
N I
S LINES=+$G(LINES)
F I=0:1:LINES D
.S DGXM=DGXM+1
.S @DGROOT@(DGXM,0)=TEXT
.S TEXT=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGYPREG1 4732 printed Dec 13, 2024@03:00:30 Page 2
DGYPREG1 ;ALB/REW - POST-INIT PATIENT FILE POST-INIT CONT'D ;1-APR-93
+1 ;;5.3;Registration;;Aug 13, 1993
CFLREP ;End of Patient File Loop: Problem CFL Fields
+1 NEW DGDJ
+2 ; 1=CFL 2=TOTVACHK
DO SETUP(1)
+3 DO CSUM(1)
DO CDET
+4 DO END
+5 QUIT
TOTVAREP ;End of Patient File Loop: Problem MB Fields
+1 SET DGDJ=$GET(DGDJ)
+2 NEW FROM,REP,SUB,TEXT,TO
+3 NEW DGACT,DGDJ,DGFSTINT,DGL4,DGLPCT,DGPTNM,DGX,DGTEXT,X
+4 SET DGLPCT=0
+5 ;1=CFL 2=TOTVA
DO SETUP(2)
+6 DO CSUM(2)
+7 ;INTERNAL FIRST DATE TO PRINT
SET DGFSTINT=+(9999999-$GET(DGFSTDT))
+8 IF $GET(DGFSTDT)
Begin DoDot:1
+9 DO MESS(" Only patients whose Last Activity Date is AFTER "_$EXTRACT(DGFSTDT,4,5)_"/"_$EXTRACT(DGFSTDT,6,7)_"/"_$EXTRACT(DGFSTDT,2,3)_" will be listed.",1)
End DoDot:1
+10 IF $GET(DGTOTBD)>DGMAXPT
Begin DoDot:1
+11 DO MESS(" Only "_DGMAXPT_" patients will be listed.",2)
+12 DO MESS(" To see more, run the PIMS Monetary Benefit Amounts Conversion Report",1)
End DoDot:1
+13 DO MESS("PATIENT NAME LAST ACTIVITY A&A H.B. Dis. Pension")
+14 DO MESS($EXTRACT(DGSPACE,1,17)_"4-ID DATE AMOUNT AMOUNT AMOUNT AMOUNT")
+15 DO MESS(DGUND)
+16 FOR DGACT=0:0
SET DGACT=$ORDER(^TMP("DGBDMB",$JOB,DGACT))
if 'DGACT
QUIT
FOR DFN=0:0
SET DFN=$ORDER(^TMP("DGBDMB",$JOB,DGACT,DFN))
if 'DFN!(DGLPCT'<DGMAXPT)!(DGACT>DGFSTINT)
QUIT
SET DGX=$GET(^(DFN))
Begin DoDot:1
+17 DO GETID
+18 SET X=9999999-DGACT
+19 SET DGTEXT=DGPTNM_$EXTRACT(DGSPACE,$LENGTH(DGPTNM),16)_DGL4_" "_$EXTRACT(X,4,5)_"-"_$EXTRACT(X,6,7)_"-"_$EXTRACT(X,2,3)_$EXTRACT(DGSPACE,$LENGTH(X),6)_" "
+20 FOR X=1:1:4
SET DGTEXT=DGTEXT_$JUSTIFY($PIECE(DGX,U,X),10,2)
+21 DO MESS(DGTEXT)
+22 SET DGLPCT=DGLPCT+1
End DoDot:1
+23 DO END
+24 QUIT
END ;
+1 NEW DIFROM
+2 DO ^XMD
+3 ;K @DGROOT
+4 KILL DGFSTDT,DGMAXPT,DGROOT,DGSPACE,DGTEXT,DGUCCT,DGUND,DGX,DGXM,DIR,XMDUZ,XMSUB,XMTEXT,XMY
+5 QUIT
SETUP(REP) ;
+1 if '$GET(REP)
QUIT
+2 SET DGDJ=$SELECT($GET(DGDJ):DGDJ,1:$JOB)
+3 SET $PIECE(DGUND,"=",76)=""
+4 SET $PIECE(DGSPACE," ",81)=""
+5 if '$GET(DGMAXPT)
SET DGMAXPT=1999
+6 SET XMSUB=$SELECT(REP=1:"Claims Folder Location Conversion Report",(REP=2):"Total Annual VA Check Amount Conversion Report",1:"PATIENT File ZIP+4 Population Complete")
+7 SET XMDUZ=.5
+8 SET XMY(DUZ)=""
+9 SET XMY(.5)=""
+10 SET DGROOT="^TMP("_$SELECT(REP=1:"""DGCFLREP""",(REP=2):"""DGTOTVA""",1:"""DGZIP4""")_","_$JOB
+11 SET XMTEXT=DGROOT_","
+12 SET DGROOT=DGROOT_")"
+13 KILL @DGROOT
+14 if (REP<3)
DO HEAD^DGYPREG2(REP)
+15 QUIT
CSUM(REP) ;PRINTS SUMMARY
+1 ;OUTPUT: DGUCCT = #Un-Convertible Patients
+2 NEW ACT,ACTCT,CT,DFN,SUB,Z
+3 DO MESS(" "_($EXTRACT(DGSPACE,1,23)_"TOTAL ACTIVE INACTIVE"))
+4 SET Z=9999999-(DT-10000)
+5 SET DGUCCT=0
+6 IF REP=1
FOR SUB="DGBDCFL","DGGDCFL"
SET (CT,ACTCT)=0
DO SUM
if SUB="DGBDCFL"
SET DGUCCT=CT
+7 IF REP=2
FOR SUB="DGBDMB","DGGDMB"
SET (CT,ACTCT)=0
DO SUM
if SUB="DGBDMB"
SET DGUCCT=CT
+8 DO MESS("")
+9 QUIT
SUM ;
+1 FOR ACT=0:0
SET ACT=$ORDER(^TMP(SUB,$JOB,ACT))
if 'ACT
QUIT
Begin DoDot:1
+2 SET DFN=0
FOR CT=CT:1
SET DFN=$ORDER(^TMP(SUB,$JOB,ACT,DFN))
if 'DFN
QUIT
if ACT<Z
SET ACTCT=ACTCT+1
End DoDot:1
+3 DO MESS(" "_$SELECT(SUB["DGBD":"Un-Convertible:",1:"Convertible:")_$EXTRACT(DGSPACE,$SELECT(SUB["DGGD":12,1:15),19)_$JUSTIFY(CT,8)_" "_$JUSTIFY(ACTCT,8)_" "_$JUSTIFY((CT-ACTCT),8))
+4 QUIT
CDET ;
+1 NEW DGCT,DGDT,DGACT,DGFSTINT,DGL4,DGPTNM,X
+2 if '$GET(DGMAXPT)
QUIT
+3 if '$GET(DGUCCT)
QUIT
+4 DO MESS("")
+5 ;INTERNAL FIRST DATE TO PRINT
SET DGFSTINT=+(9999999-$GET(DGFSTDT))
+6 IF $GET(DGFSTDT)
Begin DoDot:1
+7 DO MESS(" Only patients whose Last Activity Date is AFTER "_$EXTRACT(DGFSTDT,4,5)_"/"_$EXTRACT(DGFSTDT,6,7)_"/"_$EXTRACT(DGFSTDT,2,3)_" will be listed.",1)
End DoDot:1
+8 IF DGUCCT>DGMAXPT
Begin DoDot:1
+9 DO MESS(" Only "_DGMAXPT_" patients will be listed.",2)
+10 DO MESS(" To see more, run the PIMS Claim Folder Location Conversion Report",1)
End DoDot:1
+11 DO MESS("PATIENT NAME LAST ACTIVITY CLAIM FOLDER")
+12 DO MESS($EXTRACT(DGSPACE,1,18)_"4-ID DATE LOCATION")
+13 DO MESS(DGUND)
+14 SET CT=0
+15 FOR DGACT=0:0
SET DGACT=$ORDER(^TMP("DGBDCFL",$JOB,DGACT))
if ('DGACT)!(DGMAXPT'>CT)!(DGACT>DGFSTINT)
QUIT
SET DFN=0
FOR CT=CT:1:DGMAXPT
SET DFN=$ORDER(^TMP("DGBDCFL",$JOB,DGACT,DFN))
if 'DFN
QUIT
SET DGX=$GET(^(DFN))
Begin DoDot:1
+16 DO GETID
+17 SET X=9999999-DGACT
+18 DO MESS(DGPTNM_$EXTRACT(DGSPACE,$LENGTH(DGPTNM),17)_DGL4_" "_$EXTRACT(X,4,5)_"-"_$EXTRACT(X,6,7)_"-"_$EXTRACT(X,2,3)_$EXTRACT(DGSPACE,$LENGTH(X),6)_" "_$PIECE(DGX,U,2))
End DoDot:1
+19 QUIT
GETID ;
+1 NEW DGPNODE
+2 SET DGPNODE=$GET(^DPT(DFN,0))
+3 SET DGPTNM=$EXTRACT($PIECE(DGPNODE,U,1),1,15)
SET DGL4=$EXTRACT($PIECE(DGPNODE,U,9),6,9)
+4 QUIT
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
MESS(TEXT,LINES) ;ADD TO MAIL TEXT
+1 ;
+2 ; INPUT VARIABLES:
+3 ; DGROOT - ARRAY HOLDING MAIL TEXT (NEEDS TO BE DEFINED)
+4 ; TEXT - CONTENT OF NEXT LINE (PARAMETER)
+5 ; LINES - [Optional] Parameter to do following line feed(s)
+6 ; DGXM - LINE COUNT (NEEDS TO BE DEFINED)
+7 if '$GET(DGXM)!'$DATA(TEXT)
QUIT
+8 NEW I
+9 SET LINES=+$GET(LINES)
+10 FOR I=0:1:LINES
Begin DoDot:1
+11 SET DGXM=DGXM+1
+12 SET @DGROOT@(DGXM,0)=TEXT
+13 SET TEXT=""
End DoDot:1
+14 QUIT
