EMERGENCY Released RMPR*3*109 SEQ #83 Extracted from mail message **KIDS**:RMPR*3.0*109^ **INSTALL NAME** RMPR*3.0*109 "BLD",5659,0) RMPR*3.0*109^PROSTHETICS^0^3050531^y "BLD",5659,1,0) ^^1^1^3050524^^ "BLD",5659,1,1,0) Please see FORUM for full patch description. "BLD",5659,4,0) ^9.64PA^^ "BLD",5659,"KRN",0) ^9.67PA^8989.52^19 "BLD",5659,"KRN",.4,0) .4 "BLD",5659,"KRN",.401,0) .401 "BLD",5659,"KRN",.402,0) .402 "BLD",5659,"KRN",.403,0) .403 "BLD",5659,"KRN",.5,0) .5 "BLD",5659,"KRN",.84,0) .84 "BLD",5659,"KRN",3.6,0) 3.6 "BLD",5659,"KRN",3.8,0) 3.8 "BLD",5659,"KRN",9.2,0) 9.2 "BLD",5659,"KRN",9.8,0) 9.8 "BLD",5659,"KRN",9.8,"NM",0) ^9.68A^1^1 "BLD",5659,"KRN",9.8,"NM",1,0) RMPREXT^^0^B47650564 "BLD",5659,"KRN",9.8,"NM","B","RMPREXT",1) "BLD",5659,"KRN",19,0) 19 "BLD",5659,"KRN",19.1,0) 19.1 "BLD",5659,"KRN",101,0) 101 "BLD",5659,"KRN",409.61,0) 409.61 "BLD",5659,"KRN",771,0) 771 "BLD",5659,"KRN",870,0) 870 "BLD",5659,"KRN",8989.51,0) 8989.51 "BLD",5659,"KRN",8989.52,0) 8989.52 "BLD",5659,"KRN",8994,0) 8994 "BLD",5659,"KRN","B",.4,.4) "BLD",5659,"KRN","B",.401,.401) "BLD",5659,"KRN","B",.402,.402) "BLD",5659,"KRN","B",.403,.403) "BLD",5659,"KRN","B",.5,.5) "BLD",5659,"KRN","B",.84,.84) "BLD",5659,"KRN","B",3.6,3.6) "BLD",5659,"KRN","B",3.8,3.8) "BLD",5659,"KRN","B",9.2,9.2) "BLD",5659,"KRN","B",9.8,9.8) "BLD",5659,"KRN","B",19,19) "BLD",5659,"KRN","B",19.1,19.1) "BLD",5659,"KRN","B",101,101) "BLD",5659,"KRN","B",409.61,409.61) "BLD",5659,"KRN","B",771,771) "BLD",5659,"KRN","B",870,870) "BLD",5659,"KRN","B",8989.51,8989.51) "BLD",5659,"KRN","B",8989.52,8989.52) "BLD",5659,"KRN","B",8994,8994) "BLD",5659,"QUES",0) ^9.62^^ "BLD",5659,"REQB",0) ^9.611^1^1 "BLD",5659,"REQB",1,0) RMPR*3.0*106^2 "BLD",5659,"REQB","B","RMPR*3.0*106",1) "MBREQ") 0 "PKG",101,-1) 1^1 "PKG",101,0) PROSTHETICS^RMPR^PROSTHETICS VERSION 3.0 ALPHA "PKG",101,20,0) ^9.402P^2^1 "PKG",101,20,2,0) 2^^ "PKG",101,20,2,1) "PKG",101,20,"B",2,2) "PKG",101,22,0) ^9.49I^1^1 "PKG",101,22,1,0) 3.0^2960209^2960214 "PKG",101,22,1,"PAH",1,0) 109^3050531 "PKG",101,22,1,"PAH",1,1,0) ^^1^1^3050531 "PKG",101,22,1,"PAH",1,1,1,0) Please see FORUM for full patch description. "QUES","XPF1",0) Y "QUES","XPF1","??") ^D REP^XPDH "QUES","XPF1","A") Shall I write over your |FLAG| File "QUES","XPF1","B") YES "QUES","XPF1","M") D XPF1^XPDIQ "QUES","XPF2",0) Y "QUES","XPF2","??") ^D DTA^XPDH "QUES","XPF2","A") Want my data |FLAG| yours "QUES","XPF2","B") YES "QUES","XPF2","M") D XPF2^XPDIQ "QUES","XPI1",0) YO "QUES","XPI1","??") ^D INHIBIT^XPDH "QUES","XPI1","A") Want KIDS to INHIBIT LOGONs during the install "QUES","XPI1","B") YES "QUES","XPI1","M") D XPI1^XPDIQ "QUES","XPM1",0) PO^VA(200,:EM "QUES","XPM1","??") ^D MG^XPDH "QUES","XPM1","A") Enter the Coordinator for Mail Group '|FLAG|' "QUES","XPM1","B") "QUES","XPM1","M") D XPM1^XPDIQ "QUES","XPO1",0) Y "QUES","XPO1","??") ^D MENU^XPDH "QUES","XPO1","A") Want KIDS to Rebuild Menu Trees Upon Completion of Install "QUES","XPO1","B") YES "QUES","XPO1","M") D XPO1^XPDIQ "QUES","XPZ1",0) Y "QUES","XPZ1","??") ^D OPT^XPDH "QUES","XPZ1","A") Want to DISABLE Scheduled Options, Menu Options, and Protocols "QUES","XPZ1","B") YES "QUES","XPZ1","M") D XPZ1^XPDIQ "QUES","XPZ2",0) Y "QUES","XPZ2","??") ^D RTN^XPDH "QUES","XPZ2","A") Want to MOVE routines to other CPUs "QUES","XPZ2","B") NO "QUES","XPZ2","M") D XPZ2^XPDIQ "RTN") 1 "RTN","RMPREXT") 0^1^B47650564 "RTN","RMPREXT",1,0) RMPREXT ;PHX/HNC-DATA EXTRACT FOR Nppd ;4/20/1995 "RTN","RMPREXT",2,0) ;;3.0;PROSTHETICS;**12,18,24,64,59,103,106,109**;Feb 09, 1996 "RTN","RMPREXT",3,0) ;Per VHA Directive 10-93-142, this routine should not be modified. "RTN","RMPREXT",4,0) ; "RTN","RMPREXT",5,0) ;DBIA #4599, Vendor file read 38,39,18.3,8.3 "RTN","RMPREXT",6,0) ; "RTN","RMPREXT",7,0) ;patch 109 - move to austin "RTN","RMPREXT",8,0) ; change line count to 1800; not over 150k "RTN","RMPREXT",9,0) ; add count of records to summary message "RTN","RMPREXT",10,0) ; summary message to PCM "RTN","RMPREXT",11,0) ; add site- to ien, use ~ as data delimiter "RTN","RMPREXT",12,0) ; add ^ as EOL for Austin "RTN","RMPREXT",13,0) ; add data1 and data2 flags for EXE parsing tool "RTN","RMPREXT",14,0) ; "RTN","RMPREXT",15,0) EN ;extract from 660 "RTN","RMPREXT",16,0) N %ZIS,ZTIO,ZTRTN,ZTSK,ZTDESC "RTN","RMPREXT",17,0) S %ZIS="Q" D ^%ZIS Q:POP "RTN","RMPREXT",18,0) I $D(IO("Q")) D QUE,HOME^%ZIS Q "RTN","RMPREXT",19,0) PR1 ;refresh amis codes "RTN","RMPREXT",20,0) D ^RMPREXR "RTN","RMPREXT",21,0) EN1 ;pass dates if needed "RTN","RMPREXT",22,0) S RMPRSEND=$P(XMRG,"*",5) "RTN","RMPREXT",23,0) S DIC="^RMPR(660,",DR=".01:83",DIQ(0)="EN" "RTN","RMPREXT",24,0) S RMPRB=0,RMPRCNT=0,RMPRSUB="B1 ",RMPRRECC=0,COUNT=0 "RTN","RMPREXT",25,0) K ^TMP("RMPR",$J) "RTN","RMPREXT",26,0) F S RMPRB=$O(^RMPR(660,"B",RMPRB)) Q:(RMPRB>RMPRDT2)!(RMPRB'>0) D "RTN","RMPREXT",27,0) .Q:RMPRB0 D "RTN","RMPREXT",32,0) ..S RMPRRECC=RMPRRECC+1 "RTN","RMPREXT",33,0) ..S DA=RMPRA,DIQ="RMPR" "RTN","RMPREXT",34,0) ..S DIC="^RMPR(660,",DR=".01:83",DIQ(0)="EN" "RTN","RMPREXT",35,0) ..D EN^DIQ1,LINECK "RTN","RMPREXT",36,0) ..;parse array in format needed to send/receive "RTN","RMPREXT",37,0) ..S RMPRC=0 "RTN","RMPREXT",38,0) ..F S RMPRC=$O(RMPR(660,RMPRC)) Q:RMPRC'>0 D TMP "RTN","RMPREXT",39,0) ;clean up before calling mailman "RTN","RMPREXT",40,0) K DFN,RMPRFLD,RMPRE,RMPRCNT,DFN,RMPRA,RMPRC,DIQ,DIC,DR,DA,RMPRDT1,RMPRDT2 "RTN","RMPREXT",41,0) S XMSUB="B1-F " D MAIL,EXIT "RTN","RMPREXT",42,0) Q "RTN","RMPREXT",43,0) LINECK ;check the message line limit (5000);move to austin change to 1800 "RTN","RMPREXT",44,0) I RMPRCNT>1800 S XMSUB=RMPRSUB D MAIL K ^TMP("RMPR",$J) S RMPRCNT=0 "RTN","RMPREXT",45,0) Q "RTN","RMPREXT",46,0) TMP ;format for mailman ^TMP(namespace,$J,counter)=record,field,value "RTN","RMPREXT",47,0) S RMPRFLD=0 "RTN","RMPREXT",48,0) F S RMPRFLD=$O(RMPR(660,RMPRC,RMPRFLD)) Q:RMPRFLD'>0 D "RTN","RMPREXT",49,0) .S RMPRCNT=RMPRCNT+1,RMPRE=0,DFN=0 "RTN","RMPREXT",50,0) .S RMPRE=$O(RMPR(660,RMPRC,RMPRFLD,RMPRE)) Q:RMPRE="" "RTN","RMPREXT",51,0) .;add station number - to ien "RTN","RMPREXT",52,0) .S IENSITE=$P($$SITE^VASITE,U,3),IENSITE=IENSITE_"-" "RTN","RMPREXT",53,0) .;strip the ~ for TEXT file "RTN","RMPREXT",54,0) .I RMPRFLD'=".01" S ^TMP("RMPR",$J,RMPRCNT)="data2~"_IENSITE_RMPRC_"~"_RMPRFLD_"~"_$TR(RMPR(660,RMPRC,RMPRFLD,RMPRE),"~","/")_U "RTN","RMPREXT",55,0) .I RMPRFLD=".01" S ^TMP("RMPR",$J,RMPRCNT)="data1~"_IENSITE_RMPRC_"~"_RMPRFLD_"~"_$TR(RMPR(660,RMPRC,RMPRFLD,RMPRE),"~","/")_U "RTN","RMPREXT",56,0) .;get SSN "RTN","RMPREXT",57,0) .I RMPRFLD=".02" D "RTN","RMPREXT",58,0) . .S DFN=$P(^RMPR(660,RMPRC,0),U,2) "RTN","RMPREXT",59,0) . .D DEM^VADPT,ADD^VADPT "RTN","RMPREXT",60,0) . .S RMPRCNT=RMPRCNT+1,^TMP("RMPR",$J,RMPRCNT)="data2~"_IENSITE_RMPRC_"~644~"_VA("PID")_U "RTN","RMPREXT",61,0) . .;DOB int "RTN","RMPREXT",62,0) . .I $G(VADM(3)) S RMPRCNT=RMPRCNT+1,^TMP("RMPR",$J,RMPRCNT)="data2~"_IENSITE_RMPRC_"~664.3~"_$P(VADM(3),U,1)_U "RTN","RMPREXT",63,0) . .;DOB ext "RTN","RMPREXT",64,0) . .I $G(VADM(3)) S RMPRCNT=RMPRCNT+1,^TMP("RMPR",$J,RMPRCNT)="data2~"_IENSITE_RMPRC_"~664.31~"_$P(VADM(3),U,2)_U "RTN","RMPREXT",65,0) . .;Sex, int "RTN","RMPREXT",66,0) . .I $G(VADM(5))'="" S RMPRCNT=RMPRCNT+1,^TMP("RMPR",$J,RMPRCNT)="data2~"_IENSITE_RMPRC_"~664.5~"_$P(VADM(5),U,1)_U "RTN","RMPREXT",67,0) . .;DOD int "RTN","RMPREXT",68,0) . .I $G(VADM(6)) S RMPRCNT=RMPRCNT+1,^TMP("RMPR",$J,RMPRCNT)="data2~"_IENSITE_RMPRC_"~664.6~"_$P(VADM(6),U,1)_U "RTN","RMPREXT",69,0) . .;DOD ext "RTN","RMPREXT",70,0) . .I $G(VADM(6)) S RMPRCNT=RMPRCNT+1,^TMP("RMPR",$J,RMPRCNT)="data2~"_IENSITE_RMPRC_"~664.61~"_$P(VADM(6),U,2)_U "RTN","RMPREXT",71,0) . .;patient zip "RTN","RMPREXT",72,0) . .I $G(VAPA(6)) S RMPRCNT=RMPRCNT+1,^TMP("RMPR",$J,RMPRCNT)="data2~"_IENSITE_RMPRC_"~664.62~"_VAPA(6)_U "RTN","RMPREXT",73,0) . .;patient county name "RTN","RMPREXT",74,0) . .I $G(VAPA(7)) S RMPRCNT=RMPRCNT+1,^TMP("RMPR",$J,RMPRCNT)="data2~"_IENSITE_RMPRC_"~664.63~"_$P(VAPA(7),U,2)_U "RTN","RMPREXT",75,0) . .;city "RTN","RMPREXT",76,0) . .I $G(VAPA(4)) S RMPRCNT=RMPRCNT+1,^TMP("RMPR",$J,RMPRCNT)="data2~"_IENSITE_RMPRC_"~664.66~"_VAPA(4)_U "RTN","RMPREXT",77,0) . .;requestor service "RTN","RMPREXT",78,0) . .; "RTN","RMPREXT",79,0) . .;ICN "RTN","RMPREXT",80,0) . .S ICN=$$GETICN^MPIF001(DFN) "RTN","RMPREXT",81,0) . .I +ICN'=-1 S RMPRCNT=RMPRCNT+1,^TMP("RMPR",$J,RMPRCNT)="data2~"_IENSITE_RMPRC_"~664.64~"_ICN_U "RTN","RMPREXT",82,0) . .;CMOR "RTN","RMPREXT",83,0) . .S CMOR=$$GETVCCI^MPIF001(DFN) "RTN","RMPREXT",84,0) . .I +CMOR'=-1 S RMPRCNT=RMPRCNT+1,^TMP("RMPR",$J,RMPRCNT)="data2~"_IENSITE_RMPRC_"~664.65~"_CMOR_U "RTN","RMPREXT",85,0) .;vendor info "RTN","RMPREXT",86,0) .I RMPRFLD=7 D "RTN","RMPREXT",87,0) ..;N DIC,DR,DA "RTN","RMPREXT",88,0) ..S DIC="^PRC(440," "RTN","RMPREXT",89,0) ..S DA=$P(^RMPR(660,RMPRC,0),U,9) "RTN","RMPREXT",90,0) ..Q:+DA'>0 "RTN","RMPREXT",91,0) ..S DR="38;39;18.3;8.3",DIQ="TAXID(",DIQ(0)="E" "RTN","RMPREXT",92,0) ..D EN^DIQ1 "RTN","RMPREXT",93,0) ..S RMPRCNT=RMPRCNT+1,^TMP("RMPR",$J,RMPRCNT)="data2~"_IENSITE_RMPRC_"~664.738~"_TAXID(440,DA,38,"E")_U "RTN","RMPREXT",94,0) ..S RMPRCNT=RMPRCNT+1,^TMP("RMPR",$J,RMPRCNT)="data2~"_IENSITE_RMPRC_"~664.739~"_TAXID(440,DA,39,"E")_U "RTN","RMPREXT",95,0) ..S RMPRCNT=RMPRCNT+1,^TMP("RMPR",$J,RMPRCNT)="data2~"_IENSITE_RMPRC_"~664.7183~"_TAXID(440,DA,18.3,"E")_U "RTN","RMPREXT",96,0) ..S RMPRCNT=RMPRCNT+1,^TMP("RMPR",$J,RMPRCNT)="data2~"_IENSITE_RMPRC_"~664.783~"_TAXID(440,DA,8.3,"E")_U "RTN","RMPREXT",97,0) ; "RTN","RMPREXT",98,0) K VA("PID"),RMPR,VADM,VAPA,ICN,CMOR,TAXID "RTN","RMPREXT",99,0) Q "RTN","RMPREXT",100,0) MAIL ;pack it up and send it off "RTN","RMPREXT",101,0) S XMTEXT="^TMP(""RMPR"",$J," "RTN","RMPREXT",102,0) MAILS ;entry point to send summary msg "RTN","RMPREXT",103,0) S XMDUZ=.5 "RTN","RMPREXT",104,0) I RMPRSEND'="" S XMY("G.PROSTHETICS@PSAS.MED.VA.GOV")="" "RTN","RMPREXT",105,0) S XMY("XXX@Q-PRO.VA.GOV")="" "RTN","RMPREXT",106,0) S XMSUB=XMSUB_" Extract From "_$P($$SITE^VASITE,U,2) "RTN","RMPREXT",107,0) D ^XMD "RTN","RMPREXT",108,0) ;keep track of messages sent "RTN","RMPREXT",109,0) S RMPRM(XMZ)=XMZ_U "RTN","RMPREXT",110,0) S COUNT=COUNT+1 "RTN","RMPREXT",111,0) Q "RTN","RMPREXT",112,0) QUE ;TaskMan Queue "RTN","RMPREXT",113,0) S ZTIO=ION_";"_IOST K IO("Q") "RTN","RMPREXT",114,0) S ZTRTN="PR1^RMPREXT" "RTN","RMPREXT",115,0) S ZTDESC="Prosthetics National Data Extract" "RTN","RMPREXT",116,0) K ZTSK D ^%ZTLOAD I $G(ZTSK) U IO(0) W !,"" "RTN","RMPREXT",117,0) Q "RTN","RMPREXT",118,0) EXIT ;exit point "RTN","RMPREXT",119,0) ;send summary msg "RTN","RMPREXT",120,0) S RMPRM(1)="Message Numbers Created Below, Total Record #:"_RMPRRECC_U "RTN","RMPREXT",121,0) S XMSUB=RMPRSUB_"Summary ",XMTEXT="RMPRM(" "RTN","RMPREXT",122,0) D MAILS "RTN","RMPREXT",123,0) K ^TMP("RMPR",$J),XMTEXT,XMDUZ,XMY,XMSUB,RMPRM "RTN","RMPREXT",124,0) ;send message to PCM group to let them know Austin should have all mail. "RTN","RMPREXT",125,0) S RMPRMM(1)="Total Record # ^ Total Message #:"_RMPRRECC_U_COUNT "RTN","RMPREXT",126,0) S XMTEXT="RMPRMM(" "RTN","RMPREXT",127,0) S XMSUB="NPPD Summary Update From "_$P($$SITE^VASITE,U,2) "RTN","RMPREXT",128,0) S XMY("VHACOPSASPIPReport@med.va.gov")="" "RTN","RMPREXT",129,0) S XMDUZ=.5 "RTN","RMPREXT",130,0) D ^XMD "RTN","RMPREXT",131,0) K XMTEXT,XMDUZ,XMY,XMSUB,RMPRRECC,COUNT,RMPRMM,RMPRSEND,IENSITE "RTN","RMPREXT",132,0) Q "RTN","RMPREXT",133,0) ; "RTN","RMPREXT",134,0) PR2 ;Bundle open obligations on 2319 "RTN","RMPREXT",135,0) S XMDUZ=.5 "RTN","RMPREXT",136,0) S XMY("G.RMPR SERVER")="" "RTN","RMPREXT",137,0) S XMSUB="Prosthetics Data Extract Open Obligations" "RTN","RMPREXT",138,0) S RMPRMSG(1)="The National Data Server has been activated today by Prosthetics HQ." "RTN","RMPREXT",139,0) S RMPRMSG(2)="Data has been collected for all open obligations." "RTN","RMPREXT",140,0) S RMPRMSG(3)="" "RTN","RMPREXT",141,0) S RMPRMSG(4)="This was activated by "_$P(XMFROM,"@",1) "RTN","RMPREXT",142,0) S RMPRMSG(5)="" "RTN","RMPREXT",143,0) S XMTEXT="RMPRMSG(" "RTN","RMPREXT",144,0) D ^XMD "RTN","RMPREXT",145,0) K RMPRMSG "RTN","RMPREXT",146,0) K ^TMP("RMPR",$J) "RTN","RMPREXT",147,0) S RMPRB=0,RMPRCNT=0,RMPRSUB="B2 " "RTN","RMPREXT",148,0) S DIC="^RMPR(660,",DR=".01:83",DIQ(0)="EN" "RTN","RMPREXT",149,0) F S RMPRB=$O(^RMPR(660,RMPRB)) Q:RMPRB'>0 D "RTN","RMPREXT",150,0) .I $G(^RMPR(660,RMPRB,0))="" Q "RTN","RMPREXT",151,0) .S RMPRA=^RMPR(660,RMPRB,0) "RTN","RMPREXT",152,0) .;delivery date not null "RTN","RMPREXT",153,0) .Q:$P(RMPRA,U,12)'="" "RTN","RMPREXT",154,0) .S RMPRX=$P($G(^RMPR(660,RMPRB,1)),U,1) "RTN","RMPREXT",155,0) .;has an IFCAP transaction number "RTN","RMPREXT",156,0) .Q:$P(RMPRX,U,1)="" "RTN","RMPREXT",157,0) .;refresh amis data "RTN","RMPREXT",158,0) .D "RTN","RMPREXT",159,0) ..N ITM,TYPE,NEW,REPAIR "RTN","RMPREXT",160,0) ..S ITM=$P(RMPRA,U,6),TYPE=$P(RMPRA,U,4) "RTN","RMPREXT",161,0) ..Q:ITM="" "RTN","RMPREXT",162,0) ..Q:TYPE="" "RTN","RMPREXT",163,0) ..S NEW=$P($G(^RMPR(661,ITM,0)),U,3) "RTN","RMPREXT",164,0) ..S REPAIR=$P($G(^RMPR(661,ITM,0)),U,4) "RTN","RMPREXT",165,0) ..I TYPE="X" S $P(^RMPR(660,RMPRB,"AM"),U,5)=REPAIR,$P(^("AM"),U,9)="" Q "RTN","RMPREXT",166,0) ..S $P(^RMPR(660,RMPRB,"AM"),U,9)=NEW,$P(^("AM"),U,5)="" "RTN","RMPREXT",167,0) .;get data "RTN","RMPREXT",168,0) .S DA=RMPRB,DIQ="RMPR" D EN^DIQ1,LINECK "RTN","RMPREXT",169,0) .S RMPRC=0 "RTN","RMPREXT",170,0) .F S RMPRC=$O(RMPR(660,RMPRC)) Q:RMPRC'>0 D LINECK,TMP "RTN","RMPREXT",171,0) K DFN,RMPRFLD,RMPRC,RMPRA,RMPRB,RMPRX,RMPRCNT,RMPRE,DR,DIC,DIQ,DA "RTN","RMPREXT",172,0) S XMSUB="B2-F " D MAIL,EXIT "RTN","RMPREXT",173,0) D ^%ZISC "RTN","RMPREXT",174,0) Q "RTN","RMPREXT",175,0) ;END "VER") 8.0^22 **END** **END**