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

RMPREXT.m

Go to the documentation of this file. 
  1. RMPREXT ;PHX/HNC-DATA EXTRACT FOR Nppd  ;4/20/1995
  1.  ;;3.0;PROSTHETICS;**12,18,24,64,59,103,106,109,113,126,138**;Feb 09, 1996;Build 11
  1.  ;Per VHA Directive 10-93-142, this routine should not be modified.
  1.  ;
  1.  ;DBIA #4599, Vendor file read 38,39,18.3,8.3
  1.  ;
  1.  ;patch 113 - roll back to 5000 lines
  1.  ;            add count of records to summary message and 
  1.  ;            count by station number to summary total
  1.  ;            add site- to ien, use ~ as data delimiter
  1.  ;            add d1 and d2 flags for EXE parsing tool
  1.  ;
  1.  ;patch 126/hnc - check length, bug in GUI ignores DD field length
  1.  ;
  1.  ;patch 60/hnc - DDC interface, include DDC data fields.
  1.  ;               8/23/2006
  1.  ;
  1. EN ;extract from 660
  1.  N %ZIS,ZTIO,ZTRTN,ZTSK,ZTDESC
  1.  S %ZIS="Q" D ^%ZIS Q:POP
  1.  I $D(IO("Q")) D QUE,HOME^%ZIS Q
  1. PR1 ;refresh amis codes
  1.  D ^RMPREXR
  1. EN1 ;pass dates if needed
  1.  S RMPRSEND=$P(XMRG,"*",5)
  1.  S DIC="^RMPR(660,",DR=".01:100",DIQ(0)="EN"
  1.  S RMPRB=0,RMPRCNT=0,RMPRSUB="B1 ",RMPRRECC=0,COUNT=0
  1.  K ^TMP("RMPR",$J)
  1.  F  S RMPRB=$O(^RMPR(660,"B",RMPRB)) Q:(RMPRB>RMPRDT2)!(RMPRB'>0)  D
  1.  .Q:RMPRB<RMPRDT1
  1.  .;date range check complete
  1.  .;pick up mult records with same date
  1.  .S RMPRA=0
  1.  .F  S RMPRA=$O(^RMPR(660,"B",RMPRB,RMPRA)) Q:RMPRA'>0  D
  1.  ..S RMPRRECC=RMPRRECC+1
  1.  ..S DA=RMPRA,DIQ="RMPR"
  1.  ..S DIC="^RMPR(660,",DR=".01:100",DIQ(0)="EN"
  1.  ..D EN^DIQ1
  1.  ..;verify field length
  1.  ..;Brief Description
  1.  ..I $D(RMPR(660,RMPRA,24,"E")) D
  1.  ...I $L(RMPR(660,RMPRA,24,"E"))>60 S RMPR(660,RMPRA,24,"E")=$E(RMPR(660,RMPRA,24,"E"),1,60)
  1.  ..;Deliver To
  1.  ..I $D(RMPR(660,RMPRA,25,"E")) D
  1.  ...I $L(RMPR(660,RMPRA,25,"E"))>30 S RMPR(660,RMPRA,25,"E")=$E(RMPR(660,RMPRA,25,"E"),1,30)
  1.  ..;Remarks
  1.  ..I $D(RMPR(660,RMPRA,16,"E")) D
  1.  ...I $L(RMPR(660,RMPRA,16,"E"))>60 S RMPR(660,RMPRA,16,"E")=$E(RMPR(660,RMPRA,16,"E"),1,60)
  1.  ..D LINECK
  1.  ..;parse array
  1.  ..S RMPRC=0
  1.  ..F  S RMPRC=$O(RMPR(660,RMPRC)) Q:RMPRC'>0  D TMP
  1.  ;clean up before calling mailman
  1.  K DFN,RMPRFLD,RMPRE,RMPRCNT,DFN,RMPRA,RMPRC,DIQ,DIC,DR,DA,RMPRDT1,RMPRDT2
  1.  S XMSUB="B1-F " D MAIL,EXIT
  1.  Q
  1. LINECK ;check the message line limit (5000)
  1.  I RMPRCNT>5000 S XMSUB=RMPRSUB D MAIL K ^TMP("RMPR",$J) S RMPRCNT=0
  1.  Q
  1. TMP ;format for mailman ^TMP(namespace,$J,counter)=record,field,value
  1.  S RMPRFLD=0
  1.  F  S RMPRFLD=$O(RMPR(660,RMPRC,RMPRFLD)) Q:RMPRFLD'>0  D
  1.  .S RMPRCNT=RMPRCNT+1,RMPRE=0,DFN=0
  1.  .S RMPRE=$O(RMPR(660,RMPRC,RMPRFLD,RMPRE)) Q:RMPRE=""
  1.  .;add station number - to ien
  1.  .S IENSITE=$P($$SITE^VASITE,U,3),IENSITE=IENSITE_"-"
  1.  .;strip the ~ for TEXT file
  1.  .I RMPRFLD'=".01" S ^TMP("RMPR",$J,RMPRCNT)="d2~"_IENSITE_RMPRC_"~"_RMPRFLD_"~"_$TR(RMPR(660,RMPRC,RMPRFLD,RMPRE),"~","/")_U
  1.  .I RMPRFLD=".01" S ^TMP("RMPR",$J,RMPRCNT)="d1~"_IENSITE_RMPRC_"~"_RMPRFLD_"~"_$TR(RMPR(660,RMPRC,RMPRFLD,RMPRE),"~","/")_U
  1.  .;get SSN
  1.  .I RMPRFLD=".02" D
  1.  .  .S DFN=$P(^RMPR(660,RMPRC,0),U,2)
  1.  .  .D DEM^VADPT,ADD^VADPT,SVC^VADPT
  1.  .  .S RMPRCNT=RMPRCNT+1,^TMP("RMPR",$J,RMPRCNT)="d2~"_IENSITE_RMPRC_"~644~"_VA("PID")_U
  1.  .  .;DOB int
  1.  .  .I $G(VADM(3)) S RMPRCNT=RMPRCNT+1,^TMP("RMPR",$J,RMPRCNT)="d2~"_IENSITE_RMPRC_"~664.3~"_$P(VADM(3),U,1)_U
  1.  .  .;DOB ext
  1.  .  .I $G(VADM(3)) S RMPRCNT=RMPRCNT+1,^TMP("RMPR",$J,RMPRCNT)="d2~"_IENSITE_RMPRC_"~664.31~"_$P(VADM(3),U,2)_U
  1.  .  .;Sex, int
  1.  .  .I $G(VADM(5))'="" S RMPRCNT=RMPRCNT+1,^TMP("RMPR",$J,RMPRCNT)="d2~"_IENSITE_RMPRC_"~664.5~"_$P(VADM(5),U,1)_U
  1.  .  .;DOD int
  1.  .  .I $G(VADM(6)) S RMPRCNT=RMPRCNT+1,^TMP("RMPR",$J,RMPRCNT)="d2~"_IENSITE_RMPRC_"~664.6~"_$P(VADM(6),U,1)_U
  1.  .  .;DOD ext
  1.  .  .I $G(VADM(6)) S RMPRCNT=RMPRCNT+1,^TMP("RMPR",$J,RMPRCNT)="d2~"_IENSITE_RMPRC_"~664.61~"_$P(VADM(6),U,2)_U
  1.  .  .;patient zip
  1.  .  .I $G(VAPA(6)) S RMPRCNT=RMPRCNT+1,^TMP("RMPR",$J,RMPRCNT)="d2~"_IENSITE_RMPRC_"~664.62~"_VAPA(6)_U
  1.  .  .;patient county name
  1.  .  .I $G(VAPA(7)) S RMPRCNT=RMPRCNT+1,^TMP("RMPR",$J,RMPRCNT)="d2~"_IENSITE_RMPRC_"~664.63~"_$P(VAPA(7),U,2)_U
  1.  .  .;city
  1.  .  .I $G(VAPA(4)) S RMPRCNT=RMPRCNT+1,^TMP("RMPR",$J,RMPRCNT)="d2~"_IENSITE_RMPRC_"~664.66~"_VAPA(4)_U
  1.  .  .;requestor service
  1.  .  .;O INDICATOR
  1.  .  .I $P($G(VASV(11)),U,1)>0 S RMPRCNT=RMPRCNT+1,^TMP("RMPR",$J,RMPRCNT)="d2~"_IENSITE_RMPRC_"~664.80~"_$P(VASV(11),U,1)_U
  1.  .  .I $P($G(VASV(12)),U,1)>0 S RMPRCNT=RMPRCNT+1,^TMP("RMPR",$J,RMPRCNT)="d2~"_IENSITE_RMPRC_"~664.81~"_$P(VASV(12),U,1)_U
  1.  .  .I $P($G(VASV(13)),U,1)>0 S RMPRCNT=RMPRCNT+1,^TMP("RMPR",$J,RMPRCNT)="d2~"_IENSITE_RMPRC_"~664.82~"_$P(VASV(13),U,1)_U
  1.  .  .K VASV
  1.  .  .;
  1.  .  .;ICN
  1.  .  .S ICN=$$GETICN^MPIF001(DFN)
  1.  .  .I +ICN'=-1 S RMPRCNT=RMPRCNT+1,^TMP("RMPR",$J,RMPRCNT)="d2~"_IENSITE_RMPRC_"~664.64~"_ICN_U
  1.  .  .;CMOR
  1.  .  .S CMOR=$$GETVCCI^MPIF001(DFN)
  1.  .  .I +CMOR'=-1 S RMPRCNT=RMPRCNT+1,^TMP("RMPR",$J,RMPRCNT)="d2~"_IENSITE_RMPRC_"~664.65~"_CMOR_U
  1.  .;vendor info
  1.  .I RMPRFLD=7 D
  1.  ..;N DIC,DR,DA
  1.  ..S DIC="^PRC(440,"
  1.  ..S DA=$P(^RMPR(660,RMPRC,0),U,9)
  1.  ..Q:+DA'>0
  1.  ..S DR="38;39;18.3;8.3",DIQ="TAXID(",DIQ(0)="E"
  1.  ..D EN^DIQ1
  1.  ..S RMPRCNT=RMPRCNT+1,^TMP("RMPR",$J,RMPRCNT)="d2~"_IENSITE_RMPRC_"~664.738~"_TAXID(440,DA,38,"E")_U
  1.  ..S RMPRCNT=RMPRCNT+1,^TMP("RMPR",$J,RMPRCNT)="d2~"_IENSITE_RMPRC_"~664.739~"_TAXID(440,DA,39,"E")_U
  1.  ..S RMPRCNT=RMPRCNT+1,^TMP("RMPR",$J,RMPRCNT)="d2~"_IENSITE_RMPRC_"~664.7183~"_TAXID(440,DA,18.3,"E")_U
  1.  ..S RMPRCNT=RMPRCNT+1,^TMP("RMPR",$J,RMPRCNT)="d2~"_IENSITE_RMPRC_"~664.783~"_TAXID(440,DA,8.3,"E")_U
  1.  ;
  1.  K VA("PID"),RMPR,VADM,VAPA,ICN,CMOR,TAXID
  1.  Q
  1. MAIL ;pack it up and send it off
  1.  S XMTEXT="^TMP(""RMPR"",$J,"
  1. MAILS ;entry point to send summary msg
  1.  S XMDUZ=.5
  1.  S XMY("G.PROSTHETICS@PSAS.DOMAIN.EXT")=""
  1.  S XMSUB=XMSUB_" Extract From "_$P($$SITE^VASITE,U,2)
  1.  D ^XMD
  1.  ;keep track of messages sent
  1.  S RMPRM(XMZ)=XMZ_U
  1.  S COUNT=COUNT+1
  1.  Q
  1. QUE ;TaskMan Queue
  1.  S ZTIO=ION_";"_IOST K IO("Q")
  1.  S ZTRTN="PR1^RMPREXT"
  1.  S ZTDESC="Prosthetics National Data Extract"
  1.  K ZTSK D ^%ZTLOAD I $G(ZTSK) U IO(0) W !,"<REQUEST QUEUED>"
  1.  Q
  1. EXIT ;exit point
  1.  ;send summary msg
  1.  S RMPRM(1)="Message Numbers Created Below, Site^Total Record #:"_U_$P($$SITE^VASITE,U,3)_U_$P($$SITE^VASITE,U,2)_U_RMPRRECC_U
  1.  S XMSUB=RMPRSUB_"Summary ",XMTEXT="RMPRM("
  1.  D MAILS
  1.  K ^TMP("RMPR",$J),XMTEXT,XMDUZ,XMY,XMSUB,RMPRM
  1.  ;send message to PCM group to let them know Austin should have all mail.
  1.  S RMPRMM(1)="Site^Total Record # ^ Total Message #:"_U_$P($$SITE^VASITE,U,3)_U_$P($$SITE^VASITE,U,2)_U_RMPRRECC_U_COUNT
  1.  S XMTEXT="RMPRMM("
  1.  S XMSUB="NPPD Summary Update From "_$P($$SITE^VASITE,U,2)
  1.  S XMY("VHACOPSASPIPReport@domain.ext")=""
  1.  S XMDUZ=.5
  1.  D ^XMD
  1.  K XMTEXT,XMDUZ,XMY,XMSUB,RMPRRECC,COUNT,RMPRMM,RMPRSEND,IENSITE
  1.  Q
  1.  ;
  1. PR2 ;Bundle open obligations on 2319
  1.  S XMDUZ=.5
  1.  S XMY("G.RMPR SERVER")=""
  1.  S XMSUB="Prosthetics Data Extract Open Obligations"
  1.  S RMPRMSG(1)="The National Data Server has been activated today by Prosthetics HQ."
  1.  S RMPRMSG(2)="Data has been collected for all open obligations."
  1.  S RMPRMSG(3)=""
  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
  1.  K ^TMP("RMPR",$J)
  1.  S RMPRB=0,RMPRCNT=0,RMPRSUB="B2 "
  1.  S DIC="^RMPR(660,",DR=".01:83",DIQ(0)="EN"
  1.  F  S RMPRB=$O(^RMPR(660,RMPRB)) Q:RMPRB'>0  D
  1.  .I $G(^RMPR(660,RMPRB,0))="" Q
  1.  .S RMPRA=^RMPR(660,RMPRB,0)
  1.  .;delivery date not null
  1.  .Q:$P(RMPRA,U,12)'=""
  1.  .S RMPRX=$P($G(^RMPR(660,RMPRB,1)),U,1)
  1.  .;has an IFCAP transaction number
  1.  .Q:$P(RMPRX,U,1)=""
  1.  .;refresh amis data
  1.  .D
  1.  ..N ITM,TYPE,NEW,REPAIR
  1.  ..S ITM=$P(RMPRA,U,6),TYPE=$P(RMPRA,U,4)
  1.  ..Q:ITM=""
  1.  ..Q:TYPE=""
  1.  ..S NEW=$P($G(^RMPR(661,ITM,0)),U,3)
  1.  ..S REPAIR=$P($G(^RMPR(661,ITM,0)),U,4)
  1.  ..I TYPE="X" S $P(^RMPR(660,RMPRB,"AM"),U,5)=REPAIR,$P(^("AM"),U,9)="" Q
  1.  ..S $P(^RMPR(660,RMPRB,"AM"),U,9)=NEW,$P(^("AM"),U,5)=""
  1.  .;get data
  1.  .S DA=RMPRB,DIQ="RMPR" D EN^DIQ1,LINECK
  1.  .S RMPRC=0
  1.  .F  S RMPRC=$O(RMPR(660,RMPRC)) Q:RMPRC'>0  D LINECK,TMP
  1.  K DFN,RMPRFLD,RMPRC,RMPRA,RMPRB,RMPRX,RMPRCNT,RMPRE,DR,DIC,DIQ,DA
  1.  S XMSUB="B2-F " D MAIL,EXIT
  1.  D ^%ZISC
  1.  Q
  1.  ;END