RGPRSSN ;WAS/FHM-MPI/PD PSEUDO/MISSING SSN REPORT ;6/25/98
;;1.0;CLINICAL INFO RESOURCE NETWORK;**19,34**;30 Apr 99
;
;Reference to ^DIC(8 supported by IA #427
;Reference to ^DGPM( supported by IA #966
;Reference to ^SCE( supported by IA #2443
;Reference to ADM^VADPT2 supported by IA #325
;
;EXTRACT BAD SSN AND SORTS THEM BY CLASSIFICATION
W !,"This report will provide a list of:"
W !,"(1) any B Cross-references (there is no 'zero' node but a B x-ref)"
W !," on the patient file,"
W !,"(2) patients with Pseudo SSNs who have not had activity within the past 3 years,"
W !,"(3) patients with Pseudo SSNs who have had activity within the past 3 years.",!
W !,"The Reports are sorted by Primary Eligibility Code. The report can"
W !,"be queued if desired."
W !,!,"For MPI/PD purposes, general advice is to concentrate first on"
W !,"getting correct SSNs for the patients who HAVE had activity within"
W !,"the past 3 years.",!
S %ZIS="QM" D ^%ZIS G EXIT:POP
K ^TMP($J)
I $D(IO("Q")) D Q
.S ZTRTN="DQ^RGPRSSN",ZTDESC="MPI/PD SSN VALIDATION"
.D ^%ZTLOAD D HOME^%ZIS K IO("Q")
DQ N DTOUT,DUOUT S RGFS=1,PRNTCODE="",RGPRNTCO=""
U IO W @IOF,!,"MPI/PD Report of Pseudo, missing & potentially false SSNs "
D NOW^%DTC D YX^%DTC
W ?55,Y,!
W !,"Bad B Cross References Report"
W !,"Please contact IRM for assistance with bad B Cross references."
W !,"----------------------------------------------------------------------------"
S BREF=0
S NAME=""
F S NAME=$O(^DPT("B",NAME)) Q:NAME="" D
.S REFNO=0
.S REFNO=$O(^DPT("B",NAME,REFNO)) Q:REFNO=""
.IF $D(^DPT(REFNO,0)) S NODE=^DPT(REFNO,0),RGSSN=$P(NODE,"^",9)
.E S BREF=1 W !,"B Cross Reference with no 0 Node in DPT: DFN= ",REFNO Q
.IF RGSSN="" S RGSSN="None"
.IF RGSSN'?9N S SCRATCH=$$SETGBL
.IF RGSSN="123456789" S SCRATCH=$$SETGBL
.IF RGSSN="000000000" S SCRATCH=$$SETGBL
.IF RGSSN="111111111" S SCRATCH=$$SETGBL
.IF RGSSN="222222222" S SCRATCH=$$SETGBL
.IF RGSSN="333333333" S SCRATCH=$$SETGBL
.IF RGSSN="444444444" S SCRATCH=$$SETGBL
.IF RGSSN="555555555" S SCRATCH=$$SETGBL
.IF RGSSN="666666666" S SCRATCH=$$SETGBL
.IF RGSSN="777777777" S SCRATCH=$$SETGBL
.IF RGSSN="888888888" S SCRATCH=$$SETGBL
.IF RGSSN?1"9"8N S SCRATCH=$$SETGBL
.QUIT
IF BREF=0 W !,"*** No Bad B Cross References Found in your account.***"
LST S (ACTIV1,ECODE1,NAME1,REFNO1)=""
LST1 S ACTIV1=$O(^TMP($J,ACTIV1)) G EXIT:ACTIV1="" D HEADER G EXIT:$D(DUOUT)!($D(DTOUT))
LST2 S ECODE1=$O(^TMP($J,ACTIV1,ECODE1)) G LST1:ECODE1="" D:$Y>(IOSL-4) HEADER,HEAD2 G:$D(DUOUT)!($D(DTOUT)) EXIT W ! S SCRATCH=$$GETECODE
LST3 S NAME1=$O(^TMP($J,ACTIV1,ECODE1,NAME1)) G LST2:NAME1="" D:$Y>(IOSL-4) HEADER,HEAD2 G:$D(DUOUT)!($D(DTOUT)) EXIT
S REFNO1=^TMP($J,ACTIV1,ECODE1,NAME1)
S (PHONE,RGSSN,ECODE)="None"
;Using VADPT for PHONE# , SSN ,eligibility code, and Name
K VAPTYP,VAHOW,VAROOT,VADM,VAEL,VAPA,VATEST S DFN=REFNO1 D ADD^VADPT,DEM^VADPT,ELIG^VADPT S NAME=VADM(1),RGSSN=$P(VADM(2),U),PHONE=VAPA(8),ECODE=$P(VAEL(1),U)
K VAPTYP,VAHOW,VAROOT,VADM,VAEL,VAPA,VATEST
S ACTIVITY=$$ACTIVE(REFNO1)
W !,?10,ECODE,?20,NAME1,?54,RGSSN,?65,PHONE
GOTO LST3
EXIT D ^%ZISC
S:$D(ZTQUEUED) ZTREQ="@"
K ^TMP($J)
K ACTIV1,ACTIVITY,BREF,ECODE,ECODE1,NAME,NAME1,NODE,NODE2,NODE3
K NODE4,PHONE,PRNTCODE,REFNO,REFNO1,RGFS,RGPRNTCO,SCRATCH,RGSSN,ZTREQ,%ZIS,NODE1,POP,ZTDESC,ZTRTN
QUIT
SETGBL() ;SETS GLOBAL
S ECODE=""
K VAEL S DFN=REFNO D ELIG^VADPT S ECODE=$P(VAEL(1),U)
IF ECODE="" S ECODE="None"
S ACTIVITY=$$ACTIVE(REFNO)
S ^TMP($J,ACTIVITY,ECODE,NAME)=REFNO
QUIT 1
GETECODE() ;
S PRNTCODE="None"
IF $D(^DIC(8,ECODE1,0)) S NODE4=^DIC(8,ECODE1,0),PRNTCODE=$P(NODE4,"^",1)
W !,PRNTCODE S RGFS=0
QUIT 1
LTD(DFN) ;
;FIND LAST TREATMENT DATE
;INPUT: DFN
;OUTPUT: LTD LAST TREATMENT DATE
;
;
N LTD,X
;
; - NEED A PATIENT
I '$G(DFN) S LTD=0 G LTDQ
;
; - IF CURRENT INPATIENT, SET LTD = TODAY AND QUIT
;Current admission movement from ADM^VAPDT2
K VADMVT,VAINDT D ADM^VADPT2 I $L(VADMVT) S LTD=DT K VADMVT,VAERR,VAINDT G LTDQ
K VADMVT,VAERR,VAINDT
;
; - GET THE LAST DISCHARGE DATE
S LTD=+$O(^DGPM("ATID3",DFN,"")) S:LTD LTD=9999999.9999999-LTD\1 S:LTD>DT LTD=DT
;
; - GET THE LAST REGISTRATION DATE AND COMPARE IT TO LTD
K VAROOT,VARP,^UTILITY("VARP",$J) S VARP("F")=2000101 D REG^VADPT I $D(^UTILITY("VARP",$J,1,"I")) S X=$P(^("I"),U) I X S X=X\1 S:X>LTD LTD=X
K ^UTILITY("VARP",$J),VARP,VAERR
;
; - GET THE LAST STOP AND COMPARE TO LTD
; Look at Outpatient Encounter, ^SDV is going away
; Use an API instead of ordering through global
N OPIEN S OPIEN=$$GETLAST^SDOE(DFN,2000101,"C")
I $G(^SCE(+OPIEN,0)) S LTD=$P(^SCE(OPIEN,0),"^",1)\1
;
LTDQ ;
Q $S(LTD:LTD,1:0)
;
ACTIVE(DFN) ;
N LTD,TODAY,DIFF
S LTD=$$LTD(DFN)
Q:LTD'>0 "NO"
Q:$L(LTD)'=7 1_"^"_LTD_"^"_"ZERO"
S TODAY=$$NOW^XLFDT\1
S DIFF=$$FMDIFF^XLFDT(TODAY,LTD)
; if difference is > 1096 days or 3 years
I DIFF>1096 Q "NO"
Q "YES"
I ($E(IOST,1,2)="C-")&(IO=IO(0)) D
. S DIR(0)="E"
. D ^DIR K DIR
Q:$D(DUOUT)!($D(DTOUT))
;;;W:$D(IOF) @IOF
W @IOF,!,"MPI/PD Report of Pseudo, missing & potentially false SSNs "
D NOW^%DTC D YX^%DTC
W ?55,Y,! K Y
W !,?20,"Patient activity within past 3 years = ",$G(ACTIV1)
W !,?1,"Primary"
W !,?1,"Elig Code"
W !,?10,"Elig.",?20,"Name",?54,"SSN",?65,"Home Phone"
W !,"-----------------------------------------------------------------------------"
Q
HEAD2 ;SUB HEADER
Q:$D(DUOUT)!($D(DTOUT))
I RGFS=0,PRNTCODE=RGPRNTCO W !,PRNTCODE
E I RGFS=0 W !,PRNTCODE S RGPRNTCO=PRNTCODE
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRGPRSSN 5722 printed Sep 23, 2025@19:18:44 Page 2
+1 ;;1.0;CLINICAL INFO RESOURCE NETWORK;**19,34**;30 Apr 99
+2 ;
+3 ;Reference to ^DIC(8 supported by IA #427
+4 ;Reference to ^DGPM( supported by IA #966
+5 ;Reference to ^SCE( supported by IA #2443
+6 ;Reference to ADM^VADPT2 supported by IA #325
+7 ;
+8 ;EXTRACT BAD SSN AND SORTS THEM BY CLASSIFICATION
+9 WRITE !,"This report will provide a list of:"
+10 WRITE !,"(1) any B Cross-references (there is no 'zero' node but a B x-ref)"
+11 WRITE !," on the patient file,"
+12 WRITE !,"(2) patients with Pseudo SSNs who have not had activity within the past 3 years,"
+13 WRITE !,"(3) patients with Pseudo SSNs who have had activity within the past 3 years.",!
+14 WRITE !,"The Reports are sorted by Primary Eligibility Code. The report can"
+15 WRITE !,"be queued if desired."
+16 WRITE !,!,"For MPI/PD purposes, general advice is to concentrate first on"
+17 WRITE !,"getting correct SSNs for the patients who HAVE had activity within"
+18 WRITE !,"the past 3 years.",!
+19 SET %ZIS="QM"
DO ^%ZIS
if POP
GOTO EXIT
+20 KILL ^TMP($JOB)
+21 IF $DATA(IO("Q"))
Begin DoDot:1
+22 SET ZTRTN="DQ^RGPRSSN"
SET ZTDESC="MPI/PD SSN VALIDATION"
+23 DO ^%ZTLOAD
DO HOME^%ZIS
KILL IO("Q")
End DoDot:1
QUIT
DQ NEW DTOUT,DUOUT
SET RGFS=1
SET PRNTCODE=""
SET RGPRNTCO=""
+1 USE IO
WRITE @IOF,!,"MPI/PD Report of Pseudo, missing & potentially false SSNs "
+2 DO NOW^%DTC
DO YX^%DTC
+3 WRITE ?55,Y,!
+4 WRITE !,"Bad B Cross References Report"
+5 WRITE !,"Please contact IRM for assistance with bad B Cross references."
+6 WRITE !,"----------------------------------------------------------------------------"
+7 SET BREF=0
+8 SET NAME=""
+9 FOR
SET NAME=$ORDER(^DPT("B",NAME))
if NAME=""
QUIT
Begin DoDot:1
+10 SET REFNO=0
+11 SET REFNO=$ORDER(^DPT("B",NAME,REFNO))
if REFNO=""
QUIT
+12 IF $DATA(^DPT(REFNO,0))
SET NODE=^DPT(REFNO,0)
SET RGSSN=$PIECE(NODE,"^",9)
+13 IF '$TEST
SET BREF=1
WRITE !,"B Cross Reference with no 0 Node in DPT: DFN= ",REFNO
QUIT
+14 IF RGSSN=""
SET RGSSN="None"
+15 IF RGSSN'?9N
SET SCRATCH=$$SETGBL
+16 IF RGSSN="123456789"
SET SCRATCH=$$SETGBL
+17 IF RGSSN="000000000"
SET SCRATCH=$$SETGBL
+18 IF RGSSN="111111111"
SET SCRATCH=$$SETGBL
+19 IF RGSSN="222222222"
SET SCRATCH=$$SETGBL
+20 IF RGSSN="333333333"
SET SCRATCH=$$SETGBL
+21 IF RGSSN="444444444"
SET SCRATCH=$$SETGBL
+22 IF RGSSN="555555555"
SET SCRATCH=$$SETGBL
+23 IF RGSSN="666666666"
SET SCRATCH=$$SETGBL
+24 IF RGSSN="777777777"
SET SCRATCH=$$SETGBL
+25 IF RGSSN="888888888"
SET SCRATCH=$$SETGBL
+26 IF RGSSN?1"9"8N
SET SCRATCH=$$SETGBL
+27 QUIT
End DoDot:1
+28 IF BREF=0
WRITE !,"*** No Bad B Cross References Found in your account.***"
LST SET (ACTIV1,ECODE1,NAME1,REFNO1)=""
LST1 SET ACTIV1=$ORDER(^TMP($JOB,ACTIV1))
if ACTIV1=""
GOTO EXIT
DO HEADER
if $DATA(DUOUT)!($DATA(DTOUT))
GOTO EXIT
LST2 SET ECODE1=$ORDER(^TMP($JOB,ACTIV1,ECODE1))
if ECODE1=""
GOTO LST1
if $Y>(IOSL-4)
DO HEADER
DO HEAD2
if $DATA(DUOUT)!($DATA(DTOUT))
GOTO EXIT
WRITE !
SET SCRATCH=$$GETECODE
LST3 SET NAME1=$ORDER(^TMP($JOB,ACTIV1,ECODE1,NAME1))
if NAME1=""
GOTO LST2
if $Y>(IOSL-4)
DO HEADER
DO HEAD2
if $DATA(DUOUT)!($DATA(DTOUT))
GOTO EXIT
+1 SET REFNO1=^TMP($JOB,ACTIV1,ECODE1,NAME1)
+2 SET (PHONE,RGSSN,ECODE)="None"
+3 ;Using VADPT for PHONE# , SSN ,eligibility code, and Name
+4 KILL VAPTYP,VAHOW,VAROOT,VADM,VAEL,VAPA,VATEST
SET DFN=REFNO1
DO ADD^VADPT
DO DEM^VADPT
DO ELIG^VADPT
SET NAME=VADM(1)
SET RGSSN=$PIECE(VADM(2),U)
SET PHONE=VAPA(8)
SET ECODE=$PIECE(VAEL(1),U)
+5 KILL VAPTYP,VAHOW,VAROOT,VADM,VAEL,VAPA,VATEST
+6 SET ACTIVITY=$$ACTIVE(REFNO1)
+7 WRITE !,?10,ECODE,?20,NAME1,?54,RGSSN,?65,PHONE
+8 GOTO LST3
EXIT DO ^%ZISC
+1 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 KILL ^TMP($JOB)
+3 KILL ACTIV1,ACTIVITY,BREF,ECODE,ECODE1,NAME,NAME1,NODE,NODE2,NODE3
+4 KILL NODE4,PHONE,PRNTCODE,REFNO,REFNO1,RGFS,RGPRNTCO,SCRATCH,RGSSN,ZTREQ,%ZIS,NODE1,POP,ZTDESC,ZTRTN
+5 QUIT
SETGBL() ;SETS GLOBAL
+1 SET ECODE=""
+2 KILL VAEL
SET DFN=REFNO
DO ELIG^VADPT
SET ECODE=$PIECE(VAEL(1),U)
+3 IF ECODE=""
SET ECODE="None"
+4 SET ACTIVITY=$$ACTIVE(REFNO)
+5 SET ^TMP($JOB,ACTIVITY,ECODE,NAME)=REFNO
+6 QUIT 1
GETECODE() ;
+1 SET PRNTCODE="None"
+2 IF $DATA(^DIC(8,ECODE1,0))
SET NODE4=^DIC(8,ECODE1,0)
SET PRNTCODE=$PIECE(NODE4,"^",1)
+3 WRITE !,PRNTCODE
SET RGFS=0
+4 QUIT 1
LTD(DFN) ;
+1 ;FIND LAST TREATMENT DATE
+2 ;INPUT: DFN
+3 ;OUTPUT: LTD LAST TREATMENT DATE
+4 ;
+5 ;
+6 NEW LTD,X
+7 ;
+8 ; - NEED A PATIENT
+9 IF '$GET(DFN)
SET LTD=0
GOTO LTDQ
+10 ;
+11 ; - IF CURRENT INPATIENT, SET LTD = TODAY AND QUIT
+12 ;Current admission movement from ADM^VAPDT2
+13 KILL VADMVT,VAINDT
DO ADM^VADPT2
IF $LENGTH(VADMVT)
SET LTD=DT
KILL VADMVT,VAERR,VAINDT
GOTO LTDQ
+14 KILL VADMVT,VAERR,VAINDT
+15 ;
+16 ; - GET THE LAST DISCHARGE DATE
+17 SET LTD=+$ORDER(^DGPM("ATID3",DFN,""))
if LTD
SET LTD=9999999.9999999-LTD\1
if LTD>DT
SET LTD=DT
+18 ;
+19 ; - GET THE LAST REGISTRATION DATE AND COMPARE IT TO LTD
+20 KILL VAROOT,VARP,^UTILITY("VARP",$JOB)
SET VARP("F")=2000101
DO REG^VADPT
IF $DATA(^UTILITY("VARP",$JOB,1,"I"))
SET X=$PIECE(^("I"),U)
IF X
SET X=X\1
if X>LTD
SET LTD=X
+21 KILL ^UTILITY("VARP",$JOB),VARP,VAERR
+22 ;
+23 ; - GET THE LAST STOP AND COMPARE TO LTD
+24 ; Look at Outpatient Encounter, ^SDV is going away
+25 ; Use an API instead of ordering through global
+26 NEW OPIEN
SET OPIEN=$$GETLAST^SDOE(DFN,2000101,"C")
+27 IF $GET(^SCE(+OPIEN,0))
SET LTD=$PIECE(^SCE(OPIEN,0),"^",1)\1
+28 ;
LTDQ ;
+1 QUIT $SELECT(LTD:LTD,1:0)
+2 ;
ACTIVE(DFN) ;
+1 NEW LTD,TODAY,DIFF
+2 SET LTD=$$LTD(DFN)
+3 if LTD'>0
QUIT "NO"
+4 if $LENGTH(LTD)'=7
QUIT 1_"^"_LTD_"^"_"ZERO"
+5 SET TODAY=$$NOW^XLFDT\1
+6 SET DIFF=$$FMDIFF^XLFDT(TODAY,LTD)
+7 ; if difference is > 1096 days or 3 years
+8 IF DIFF>1096
QUIT "NO"
+9 QUIT "YES"
+1 IF ($EXTRACT(IOST,1,2)="C-")&(IO=IO(0))
Begin DoDot:1
+2 SET DIR(0)="E"
+3 DO ^DIR
KILL DIR
End DoDot:1
+4 if $DATA(DUOUT)!($DATA(DTOUT))
QUIT
+5 ;;;W:$D(IOF) @IOF
+6 WRITE @IOF,!,"MPI/PD Report of Pseudo, missing & potentially false SSNs "
+7 DO NOW^%DTC
DO YX^%DTC
+8 WRITE ?55,Y,!
KILL Y
+9 WRITE !,?20,"Patient activity within past 3 years = ",$GET(ACTIV1)
+10 WRITE !,?1,"Primary"
+11 WRITE !,?1,"Elig Code"
+12 WRITE !,?10,"Elig.",?20,"Name",?54,"SSN",?65,"Home Phone"
+13 WRITE !,"-----------------------------------------------------------------------------"
+14 QUIT
HEAD2 ;SUB HEADER
+1 if $DATA(DUOUT)!($DATA(DTOUT))
QUIT
+2 IF RGFS=0
IF PRNTCODE=RGPRNTCO
WRITE !,PRNTCODE
+3 IF '$TEST
IF RGFS=0
WRITE !,PRNTCODE
SET RGPRNTCO=PRNTCODE
+4 QUIT
