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

RMPREXDS.m

Go to the documentation of this file. 
  1. RMPREXDS ;PHX/HNB -National Data Extract Pros Disability Codes - 10/30/96
  1.  ;;3.0;PROSTHETICS;**18**;Feb 09, 1996
  1.  ;can't enter from top
  1.  Q
  1. EN(RMPRDT1,RMPRDT2) ;entry point
  1.  ;send message to chief prosthetics notify of activation
  1.  D NOT
  1.  S RMPRB=0,CNT=1
  1.  K ^TMP($J),^TMP("RMPR",$J),^TMP("RMPRF",$J)
  1.  F  S RMPRB=$O(^RMPR(660,"B",RMPRB)) Q:(RMPRB>RMPRDT2)!(RMPRB'>0)  D
  1.  .Q:RMPRB<RMPRDT1
  1.  .S RMPRA=0
  1.  .F  S RMPRA=$O(^RMPR(660,"B",RMPRB,RMPRA)) Q:RMPRA'>0  D
  1.  . .S DFN=$P($G(^RMPR(660,RMPRA,0)),U,2)
  1.  . .Q:DFN=""
  1.  . .Q:$D(^TMP("RMPR",$J,DFN))
  1.  . .;leave out historical records
  1.  . .Q:$P(^RMPR(660,RMPRA,0),U,15)
  1.  . .S STN=$P(^RMPR(660,RMPRA,0),U,10)
  1.  . .Q:STN=""
  1.  . .S STN=$P($G(^DIC(4,STN,99)),U,1)
  1.  . .Q:STN=""
  1.  . .D SSN
  1.  . .D DS
  1.  . .D CK
  1.  D:$D(^TMP($J)) MAIL1
  1.  D MAILS
  1.  Q
  1. DS ;patients disability codes/records
  1.  Q:$D(^TMP("RMPR",$J,DFN))
  1.  D GETS^DIQ(665,DFN_",","**","","RDIS")
  1.  MERGE R19=RDIS(665.01)
  1.  K RDIS
  1.  Q:'$D(R19)
  1.  S B1=0
  1.  F  S B1=$O(R19(B1)) Q:B1=""  D
  1.  .S B2=0
  1.  .F  S B2=$O(R19(B1,B2)) Q:B2=""  D
  1.  . .;format for mailman ^TMP($J,counter)=station number^ssn^field^value
  1.  . .Q:B2=1
  1.  . .Q:B2>5
  1.  . .S ^TMP($J,CNT)=STN_U_RMPRSSN_U_B2_U_R19(B1,B2)
  1.  . .S ^TMP("RMPR",$J,DFN)=""
  1.  . .S CNT=CNT+1
  1.  K R19,RMPRSSN,STN
  1.  Q
  1. SSN ;pull ssn
  1.  D DEM^VADPT
  1.  S RMPRSSN=+VADM(2)
  1.  K VADM
  1.  Q
  1. NOT ;send notificaton to mail group
  1.  S Y=RMPRDT1 D DD^%DT S RMPRDAT1=Y
  1.  S Y=RMPRDT2 D DD^%DT S RMPRDAT2=Y
  1.  S XMDUZ=.5
  1.  S XMY("G.RMPR SERVER")=""
  1.  S XMSUB="Prosthetics Data Extract "_RMPRDAT1_" to "_RMPRDAT2
  1.  S RMPRMSG(1)="The National Data Server has been activated today by Prosthetics HQ."
  1.  S RMPRMSG(2)="Data has been collected for the date range "_RMPRDAT1_" to "_RMPRDAT2_"."
  1.  S RMPRMSG(3)="Disability Code information will be transmitted."
  1.  S RMPRMSG(4)="This was activated by "_$P(XMFROM,"@",1)
  1.  S RMPRMSG(5)=""
  1.  S XMTEXT="RMPRMSG("
  1.  D ^XMD
  1.  K RMPRMSG,RMPRDAT1,RMPRDAT2
  1.  Q
  1. CK ;check line length to send
  1.  I CNT>4999 D MAIL1 S CNT=1 Q
  1.  Q
  1. MAIL1 ;send message
  1.  S XMTEXT="^TMP($J,"
  1.  S XMDUZ=.5
  1.  S XMY("G.PROSTHETICS@PSAS.DOMAIN.EXT")=""
  1.  S XMSUB="PSAS National Extract From "_$P($$SITE^VASITE,U,2)
  1.  D ^XMD S RMPRXMZ(XMZ)=XMZ
  1.  K ^TMP($J)
  1.  Q
  1. MAIL ;send it
  1.  S CNT=1
  1.  F  S RMPRA=$O(^TMP($J,RMPRA)) Q:RMPRA=""  D
  1.  .S ^TMP("RMPRF",$J,CNT)=^TMP($J,RMPRA)
  1.  .K ^TMP($J,RMPRA)
  1.  .S CNT=CNT+1
  1.  .I CNT>4999 D
  1.  . .S XMTEXT="^TMP(""RMPRF"",$J,"
  1.  . .S XMDUZ=.5
  1.  . .S XMY("G.PROSTHETICS@PSAS.DOMAIN.EXT")=""
  1.  . .S XMSUB="PSAS National Extract From "_$P($$SITE^VASITE,U,2)
  1.  . .D ^XMD K ^TMP("RMPRF",$J) S RMPRXMZ(XMZ)=XMZ,CNT=1
  1.  S XMTEXT="^TMP(""RMPRF"",$J,"
  1.  S XMDUZ=.5
  1.  S XMY("G.PROSTHETICS@PSAS.DOMAIN.EXT")=""
  1.  S XMSUB="PSAS National Extract From "_$P($$SITE^VASITE,U,2)
  1.  D ^XMD K ^TMP("RMPRF",$J) S RMPRXMZ(XMZ)=XMZ
  1. MAILS ;mail summary message
  1.  Q:'$D(RMPRXMZ)
  1.  S RMPRB=0,RMPRTOT=0
  1.  F  S RMPRB=$O(^TMP("RMPR",$J,RMPRB)) Q:RMPRB=""  S RMPRTOT=RMPRTOT+1
  1.  S XMTEXT="RMPRXMZ("
  1.  S RMPRXMZ(1)="Total Number of Unique SSN's for this site: "_RMPRTOT
  1.  S XMDUZ=.5
  1.  S XMY("G.PROSTHETICS@PSAS.DOMAIN.EXT")=""
  1.  S XMSUB="PSAS Summary National Extract From "_$P($$SITE^VASITE,U,2)
  1.  D ^XMD
  1.  ;END