Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DG53401P

DG53401P.m

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