- 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 Feb 18, 2025@23:09:08 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
