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