DG53401P ;ALB/AEG - CLEAN UP REQUIRED TESTS THAT SHOULD BE NLR
;;5.3;Registration;**401**;23-AUG-01
;
; This routine is a post-installation for DG*5.3*401 and will look
; at those patients that have a date of death and a primary means
; test on file. The determination will be made if these tests need
; to be changed to NLR status based upon eligibility criteria only
; and will take the necessary action to do so. An email will be
; generated letting the user know which patients had tests changed to
; a NO LONGER REQUIRED status.
;
EN ; Post-install entry point
D INIT
Q
INIT ; Initialize tracking global and associated checkpoints.
K ^TMP($J),^XTMP("DG-DFN"),^XTMP("DG-DGIDT"),^XTMP("DG-DGMTI")
N %,I,X,X1,X2
; Create Checkpoints
I $D(XPDNM) D
.I $$VERCP^XPDUTL("DFN")'>0 D
..S %=$$NEWCP^XPDUTL("DFN","",0)
.I $$VERCP^XPDUTL("DGIDT")'>0 D
..S %=$$NEWCP^XPDUTL("DGIDT","",0)
.I $$VERCP^XPDUTL("DGMTI")'>0 D
..S %=$$NEWCP^XPDUTL("DGMTI","",0)
;
; Initialize tracking global
F I="DFN","DGIDT","DGMTI" D
.I $D(^XTMP("DG-"_I)) Q
.S X1=DT,X2=30 D C^%DTC
.S ^XTMP("DG-"_I,0)=X_U_$$DT^XLFDT_"^DG*5.3*401 POST INSTALL"
.S ^XTMP("DG-"_I,0)=^XTMP("DG-"_I,0)_$S(I="DFN":" Patient Records",I="DGIDT":" Means Test Records Reviewed",I="DGMTI":" MT Records corrected",1:" errors")
I '$D(XPDNM) S (^XTMP("DG-DFN",1),^XTMP("DG-DGIDT",1),^XTMP("DG-DGMTI",1))=0
; Check status and if root check point not complete start cleanup.
I $D(XPDNM) S %=$$VERCP^XPDUTL("DFN") D
.I '$D(^XTMP("DG-DFN",1)) S ^XTMP("DG-DFN",1)=0
.I '$D(^XTMP("DG-DGIDT",1)) S ^XTMP("DG-DGIDT",1)=0
.I '$D(^XTMP("DG-DGMTI",1)) S ^XTMP("DG-DGMTI",1)=0
I $G(%)="" S %=0
I %=0 D START
Q
START ;Main control of action starts here
D EN1
I $D(XPDNM) D
.S %=$$COMCP^XPDUTL("DFN")
.S %=$$COMCP^XPDUTL("DGIDT")
.S %=$$COMCP^XPDUTL("DGMTI")
D BUILD,MAIL,DONE
Q
EN1 ;
D BMES^XPDUTL("POST INSTALLATION PROCESSING")
D MES^XPDUTL("----------------------------")
D MES^XPDUTL("This post installation will generate an e-mail message")
D MES^XPDUTL("reporting on Means Test records for deceased patients")
D MES^XPDUTL("whose eligibility criteria dictate that these tests ")
D MES^XPDUTL("should be in a 'NO LONGER REQUIRED' status. These tests")
D MES^XPDUTL("were not in the correct status for a number of reasons")
D MES^XPDUTL("and are being corrected. This process may take a while,")
D MES^XPDUTL("please be patient. Thanks!")
D BMES^XPDUTL("Search engine started at "_$$FMTE^XLFDT($$NOW^XLFDT))
D BMES^XPDUTL("Each "_"`.`"_" represents approximatly 200 records ")
N DFN,DGMTI,DGCS,DGIDT,DGCNT,DGNODE,MTIEN,DGDOA,DGDT,DGIDT1,DGMTST
S DFN=0 F DGCNT=1:1 S DFN=$O(^DPT(DFN)) Q:'+DFN D
.I '$D(ZTQUEUED) W:'(DGCNT#200) "."
.S ^XTMP("DG-DFN",1)=$G(^XTMP("DG-DFN",1))+1
.D:$P($G(^DPT(DFN,.35)),U)'=""
..S DGDOA=$P($G(^DPT(DFN,.35)),U) I DGDOA["." S DGDOA=$P(DGDOA,".",1)
..S DGDT="",DGIDT=$S($G(DGDT)>0:-DGDT,1:-DT) S:'$P(DGIDT,".",2) DGIDT=DGIDT_.2359
..F S DGIDT=$O(^DGMT(408.31,"AID",1,DFN,DGIDT)) Q:'DGIDT D
...S ^XTMP("DG-DGIDT",1)=$G(^XTMP("DG-DGIDT",1))+1
...F DGMTI=0:0 S DGMTI=$O(^DGMT(408.31,"AID",1,DFN,DGIDT,DGMTI)) Q:'DGMTI D
....S DGIDT1=(DGIDT*-1)
....S DGNODE=$G(^DGMT(408.31,DGMTI,0)),DGMTST=$P(DGNODE,U,3)
....Q:'+$G(^DGMT(408.31,DGMTI,"PRIM"))
....Q:$P($G(DGNODE),U,19)'=1
....I DGNODE,$G(^("PRIM")) S MTIEN=DGMTI_U_$P(DGNODE,U)_U_$$MTS^DGMTU(DFN,DGMTST)_U_$P(DGNODE,U,23)
....I $G(MTIEN),$P(MTIEN,U,4)'="N" D
.....S SUCCESS=$$REQ(DFN,DGMTI,DGMTST,DGIDT)
.....I +SUCCESS=1 S ^TMP($J,"SUCCESS",DFN_"~~"_DGMTI)=DGMTST,^XTMP("DG-DGMTI",1)=$G(^XTMP("DG-DGMTI",1))+1
.....Q
....Q
...I $D(XPDNM) S %=$$UPCP^XPDUTL("DGMTI",DGMTI)
...Q
..I $D(XPDNM) S %=$$UPCP^XPDUTL("DGIDT",DGIDT)
..Q
.I $D(XPDNM) S %=$$UPCP^XPDUTL("DFN",DFN)
.Q
Q
REQ(DFN,DGMTI,DGCS,IDT) ; Determine if test is Required
;
; ** amended copy of EN^DGMTR as check for latest Primary **
; ** test is not valid for this cleanup. **
;
; Input:
; DFN - Patient ID
; DGMTI - Annual Means Test IEN
; DGCS - Annual Means Test Status
; IDT - Means Test Date
;
; Output:
; DGREQF - Means Test Require Flag
; (1 if required and 0 if not required)
; DGDOM1 - DOM Patient Flag (defined and set to 1 if
; patient currently on a DOM ward)
;
N DGDOM,DGMT0,DGMTYPT,OLD,DGRGAUTO,DGQSENT,DGMSGF,SUCCESS,DGREQF
;
S (SUCCESS,DGQSENT,DGREQF)=0,(OLD,DGMTYPT,DGMSGF,DGMTMSG)=1
I $D(^DPT(DFN,.36)) S X=^(.36) D
. I $P($G(^DIC(8,+X,0)),"^",9)=5!($$SC^DGMTR(DFN)) S DGREQF=1
. I $P(X,"^",2),$P(X,"^",2)<3 S DGREQF=0
I DGREQF S:$G(^DPT(DFN,.38)) DGREQF=0
I DGREQF D DOM^DGMTR S:$G(DGDOM) DGREQF=0
S DGMT0=$G(^DGMT(408.31,DGMTI,0))
I DGCS S OLD=$$OLD^DGMTU4(IDT)
I $P($G(^DPT(DFN,.53)),U)="Y" S DGREQF=0
;
D
.I 'DGREQF,DGCS,DGCS'=3,'$G(DGDOM) D NOL^DGMTR S SUCCESS=1 Q
;
;be sure to check whether or not patient is subject to RX copay!
;
D EN^DGMTCOR
Q SUCCESS
DONE ;
K ^TMP($J),^UTILITY($J)
K DGMTMSG
Q
BUILD ;Build ^UTILITY($J, nodes for use by mailman.
I '$D(^TMP($J,"SUCCESS")) D
.S ^UTILITY($J,1)="No means test records found on deceased patients requiring"
.S ^UTILITY($J,2)="correction."
I $D(^TMP($J,"SUCCESS")) D
.S ^UTILITY($J,1)="The following means tests were found for deceased patients"
.S ^UTILITY($J,2)="that should have been in a 'NO LONGER REQUIRED' status. These"
.S ^UTILITY($J,3)="tests were found in a status other than 'NO LONGER REQUIRED'"
.S ^UTILITY($J,4)="and have been corrected. This information is based upon"
.S ^UTILITY($J,5)="the business rules for a 'NO LONGER REQUIRED' status "
.S ^UTILITY($J,6)="determination to be valid."
.S ^UTILITY($J,7)=" "
.S ^UTILITY($J,8)="** SPECIAL NOTE: This report reflects ONLY Current and Previous"
.S ^UTILITY($J,9)=" income year tests corrected by DG*5.3*401."
.S ^UTILITY($J,10)=" "
.S ^UTILITY($J,11)=$$BLDSTR("PATIENT NAME","SSN","TEST DATE")
.S ^UTILITY($J,12)=$$BLDSTR("------------","---","---------")
.N I,DGDFN,DGDFN1,DGSSN,DGMTI,DGMTD,PNAME,OSTAT,NSTAT
.S (DGDFN,DGDFN1,DGSSN,DGMTI)=""
.F I=13:1 S DGDFN=$O(^TMP($J,"SUCCESS",DGDFN)) Q:'+DGDFN D
..S DGDFN1=$P($G(DGDFN),"~~",1)
..S DGMTI=$P($G(DGDFN),"~~",2)
..S PNAME=$P($G(^DPT(DGDFN1,0)),U),P1=PNAME
..S DGSSN=$P($G(^DPT(DGDFN1,0)),U,9),P2=DGSSN
..S DGMTD=$P($G(^DGMT(408.31,DGMTI,0)),U),P3=DGMTD
..Q:P3'>$$LIY(DT)
..S ^UTILITY($J,I)=$$BLDSTR(P1,P2,P3)
..Q
.Q
S ^UTILITY($J,99998)=" "
I $D(^TMP($J,"SUCCESS")) S ^UTILITY($J,99999)="** - Indicates a Pseudo SSN has been used for this patient."
Q
MAIL ;Send an email notifying user of what records were successfully
;changed to NLR status based upon normal MT criterion.
N %,DIFROM,Y,XMDUZ,XMSUB,XMTEXT,XMY,XMZ
S XMY(DUZ)="",XMY(.5)="",XMDUZ="REGISTRATION PACKAGE"
S XMTEXT="^UTILITY($J,"
S XMSUB="'NO LONGER REQUIRED' MEANS TEST ON EXPIRED PTS. CLEANUP"
D ^XMD
D BMES^XPDUTL("MAIL MESSAGE # < "_XMZ_" > SENT.")
Q
BLDSTR(P1,P2,P3) ;Build a string from input variables
; Input - P1 (Parameter 1) = Patient Name
; P2 ( "" 2) = "" SSN
; P3 ( "" 3) = "" MT Date
;
; Output - String built from input variables to be used
; in mailman output.
;
N S1,S2,S3
S S1=$E(P1,1,15),S1=S1_$J(" ",(20-$L(S1)))
S S2=P2
I S2?9N S S2=$E(S2,1,3)_"-"_$E(S2,4,5)_"-"_$E(S2,6,9),S2=S2_$J(" ",(20-$L(S2)))
I S2?9N.A S S2=$E(S2,1,3)_"-"_$E(S2,4,5)_"-"_$E(S2,6,10)_" **",S2=S2_$J(" ",(20-$L(S2)))
I S2'?9N S S2=S2_$J(" ",(20-$L(S2)))
S S3=P3,Y=S3 X ^DD("DD") S S3=Y,S3=S3_$J(" ",(20-$L(S3)))
Q S1_S2_S3
LIY(DT) ;Determine Last Income year
N X,%DT,Y,DGINY
S X="T",%DT="" D ^%DT
S DGINY=Y,DGINY=$$LYR^DGMTSCU1(DGINY)
Q (DGINY-10000)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDG53401P 7902 printed Dec 13, 2024@02:37:22 Page 2
DG53401P ;ALB/AEG - CLEAN UP REQUIRED TESTS THAT SHOULD BE NLR
+1 ;;5.3;Registration;**401**;23-AUG-01
+2 ;
+3 ; This routine is a post-installation for DG*5.3*401 and will look
+4 ; at those patients that have a date of death and a primary means
+5 ; test on file. The determination will be made if these tests need
+6 ; to be changed to NLR status based upon eligibility criteria only
+7 ; and will take the necessary action to do so. An email will be
+8 ; generated letting the user know which patients had tests changed to
+9 ; a NO LONGER REQUIRED status.
+10 ;
EN ; Post-install entry point
+1 DO INIT
+2 QUIT
INIT ; Initialize tracking global and associated checkpoints.
+1 KILL ^TMP($JOB),^XTMP("DG-DFN"),^XTMP("DG-DGIDT"),^XTMP("DG-DGMTI")
+2 NEW %,I,X,X1,X2
+3 ; Create Checkpoints
+4 IF $DATA(XPDNM)
Begin DoDot:1
+5 IF $$VERCP^XPDUTL("DFN")'>0
Begin DoDot:2
+6 SET %=$$NEWCP^XPDUTL("DFN","",0)
End DoDot:2
+7 IF $$VERCP^XPDUTL("DGIDT")'>0
Begin DoDot:2
+8 SET %=$$NEWCP^XPDUTL("DGIDT","",0)
End DoDot:2
+9 IF $$VERCP^XPDUTL("DGMTI")'>0
Begin DoDot:2
+10 SET %=$$NEWCP^XPDUTL("DGMTI","",0)
End DoDot:2
End DoDot:1
+11 ;
+12 ; Initialize tracking global
+13 FOR I="DFN","DGIDT","DGMTI"
Begin DoDot:1
+14 IF $DATA(^XTMP("DG-"_I))
QUIT
+15 SET X1=DT
SET X2=30
DO C^%DTC
+16 SET ^XTMP("DG-"_I,0)=X_U_$$DT^XLFDT_"^DG*5.3*401 POST INSTALL"
+17 SET ^XTMP("DG-"_I,0)=^XTMP("DG-"_I,0)_$SELECT(I="DFN":" Patient Records",I="DGIDT":" Means Test Records Reviewed",I="DGMTI":" MT Records corrected",1:" errors")
End DoDot:1
+18 IF '$DATA(XPDNM)
SET (^XTMP("DG-DFN",1),^XTMP("DG-DGIDT",1),^XTMP("DG-DGMTI",1))=0
+19 ; Check status and if root check point not complete start cleanup.
+20 IF $DATA(XPDNM)
SET %=$$VERCP^XPDUTL("DFN")
Begin DoDot:1
+21 IF '$DATA(^XTMP("DG-DFN",1))
SET ^XTMP("DG-DFN",1)=0
+22 IF '$DATA(^XTMP("DG-DGIDT",1))
SET ^XTMP("DG-DGIDT",1)=0
+23 IF '$DATA(^XTMP("DG-DGMTI",1))
SET ^XTMP("DG-DGMTI",1)=0
End DoDot:1
+24 IF $GET(%)=""
SET %=0
+25 IF %=0
DO START
+26 QUIT
START ;Main control of action starts here
+1 DO EN1
+2 IF $DATA(XPDNM)
Begin DoDot:1
+3 SET %=$$COMCP^XPDUTL("DFN")
+4 SET %=$$COMCP^XPDUTL("DGIDT")
+5 SET %=$$COMCP^XPDUTL("DGMTI")
End DoDot:1
+6 DO BUILD
DO MAIL
DO DONE
+7 QUIT
EN1 ;
+1 DO BMES^XPDUTL("POST INSTALLATION PROCESSING")
+2 DO MES^XPDUTL("----------------------------")
+3 DO MES^XPDUTL("This post installation will generate an e-mail message")
+4 DO MES^XPDUTL("reporting on Means Test records for deceased patients")
+5 DO MES^XPDUTL("whose eligibility criteria dictate that these tests ")
+6 DO MES^XPDUTL("should be in a 'NO LONGER REQUIRED' status. These tests")
+7 DO MES^XPDUTL("were not in the correct status for a number of reasons")
+8 DO MES^XPDUTL("and are being corrected. This process may take a while,")
+9 DO MES^XPDUTL("please be patient. Thanks!")
+10 DO BMES^XPDUTL("Search engine started at "_$$FMTE^XLFDT($$NOW^XLFDT))
+11 DO BMES^XPDUTL("Each "_"`.`"_" represents approximatly 200 records ")
+12 NEW DFN,DGMTI,DGCS,DGIDT,DGCNT,DGNODE,MTIEN,DGDOA,DGDT,DGIDT1,DGMTST
+13 SET DFN=0
FOR DGCNT=1:1
SET DFN=$ORDER(^DPT(DFN))
if '+DFN
QUIT
Begin DoDot:1
+14 IF '$DATA(ZTQUEUED)
if '(DGCNT#200)
WRITE "."
+15 SET ^XTMP("DG-DFN",1)=$GET(^XTMP("DG-DFN",1))+1
+16 if $PIECE($GET(^DPT(DFN,.35)),U)'=""
Begin DoDot:2
+17 SET DGDOA=$PIECE($GET(^DPT(DFN,.35)),U)
IF DGDOA["."
SET DGDOA=$PIECE(DGDOA,".",1)
+18 SET DGDT=""
SET DGIDT=$SELECT($GET(DGDT)>0:-DGDT,1:-DT)
if '$PIECE(DGIDT,".",2)
SET DGIDT=DGIDT_.2359
+19 FOR
SET DGIDT=$ORDER(^DGMT(408.31,"AID",1,DFN,DGIDT))
if 'DGIDT
QUIT
Begin DoDot:3
+20 SET ^XTMP("DG-DGIDT",1)=$GET(^XTMP("DG-DGIDT",1))+1
+21 FOR DGMTI=0:0
SET DGMTI=$ORDER(^DGMT(408.31,"AID",1,DFN,DGIDT,DGMTI))
if 'DGMTI
QUIT
Begin DoDot:4
+22 SET DGIDT1=(DGIDT*-1)
+23 SET DGNODE=$GET(^DGMT(408.31,DGMTI,0))
SET DGMTST=$PIECE(DGNODE,U,3)
+24 if '+$GET(^DGMT(408.31,DGMTI,"PRIM"))
QUIT
+25 if $PIECE($GET(DGNODE),U,19)'=1
QUIT
+26 IF DGNODE
IF $GET(^("PRIM"))
SET MTIEN=DGMTI_U_$PIECE(DGNODE,U)_U_$$MTS^DGMTU(DFN,DGMTST)_U_$PIECE(DGNODE,U,23)
+27 IF $GET(MTIEN)
IF $PIECE(MTIEN,U,4)'="N"
Begin DoDot:5
+28 SET SUCCESS=$$REQ(DFN,DGMTI,DGMTST,DGIDT)
+29 IF +SUCCESS=1
SET ^TMP($JOB,"SUCCESS",DFN_"~~"_DGMTI)=DGMTST
SET ^XTMP("DG-DGMTI",1)=$GET(^XTMP("DG-DGMTI",1))+1
+30 QUIT
End DoDot:5
+31 QUIT
End DoDot:4
+32 IF $DATA(XPDNM)
SET %=$$UPCP^XPDUTL("DGMTI",DGMTI)
+33 QUIT
End DoDot:3
+34 IF $DATA(XPDNM)
SET %=$$UPCP^XPDUTL("DGIDT",DGIDT)
+35 QUIT
End DoDot:2
+36 IF $DATA(XPDNM)
SET %=$$UPCP^XPDUTL("DFN",DFN)
+37 QUIT
End DoDot:1
+38 QUIT
REQ(DFN,DGMTI,DGCS,IDT) ; Determine if test is Required
+1 ;
+2 ; ** amended copy of EN^DGMTR as check for latest Primary **
+3 ; ** test is not valid for this cleanup. **
+4 ;
+5 ; Input:
+6 ; DFN - Patient ID
+7 ; DGMTI - Annual Means Test IEN
+8 ; DGCS - Annual Means Test Status
+9 ; IDT - Means Test Date
+10 ;
+11 ; Output:
+12 ; DGREQF - Means Test Require Flag
+13 ; (1 if required and 0 if not required)
+14 ; DGDOM1 - DOM Patient Flag (defined and set to 1 if
+15 ; patient currently on a DOM ward)
+16 ;
+17 NEW DGDOM,DGMT0,DGMTYPT,OLD,DGRGAUTO,DGQSENT,DGMSGF,SUCCESS,DGREQF
+18 ;
+19 SET (SUCCESS,DGQSENT,DGREQF)=0
SET (OLD,DGMTYPT,DGMSGF,DGMTMSG)=1
+20 IF $DATA(^DPT(DFN,.36))
SET X=^(.36)
Begin DoDot:1
+21 IF $PIECE($GET(^DIC(8,+X,0)),"^",9)=5!($$SC^DGMTR(DFN))
SET DGREQF=1
+22 IF $PIECE(X,"^",2)
IF $PIECE(X,"^",2)<3
SET DGREQF=0
End DoDot:1
+23 IF DGREQF
if $GET(^DPT(DFN,.38))
SET DGREQF=0
+24 IF DGREQF
DO DOM^DGMTR
if $GET(DGDOM)
SET DGREQF=0
+25 SET DGMT0=$GET(^DGMT(408.31,DGMTI,0))
+26 IF DGCS
SET OLD=$$OLD^DGMTU4(IDT)
+27 IF $PIECE($GET(^DPT(DFN,.53)),U)="Y"
SET DGREQF=0
+28 ;
+29 Begin DoDot:1
+30 IF 'DGREQF
IF DGCS
IF DGCS'=3
IF '$GET(DGDOM)
DO NOL^DGMTR
SET SUCCESS=1
QUIT
End DoDot:1
+31 ;
+32 ;be sure to check whether or not patient is subject to RX copay!
+33 ;
+34 DO EN^DGMTCOR
+35 QUIT SUCCESS
DONE ;
+1 KILL ^TMP($JOB),^UTILITY($JOB)
+2 KILL DGMTMSG
+3 QUIT
BUILD ;Build ^UTILITY($J, nodes for use by mailman.
+1 IF '$DATA(^TMP($JOB,"SUCCESS"))
Begin DoDot:1
+2 SET ^UTILITY($JOB,1)="No means test records found on deceased patients requiring"
+3 SET ^UTILITY($JOB,2)="correction."
End DoDot:1
+4 IF $DATA(^TMP($JOB,"SUCCESS"))
Begin DoDot:1
+5 SET ^UTILITY($JOB,1)="The following means tests were found for deceased patients"
+6 SET ^UTILITY($JOB,2)="that should have been in a 'NO LONGER REQUIRED' status. These"
+7 SET ^UTILITY($JOB,3)="tests were found in a status other than 'NO LONGER REQUIRED'"
+8 SET ^UTILITY($JOB,4)="and have been corrected. This information is based upon"
+9 SET ^UTILITY($JOB,5)="the business rules for a 'NO LONGER REQUIRED' status "
+10 SET ^UTILITY($JOB,6)="determination to be valid."
+11 SET ^UTILITY($JOB,7)=" "
+12 SET ^UTILITY($JOB,8)="** SPECIAL NOTE: This report reflects ONLY Current and Previous"
+13 SET ^UTILITY($JOB,9)=" income year tests corrected by DG*5.3*401."
+14 SET ^UTILITY($JOB,10)=" "
+15 SET ^UTILITY($JOB,11)=$$BLDSTR("PATIENT NAME","SSN","TEST DATE")
+16 SET ^UTILITY($JOB,12)=$$BLDSTR("------------","---","---------")
+17 NEW I,DGDFN,DGDFN1,DGSSN,DGMTI,DGMTD,PNAME,OSTAT,NSTAT
+18 SET (DGDFN,DGDFN1,DGSSN,DGMTI)=""
+19 FOR I=13:1
SET DGDFN=$ORDER(^TMP($JOB,"SUCCESS",DGDFN))
if '+DGDFN
QUIT
Begin DoDot:2
+20 SET DGDFN1=$PIECE($GET(DGDFN),"~~",1)
+21 SET DGMTI=$PIECE($GET(DGDFN),"~~",2)
+22 SET PNAME=$PIECE($GET(^DPT(DGDFN1,0)),U)
SET P1=PNAME
+23 SET DGSSN=$PIECE($GET(^DPT(DGDFN1,0)),U,9)
SET P2=DGSSN
+24 SET DGMTD=$PIECE($GET(^DGMT(408.31,DGMTI,0)),U)
SET P3=DGMTD
+25 if P3'>$$LIY(DT)
QUIT
+26 SET ^UTILITY($JOB,I)=$$BLDSTR(P1,P2,P3)
+27 QUIT
End DoDot:2
+28 QUIT
End DoDot:1
+29 SET ^UTILITY($JOB,99998)=" "
+30 IF $DATA(^TMP($JOB,"SUCCESS"))
SET ^UTILITY($JOB,99999)="** - Indicates a Pseudo SSN has been used for this patient."
+31 QUIT
MAIL ;Send an email notifying user of what records were successfully
+1 ;changed to NLR status based upon normal MT criterion.
+2 NEW %,DIFROM,Y,XMDUZ,XMSUB,XMTEXT,XMY,XMZ
+3 SET XMY(DUZ)=""
SET XMY(.5)=""
SET XMDUZ="REGISTRATION PACKAGE"
+4 SET XMTEXT="^UTILITY($J,"
+5 SET XMSUB="'NO LONGER REQUIRED' MEANS TEST ON EXPIRED PTS. CLEANUP"
+6 DO ^XMD
+7 DO BMES^XPDUTL("MAIL MESSAGE # < "_XMZ_" > SENT.")
+8 QUIT
BLDSTR(P1,P2,P3) ;Build a string from input variables
+1 ; Input - P1 (Parameter 1) = Patient Name
+2 ; P2 ( "" 2) = "" SSN
+3 ; P3 ( "" 3) = "" MT Date
+4 ;
+5 ; Output - String built from input variables to be used
+6 ; in mailman output.
+7 ;
+8 NEW S1,S2,S3
+9 SET S1=$EXTRACT(P1,1,15)
SET S1=S1_$JUSTIFY(" ",(20-$LENGTH(S1)))
+10 SET S2=P2
+11 IF S2?9N
SET S2=$EXTRACT(S2,1,3)_"-"_$EXTRACT(S2,4,5)_"-"_$EXTRACT(S2,6,9)
SET S2=S2_$JUSTIFY(" ",(20-$LENGTH(S2)))
+12 IF S2?9N.A
SET S2=$EXTRACT(S2,1,3)_"-"_$EXTRACT(S2,4,5)_"-"_$EXTRACT(S2,6,10)_" **"
SET S2=S2_$JUSTIFY(" ",(20-$LENGTH(S2)))
+13 IF S2'?9N
SET S2=S2_$JUSTIFY(" ",(20-$LENGTH(S2)))
+14 SET S3=P3
SET Y=S3
XECUTE ^DD("DD")
SET S3=Y
SET S3=S3_$JUSTIFY(" ",(20-$LENGTH(S3)))
+15 QUIT S1_S2_S3
LIY(DT) ;Determine Last Income year
+1 NEW X,%DT,Y,DGINY
+2 SET X="T"
SET %DT=""
DO ^%DT
+3 SET DGINY=Y
SET DGINY=$$LYR^DGMTSCU1(DGINY)
+4 QUIT (DGINY-10000)
