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

DVBANDCU.m

Go to the documentation of this file. 
  1. DVBANDCU ;ALB/GTS - Clean-up routine 7131 ASIH notice of discharges; 12 Mar 96 @ 14:00pm [3/12/96 1:45pm]
  1.  ;;2/7;AMIE;**5**;Mar 12, 1996
  1.  ;
  1. TEXT ;;
  1.  ;;This routine will walk through the FORM 7131 file (#396) and cleanup
  1.  ;;any ASIH admission dates.
  1.  ;;
  1.  ;;Once the process has completed, a MailMan message will be
  1.  ;;delivered to the person installing the patch.  The message
  1.  ;;will list 7131 requests that were cleaned up and Notices of
  1.  ;;Discharge generated.  If Notices of Discharge were generated,
  1.  ;;it is recommended you forward this message to those Regional
  1.  ;;Office AMIE users so they will be aware of the changes to the
  1.  ;;data in the AMIE system.
  1.  ;;
  1.  ;;
  1.  ;;QUIT
  1.  ;
  1. STARTPT ;
  1.  S (LNI,LNX)=""
  1.  D MES^XPDUTL(" "),MES^XPDUTL(" ")
  1.  F LNI=1:1 S LNX=$P($T(TEXT+LNI),";;",2) Q:(LNX="QUIT")  DO
  1.  .S:LNX="" LNX=" "
  1.  .D MES^XPDUTL(LNX)
  1.  D CLN7131
  1.  K LNI,LNX
  1.  Q
  1.  ;
  1. CLN7131 ;** Init process, call correction tag and send mail msg
  1.  S VAFEDXCT=0
  1.  D LINE("Results of AMIE 7131 ASIH clean-up at station "_$$SITE^VASITE())
  1.  D LINE("")
  1.  D LINE("Start time:  "_$$NOW^XLFDT()),LINE("Job Number:  "_$J)
  1.  D LINE(""),LINE("")
  1.  D LINE("This message was generated as part of the clean up performed with")
  1.  D LINE(" the installation of patch DVBA*2.7*5.")
  1.  D LINE("")
  1.  D LINE("IRM STAFF INFORMATION FOLLOWS: ")
  1.  D LINE("The following is a list of 7131 requests entered for an ASIH")
  1.  D LINE(" Admission date.  The Admission Date field (#3) was changed so")
  1.  D LINE(" the time stamp no longer indicates ASIH."),LINE("")
  1.  D LINE("Only Regional Office Staff need be concerned with this.")
  1.  D LINE("")
  1.  D LINE("REGIONAL OFFICE STAFF INFORMATION FOLLOWS: ")
  1.  D LINE("R/O Staff, If you are adjudicating the claim of a veteran listed here,")
  1.  D LINE(" be aware that Notices of Discharge generated for the admission date noted")
  1.  D LINE(" may indicate discharge to another VA Facility.")
  1.  D LINE("Check the veteran's claim folder for determination of action necessary.")
  1.  D LINE(""),LINE("")
  1.  D CORRECT ;** Correct 7131 ASIH records
  1.  D LINE("")
  1.  D LINE("End time:  "_$$NOW^XLFDT())
  1.  D MAIL ; mail results
  1.  Q
  1.  ;
  1. CORRECT ;** Walk 7131s, correct ASIH admit dts and gen 7132s
  1.  N CT,J,DVBARQDT,DVBAASIH,DVBAPAT,DVBADFN,DGPMDA,DGDT,TDIS
  1.  D SETXRO ;* Set RO station # array
  1.  S CT=0
  1.  S (J,DVBARQDT)=""
  1.  F  S DVBARQDT=$O(^DVB(396,"G",DVBARQDT)) Q:(DVBARQDT="")  DO
  1.  .F  S J=$O(^DVB(396,"G",DVBARQDT,J)) Q:J=""  DO
  1.  ..I $D(^DVB(396,J,0)),($D(^DVB(396,J,2))) DO
  1.  ...S DVBAASIH=$P(DVBARQDT,".",2)
  1.  ...I ($L(DVBAASIH)>6)&($P(^DVB(396,J,2),"^",10)="A") DO
  1.  ....S DVBADFN=$P(^DVB(396,J,0),"^",1)
  1.  ....S DVBAPAT=$P($G(^DPT(DVBADFN,0)),"^",1)
  1.  ....S:DVBAPAT="" DVBAPAT="(IRM NOTE: Bad patient name for DFN "_DVBADFN_")"
  1.  ....S DFN=DVBADFN
  1.  ....S VAIP("D")=DVBARQDT
  1.  ....S VAIP("M")=0
  1.  ....D IN5^VADPT
  1.  ....S DGPMDA=VAIP(1)
  1.  ....S DGDT=0
  1.  ....S DGDT=VAIP(17)
  1.  ....S TDIS=$P(VAIP(17,3),"^",2)
  1.  ....K VAIP,DFN
  1.  ....S DVBARQDT=+$E(DVBARQDT,1,14)
  1.  ....S DA=J,DIE="^DVB(396,",DR="3////^S X=DVBARQDT"
  1.  ....D ^DIE
  1.  ....K DIE,DR,X,DA
  1.  ....S Y=DVBARQDT
  1.  ....X ^DD("DD")
  1.  ....D LINE("  "_DVBAPAT_" 7131 for ASIH Admission Date "_Y_" corrected.")
  1.  ....K Y
  1.  ....D:DGDT GEN7132(DVBADFN,J,DVBARQDT,DGPMDA,TDIS)
  1.  ....S CT=CT+1
  1.  D:+CT'>0 LINE("No ASIH Admission 7131s were found for your Medical Center.")
  1.  D LINE(""),LINE("")
  1.  D LINE("The number of records corrected was "_CT)
  1.  D LINE(""),LINE("")
  1.  D:+CT>0 LINE("IRM PERSONNEL: ")
  1.  D:+CT>0 LINE("Please forward this message to Regional Office personnel who use your system.")
  1.  K XRO
  1.  Q
  1.  ;
  1. SETXRO ;* Set up regional office station numbers array
  1.  N I,J
  1.  F I=0:0 S I=$O(^DVB(396.1,1,1,I)) Q:I=""!(+I=0)  S J=$P(^(I,0),U,1),J=$S($D(^DIC(4,+J,99)):$P(^(99),U),1:"") I J]"" S XRO(J)=""
  1.  Q
  1.  ;
  1. GEN7132(DFN,DVBADA,ADMDT,DGPMDA,TDIS) ;* Gen Notice of Discharge (file 396.2)
  1.  ;**NOTE: XRO(n) Array must be defined with N being the RO station #s
  1.  N CFLOC
  1.  S CFLOC=$P($G(^DPT(DFN,.31)),"^",4)
  1.  S:CFLOC'="" CFLOC=$S($D(^DIC(4,CFLOC,99)):$P(^DIC(4,CFLOC,99),"^",1),1:"")
  1.  Q:CFLOC=""  ;QUIT:no CFLOC
  1.  I '$D(XRO(CFLOC))&(CFLOC'=376) Q  ;**QUIT if RO not user at site
  1.  I CFLOC=376,TDIS["DEATH" S CFLOC=$O(XRO(0)) Q:CFLOC=""  ;QUIT:no RO'S
  1.  Q:$D(^DVB(396.2,"D",ADMDT,DFN))  ;**QUIT if 7132 exists
  1.  I ($P(^DVB(396,DVBADA,0),U,5)="YES")&($P(^(0),U,9)="P") DO
  1.  .S SSN=$P($G(^DPT(DFN,0)),"^",9)
  1.  .S (DIC,DIE)="^DVB(396.2,"
  1.  .S DR="3.5///"_CFLOC_";1///"_ADMDT_";2///"_DGPMDA_";3///R"
  1.  .S DLAYGO=396.2,DIC(0)="QLM",X=""""_SSN_""""
  1.  .D ^DIC
  1.  .I +Y>0 DO
  1.  ..S DA=+Y
  1.  ..D ^DIE
  1.  ..D LINE("    .....Notice of Discharge has been generated!")
  1.  ..D LINE(""),LINE("")
  1.  .K DR,DLAYGO,DIC,DIE,X,Y,SSN
  1.  Q
  1.  ;
  1. MAIL ;** Mail Cleanup msg
  1.  N DIFROM
  1.  K XMY
  1.  S XMSUB="AMIE 7131 ASIH clean up"
  1.  S XMN=0
  1.  S XMTEXT="^TMP(""DVBA ASIH CLEANUP"",$J,"
  1.  S XMDUZ=.5,XMY(DUZ)=""
  1.  D ^XMD
  1.  D MES^XPDUTL(" "),MES^XPDUTL(" ")
  1.  D MES^XPDUTL("  ...Message has been delivered to installer!")
  1.  K VAFEDXCT,XMDUZ,XMN,XMSUB,XMTEXT,XMY,^TMP("DVBA ASIH CLEANUP",$J)
  1.  Q
  1.  ;
  1. LINE(TEXT) ; add line to array for e-mail
  1.  S VAFEDXCT=VAFEDXCT+1,^TMP("DVBA ASIH CLEANUP",$J,VAFEDXCT)=TEXT
  1.  Q