- 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 Jan 18, 2025@03:38:04 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)