- 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 Feb 19, 2025@00:26:31 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