Released RMPR*3*114 SEQ #90 Extracted from mail message **KIDS**:RMPR*3.0*114^ **INSTALL NAME** RMPR*3.0*114 "BLD",5915,0) RMPR*3.0*114^PROSTHETICS^0^3050906^y "BLD",5915,1,0) ^^1^1^3050823^ "BLD",5915,1,1,0) SUBSCRIPT ERROR/PCE ERROR MESSAGE "BLD",5915,4,0) ^9.64PA^^ "BLD",5915,"KRN",0) ^9.67PA^8989.52^19 "BLD",5915,"KRN",.4,0) .4 "BLD",5915,"KRN",.401,0) .401 "BLD",5915,"KRN",.402,0) .402 "BLD",5915,"KRN",.403,0) .403 "BLD",5915,"KRN",.5,0) .5 "BLD",5915,"KRN",.84,0) .84 "BLD",5915,"KRN",3.6,0) 3.6 "BLD",5915,"KRN",3.8,0) 3.8 "BLD",5915,"KRN",9.2,0) 9.2 "BLD",5915,"KRN",9.8,0) 9.8 "BLD",5915,"KRN",9.8,"NM",0) ^9.68A^4^4 "BLD",5915,"KRN",9.8,"NM",1,0) RMPRPCEA^^0^B50015987 "BLD",5915,"KRN",9.8,"NM",2,0) RMPRPCEB^^0^B20818586 "BLD",5915,"KRN",9.8,"NM",3,0) RMPR4E21^^0^B59934185 "BLD",5915,"KRN",9.8,"NM",4,0) RMPR4E23^^0^B3734591 "BLD",5915,"KRN",9.8,"NM","B","RMPR4E21",3) "BLD",5915,"KRN",9.8,"NM","B","RMPR4E23",4) "BLD",5915,"KRN",9.8,"NM","B","RMPRPCEA",1) "BLD",5915,"KRN",9.8,"NM","B","RMPRPCEB",2) "BLD",5915,"KRN",19,0) 19 "BLD",5915,"KRN",19.1,0) 19.1 "BLD",5915,"KRN",101,0) 101 "BLD",5915,"KRN",409.61,0) 409.61 "BLD",5915,"KRN",771,0) 771 "BLD",5915,"KRN",870,0) 870 "BLD",5915,"KRN",8989.51,0) 8989.51 "BLD",5915,"KRN",8989.52,0) 8989.52 "BLD",5915,"KRN",8994,0) 8994 "BLD",5915,"KRN","B",.4,.4) "BLD",5915,"KRN","B",.401,.401) "BLD",5915,"KRN","B",.402,.402) "BLD",5915,"KRN","B",.403,.403) "BLD",5915,"KRN","B",.5,.5) "BLD",5915,"KRN","B",.84,.84) "BLD",5915,"KRN","B",3.6,3.6) "BLD",5915,"KRN","B",3.8,3.8) "BLD",5915,"KRN","B",9.2,9.2) "BLD",5915,"KRN","B",9.8,9.8) "BLD",5915,"KRN","B",19,19) "BLD",5915,"KRN","B",19.1,19.1) "BLD",5915,"KRN","B",101,101) "BLD",5915,"KRN","B",409.61,409.61) "BLD",5915,"KRN","B",771,771) "BLD",5915,"KRN","B",870,870) "BLD",5915,"KRN","B",8989.51,8989.51) "BLD",5915,"KRN","B",8989.52,8989.52) "BLD",5915,"KRN","B",8994,8994) "BLD",5915,"QUES",0) ^9.62^^ "BLD",5915,"REQB",0) ^9.611^1^1 "BLD",5915,"REQB",1,0) RMPR*3.0*78^2 "BLD",5915,"REQB","B","RMPR*3.0*78",1) "MBREQ") 0 "PKG",280,-1) 1^1 "PKG",280,0) PROSTHETICS^RMPR^PROSTHETICS VERSION 3.0 ALPHA "PKG",280,20,0) ^9.402P^1^1 "PKG",280,20,1,0) 2^^ "PKG",280,20,1,1) "PKG",280,20,"B",2,1) "PKG",280,22,0) ^9.49I^1^1 "PKG",280,22,1,0) 3.0^2960209^2970624 "PKG",280,22,1,"PAH",1,0) 114^3050906 "PKG",280,22,1,"PAH",1,1,0) ^^1^1^3050906 "PKG",280,22,1,"PAH",1,1,1,0) SUBSCRIPT ERROR/PCE ERROR MESSAGE "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") 4 "RTN","RMPR4E21") 0^3^B59934185 "RTN","RMPR4E21",1,0) RMPR4E21 ;PHX/HNC - CLOSE OUT PURCHASE CARD TRANSACTION ;3/1/1996 "RTN","RMPR4E21",2,0) ;;3.0;PROSTHETICS;**3,12,26,28,30,34,41,45,62,111,78,114**;Feb 09, 1996 "RTN","RMPR4E21",3,0) ;TH Patch #78 - 08/04/03 - Add shipment date. Call routine ^RMPR4E23 "RTN","RMPR4E21",4,0) ;RVD patch #62 - PCE processing and link to suspense "RTN","RMPR4E21",5,0) ; "RTN","RMPR4E21",6,0) ;I '$D(^PRC(440.5,"H",DUZ)) W !!,"You are not an authorized Purchase Card User, CONTACT FISCAL!" Q "RTN","RMPR4E21",7,0) START I '$D(RMPR) D DIV4^RMPRSIT Q:$D(X) "RTN","RMPR4E21",8,0) CL K ^TMP($J,"RMPRPCE") "RTN","RMPR4E21",9,0) K DIC S DIC="664",DIC(0)="AEQM",DIC("W")="D EN2^RMPR4D1",DIC("A")="Select PATIENT: " "RTN","RMPR4E21",10,0) S DIC("S")="I $D(^(4)) I ('$P(^(0),U,8)&'$P(^(0),U,5)),($P(^(0),U,14)=RMPR(""STA""))" "RTN","RMPR4E21",11,0) W !!,"You may also make a selection by Purchase Card Transaction" "RTN","RMPR4E21",12,0) W !,"(Example, PO number), or Bank Authorization Number (6 digit number).",! "RTN","RMPR4E21",13,0) D ^DIC S (DA,RMPRA)=+Y I Y=-1 G EXIT "RTN","RMPR4E21",14,0) K DIC G:$P(^RMPR(664,RMPRA,0),U,8) M4 G:$P(^(0),U,5) M6 "RTN","RMPR4E21",15,0) L +^RMPR(664,RMPRA,0):1 I $T=0 W !,?5,$C(7),"Someone else is Editing this entry!" G EXIT "RTN","RMPR4E21",16,0) ;get amis grouper number RGRP1 "RTN","RMPR4E21",17,0) S RGRP=0,RGRP1="" "RTN","RMPR4E21",18,0) S RGRP=$O(^RMPR(664,RMPRA,1,RGRP)) G:'RGRP BRK S RGRPP=$P($G(^RMPR(664,RMPRA,1,RGRP,0)),U,13) I 'RGRPP W !!,$C(7),"ERROR** This transaction was not posted to 2319, please contact your IRM..",!! S DIR(0)="E" D ^DIR G EXIT "RTN","RMPR4E21",19,0) S RGRP1=$P($G(^RMPR(660,RGRPP,"AMS")),U,1) "RTN","RMPR4E21",20,0) S (RMPRDFN,DFN)=$P(^RMPR(664,RMPRA,0),U,2),RMPRWO=$P(^(0),U,15),RMPRDA=$P(^(0),U,17) "RTN","RMPR4E21",21,0) D DEM^VADPT S RMPRSSNE=VA("PID"),RMPRSSN=+VADM(2),RMPRNAM=VADM(1) K VADM "RTN","RMPR4E21",22,0) ;set original value before close-out "RTN","RMPR4E21",23,0) K ^TMP("RM",$J),RM(RMPRA),RHCED S RMPRF=2 "RTN","RMPR4E21",24,0) K %X,%Y S %X="^RMPR(664,RMPRA,",%Y="^TMP("_"""RM"""_",$J,RMPRA," D %XY^%RCR "RTN","RMPR4E21",25,0) S RM(RMPRA,0)=$G(^RMPR(664,RMPRA,0)),RM(RMPRA,2)=$G(^(2)),RM(RMPRA,4)=$G(^(4)) "RTN","RMPR4E21",26,0) S RMPER=$P(RM(RMPRA,2),U,6),RMBAN=$P(RM(RMPRA,4),U,2),RMSHI=$P(RM(RMPRA,0),U,11),RMSHIEN=$P(RM(RMPRA,0),U,12) "RTN","RMPR4E21",27,0) ;added by #62 "RTN","RMPR4E21",28,0) ;collect all items and previous linkage to suspense. "RTN","RMPR4E21",29,0) I $G(RMSHIEN) S:'$D(^RMPR(660,RMSHIEN,10)) RM60LINK(RMSHIEN)="" "RTN","RMPR4E21",30,0) D COL^RMPRPCEL "RTN","RMPR4E21",31,0) ; "RTN","RMPR4E21",32,0) L ;**** ask for final posting ***************************************** "RTN","RMPR4E21",33,0) D ^RMPR4LI N DIR K RFLG "RTN","RMPR4E21",34,0) S DIR("A")="Ready to Reconcile and Close-Out Transaction",DIR("B")="NO",DIR(0)="Y" "RTN","RMPR4E21",35,0) S DIR("?")="You may now Close-out and Post this Transaction. Please answer Yes or No." "RTN","RMPR4E21",36,0) D ^DIR I Y["^"!($D(DTOUT)) W !,"Transaction NOT Closed-Out!" S:$D(^TMP("RM",$J)) RFLG=1 G:$D(RFLG) POST1 G KTMP "RTN","RMPR4E21",37,0) I Y=1 G POST1 "RTN","RMPR4E21",38,0) ;***add/edit transaction********************************************** "RTN","RMPR4E21",39,0) L1 K DIR S DIR(0)="FO",DIR("A")="Select ITEM" "RTN","RMPR4E21",40,0) S DIR("?")="^S RFL=1 D ZDSP^RMPR421A" "RTN","RMPR4E21",41,0) D ^DIR G:(Y="^")!(Y="") DS G:$D(DTOUT) L "RTN","RMPR4E21",42,0) G:$D(DIRUT)&($D(^RMPR(664,RMPRA,1))) L "RTN","RMPR4E21",43,0) S DIC=661,DIC(0)="ENMZ" D ^DIC I +Y'>0 W !,"** No Item selected.." G DS "RTN","RMPR4E21",44,0) G:$D(DTOUT)!$D(DUOUT) L "RTN","RMPR4E21",45,0) D PROC G L1 "RTN","RMPR4E21",46,0) ;***process items******************************************************* "RTN","RMPR4E21",47,0) PROC N NEW S HY=+Y I $D(^RMPR(664,RMPRA,1,"B",+Y)) S DA=$O(^RMPR(664,RMPRA,1,"B",+Y,0)) G CHK "RTN","RMPR4E21",48,0) FILE S Y=HY,NUM=$P(^RMPR(664,RMPRA,1,0),U,4)+1,$P(^(0),U,4)=NUM,$P(^(0),U,3)=$P(^(0),U,3)+1,^RMPR(664,RMPRA,1,NUM,0)=+Y,DA=NUM,^RMPR(664,RMPRA,1,"B",+Y,NUM)="" S NEW=1 "RTN","RMPR4E21",49,0) ENT K DR,DQ S DA(1)=RMPRA,DIE="^RMPR(664,"_RMPRA_",1," "RTN","RMPR4E21",50,0) ;S DR=$S($D(NEW):"",1:".01;") "RTN","RMPR4E21",51,0) I '$D(NEW),($P(^RMPR(664,RMPRA,1,DA,0),U,7)="") S $P(^(0),U,7)=$P(^(0),U,3) "RTN","RMPR4E21",52,0) S:'$D(NEW) RMDACA=$P(^RMPR(664,RMPRA,1,DA,0),U,13) "RTN","RMPR4E21",53,0) S R4DA=DA "RTN","RMPR4E21",54,0) S DR="8;S RMTYPE=$P(^RMPR(664,RMPRA,1,R4DA,0),U,9);9;.01;" "RTN","RMPR4E21",55,0) S DR=DR_"16R;1;14;17;15;3R;" "RTN","RMPR4E21",56,0) I $D(NEW) S DR=DR_"2R~UNIT COST;" "RTN","RMPR4E21",57,0) E S DR=DR_"6R;",RHCNEW=$P($G(^RMPR(664,RMPRA,1,R4DA,0)),U,16) "RTN","RMPR4E21",58,0) S DR=DR_"4R~UNIT OF ISSUE;7;11////C" D ^DIE "RTN","RMPR4E21",59,0) I $D(NEW) S:$G(DA) ^TMP("RM",$J,"N",R4DA)=$G(^RMPR(664,RMPRA,1,R4DA,0)) "RTN","RMPR4E21",60,0) E S:'$G(DA)&(RMDACA) ^TMP("RM",$J,"C",RMDACA)="" I $G(DA) S ^TMP("RM",$J,"E",DA)=$G(^RMPR(664,RMPRA,1,DA,0)),RHCOLD=$P(^RMPR(664,RMPRA,1,DA,0),U,16),RD660=$P(^(0),U,13) I RHCNEW'=RHCOLD D "RTN","RMPR4E21",61,0) .S RHCED=1 "RTN","RMPR4E21",62,0) .I $D(RD660)&(RD660) S DIE="^RMPR(660,",DA=RD660,DR="4.5///^S X=$G(RHCOLD)" D ^DIE "RTN","RMPR4E21",63,0) I $D(R4DA),$P($G(^RMPR(664,RMPRA,1,R4DA,0)),U,10)=4 S DA=R4DA,DR=10 D ^DIE "RTN","RMPR4E21",64,0) ;check for Type of Transaction and update the cpt modifier. "RTN","RMPR4E21",65,0) I $D(R4DA),$D(RMTYPE) S RDATA=RMTYPE_"^"_RMPRA_"^"_R4DA D CHKCPT^RMPR4UTL(RDATA) "RTN","RMPR4E21",66,0) Q:$D(DTOUT) K NUM,R4DA,DA,Y,DR,RD660,RHCOLD,RHCNEW,DIE,RDATA,RMTYPE Q "RTN","RMPR4E21",67,0) CHK ;ADD DUPLICATE LINE ITEM "RTN","RMPR4E21",68,0) K DIR,Y S DIR(0)="S^Y:YES;N:NO",DIR("A")="DO YOU WANT TO ADD A DUPLICATE ITEM?",DIR("B")="NO" D ^DIR Q:$D(DIRUT)!($D(DTOUT)) I (X["Y")!(X["y") G FILE "RTN","RMPR4E21",69,0) S RD=0 F RDA=0:0 S RDA=$O(^RMPR(664,RMPRA,1,"B",HY,RDA)) Q:RDA'>0 S RD=RD+1 "RTN","RMPR4E21",70,0) LKP I RD>1 D Q:$D(DIRUT)!$D(DTOUT) I '$D(RD(+Y)) W $C(7) G LKP "RTN","RMPR4E21",71,0) .F RDA=0:0 S RDA=$O(^RMPR(664,RMPRA,1,"B",HY,RDA)) Q:RDA'>0 S RD(RDA)=^RMPR(664,RMPRA,1,RDA,0) W !?5,RDA,?10,$P(^PRC(441,$P(^RMPR(661,$P(RD(RDA),U),0),U),0),U,2)," $",$S($P(RD(RDA),U,7)'="":$P(RD(RDA),U,7),1:$P(RD(RDA),U,3)) "RTN","RMPR4E21",72,0) .K DIR,Y S DIR(0)="N" D ^DIR I +Y S DA=+Y "RTN","RMPR4E21",73,0) G ENT "RTN","RMPR4E21",74,0) ; "RTN","RMPR4E21",75,0) DS ;**** update shipping cost, % discount and bank authorization ******** "RTN","RMPR4E21",76,0) S (RMPERF,RMBANF,RMSHIF)=0 "RTN","RMPR4E21",77,0) I $P(^RMPR(664,RMPRA,0),U,11)="",$P(^(0),U,10) S $P(^(0),U,11)=$P(RM(RMPRA,0),U,10) "RTN","RMPR4E21",78,0) S DA=RMPRA,DIE="^RMPR(664,",DR="12;17;26" D ^DIE "RTN","RMPR4E21",79,0) I RMPER'=$P(^RMPR(664,RMPRA,2),U,6) S RMPERF=1 "RTN","RMPR4E21",80,0) I RMBAN'=$P(^RMPR(664,RMPRA,4),U,2) S RMBANF=1 "RTN","RMPR4E21",81,0) I RMSHI'=$P(^RMPR(664,RMPRA,0),U,11) S RMSHIF=1 "RTN","RMPR4E21",82,0) S:$P(^RMPR(664,RMPRA,0),U,11)="" $P(^(0),U,11)=0 "RTN","RMPR4E21",83,0) CHK1 ;delete imcomplete items "RTN","RMPR4E21",84,0) S DIK="^RMPR(664,"_RMPRA_",1,",DA(1)=RMPRA F I=0:0 S I=$O(^RMPR(664,RMPRA,1,I)) Q:I'>0 S RMPRI=$G(^(I,0)) I $P(RMPRI,U,3)=""!($P(RMPRI,U,4)="")!($P(RMPRI,U,5)="") S DA=I D ^DIK "RTN","RMPR4E21",85,0) G L ;go back to select ITEM "RTN","RMPR4E21",86,0) ;************************************************************* "RTN","RMPR4E21",87,0) POST1 ;SET AMOUNT FOR IFCAP AMENDMENT. "RTN","RMPR4E21",88,0) S (R1,RMPR("AMT"),AMT,DCT,RMPRTO)=0 "RTN","RMPR4E21",89,0) I $D(^RMPR(664,RMPRA,2)),$P(^(2),U,6) S DCT=$P(^(2),U,6),DCT=DCT/100 "RTN","RMPR4E21",90,0) F RI=0:0 S RI=$O(^RMPR(664,RMPRA,1,RI)) Q:RI'>0 D "RTN","RMPR4E21",91,0) .N RMACT "RTN","RMPR4E21",92,0) .S RMX=$G(^RMPR(664,RMPRA,1,RI,0)),RMACT=$P(RMX,U,7),RMQTY=$P(RMX,U,4) "RTN","RMPR4E21",93,0) .I DCT S RMTOT=$S(RMACT=0!(RMACT>0):RMACT-$J(RMACT*DCT,0,2)*RMQTY,1:$P(RMX,U,3)-$J($P(RMX,U,3)*DCT,0,2)*RMQTY) "RTN","RMPR4E21",94,0) .I 'DCT S RMTOT=$S(RMACT=0!(RMACT>0):RMACT*RMQTY,1:$P(RMX,U,3)*RMQTY) "RTN","RMPR4E21",95,0) .S RMPR("AMT")=RMPR("AMT")+RMTOT,RMPRTO=RMPR("AMT") "RTN","RMPR4E21",96,0) S RMPRSH=$S($P(^RMPR(664,RMPRA,0),U,11)=0:0,$P(^RMPR(664,RMPRA,0),U,11):$P(^(0),U,11),$P(^RMPR(664,RMPRA,0),U,10):$P(^(0),U,10),1:"") "RTN","RMPR4E21",97,0) D CHECK^RMPRCT I '$D(RMPRTO) W !,"***** NOT CLOSED-OUT !!!!" G KTMP "RTN","RMPR4E21",98,0) ;************************************************************** "RTN","RMPR4E21",99,0) ;check 4;3,2;8&2;9&4;6 call PRCH7C if needed "RTN","RMPR4E21",100,0) ;if total amount has not changed, then don't need to call ammend "RTN","RMPR4E21",101,0) ;if it is an early record with no ifcap order then don't call ammend "RTN","RMPR4E21",102,0) ;set the reprint flag "RTN","RMPR4E21",103,0) I $FN($P(^RMPR(664,RMPRA,4),U,3),"P",2)'=$FN(RMPRTO+RMPRSH,"P",2)&($P(^(2),U,9)="")!($P(^(2),U,9)'="")&($FN($P(^(2),U,9),"P",2)'=$FN(RMPRTO+RMPRSH,"P",2)) D I (X=0)&'$D(^TMP("RM",$J)) W !!,"**** NOT CLOSED-OUT!! ****" G KTMP "RTN","RMPR4E21",104,0) .;call IFCAP AMMEND "RTN","RMPR4E21",105,0) .S RMPR442=$P(^RMPR(664,RMPRA,4),U,6) I RMPR442="" Q "RTN","RMPR4E21",106,0) .D AMEND^PRCH7C(RMPR442,RMPRTO+RMPRSH) "RTN","RMPR4E21",107,0) .I X=1 S $P(^RMPR(664,RMPRA,2),U,8)=DUZ,$P(^RMPR(664,RMPRA,2),U,9)=RMPRTO+RMPRSH,$P(^RMPR(664,RMPRA,2),U,10)=1 "RTN","RMPR4E21",108,0) .I X'=1 S $P(^RMPR(664,RMPRA,2),U,10)="" "RTN","RMPR4E21",109,0) ;do posting to 660 "RTN","RMPR4E21",110,0) I $D(^TMP("RM",$J))!$G(RMSHIF)!$G(RMPERF)!$G(RMBANF) D POST2^RMPR4M "RTN","RMPR4E21",111,0) I $D(RMPRWO),$D(^RMPR(664.2,+RMPRWO,0)) S $P(^("AM"),U,2)=1 S $P(^RMPR(664.2,+RMPRWO,0),U,7)=$P(^(0),U,7)+RMPRSH D DA0^RMPR29M(RMPRDA,RMPRA),POST^RMPR29U "RTN","RMPR4E21",112,0) G:$D(RFLG) EXIT "RTN","RMPR4E21",113,0) ;go to exit in above line if not close-out. "RTN","RMPR4E21",114,0) ;close-out remarks "RTN","RMPR4E21",115,0) W ! S DIE="^RMPR(664,",DA=RMPRA,DR="8.1" D ^DIE S RMPRCC=$P($G(^RMPR(664,RMPRA,2)),U,3) "RTN","RMPR4E21",116,0) F S R1=$O(^RMPR(664,RMPRA,1,R1)) Q:R1'>0 I $D(^(R1,0)) D "RTN","RMPR4E21",117,0) .N RM660 "RTN","RMPR4E21",118,0) .S RM660=$P($G(^(0)),U,13) I RM660,$P($G(^RMPR(660,RM660,0)),U,18)'[RMPRCC S $P(^(0),U,18)=$P(^(0),U,18)_" "_RMPRCC "RTN","RMPR4E21",119,0) ; "RTN","RMPR4E21",120,0) EX ;***reindex record in 664 here "RTN","RMPR4E21",121,0) L -^RMPR(664,RMPRA,0) "RTN","RMPR4E21",122,0) ;IFCAP final charge payment "RTN","RMPR4E21",123,0) S RMPR442=$P(^RMPR(664,RMPRA,4),U,6) ;don't call recon if it is an early record, no ifcap order. "RTN","RMPR4E21",124,0) D:RMPR442'="" RECON^PRCH7C(RMPR442,DUZ) "RTN","RMPR4E21",125,0) I (X=0)&(RMPR442'="") W !!,"**** TRANSACTION NOT CLOSED-OUT!! ****" G EX1 "RTN","RMPR4E21",126,0) S $P(^RMPR(664,RMPRA,4),U,4)=RMPRTO+RMPRSH "RTN","RMPR4E21",127,0) ;set close out date "RTN","RMPR4E21",128,0) D NOW^%DTC S $P(^RMPR(664,RMPRA,0),U,8)=% "RTN","RMPR4E21",129,0) ;set closed by "RTN","RMPR4E21",130,0) S $P(^RMPR(664,RMPRA,2),U,7)=DUZ,DA=$P(^RMPR(664,RMPRA,0),U,12) "RTN","RMPR4E21",131,0) I DA'="" S $P(^RMPR(660,DA,0),U,12)=%,DIK="^RMPR(660," D IX1^DIK "RTN","RMPR4E21",132,0) S RMPR660=0,DA="",DIK="^RMPR(660," "RTN","RMPR4E21",133,0) F S RMPR660=$O(^RMPR(664,RMPRA,1,RMPR660)) Q:RMPR660'>0 D "RTN","RMPR4E21",134,0) .;get pointer from item mult "RTN","RMPR4E21",135,0) .S DA=$P(^RMPR(664,RMPRA,1,RMPR660,0),U,13) "RTN","RMPR4E21",136,0) .;set delivery date "RTN","RMPR4E21",137,0) .I DA'="" S $P(^RMPR(660,DA,0),U,12)=DT D IX1^DIK "RTN","RMPR4E21",138,0) .;Patch #78 - Get IFCAP Transaction Date and prompt for Shipment Date "RTN","RMPR4E21",139,0) .I DA'="" D ^RMPR4E23 "RTN","RMPR4E21",140,0) EX1 ; "RTN","RMPR4E21",141,0) ;added by #62 "RTN","RMPR4E21",142,0) D:RM68FG=1 AUTO^RMPRPCEL D:RM68FG>1 MAN^RMPRPCEL "RTN","RMPR4E21",143,0) ; "RTN","RMPR4E21",144,0) D EXIT "RTN","RMPR4E21",145,0) W !!,"Enter Next Transaction to Close-out, or to continue." "RTN","RMPR4E21",146,0) G CL "RTN","RMPR4E21",147,0) ; "RTN","RMPR4E21",148,0) EXIT ;KILL VARIABLES AND EXIT ROUTINE "RTN","RMPR4E21",149,0) L:$D(RMPRA) -^RMPR(664,RMPRA,0) "RTN","RMPR4E21",150,0) K ^TMP($J),^TMP("RM") "RTN","RMPR4E21",151,0) K RGRP,RGRP1,RGRPP,RMBAN,RMBANF "RTN","RMPR4E21",152,0) N RMPR,RMPRSITE D KILL^XUSCLEAN "RTN","RMPR4E21",153,0) Q "RTN","RMPR4E21",154,0) ; "RTN","RMPR4E21",155,0) KTMP S DIK="^RMPR(664,"_RMPRA_",1,",DA(1)=RMPRA F I=0:0 S I=$O(^TMP("RM",$J,"N",I)) Q:I'>0 S DA=I D ^DIK "RTN","RMPR4E21",156,0) S %X="^TMP("_"""RM"""_",$J,RMPRA,",%Y="^RMPR(664,RMPRA," D %XY^%RCR G EX1 "RTN","RMPR4E21",157,0) BRK W !,$C(7),"INCOMPLETE RECORD..file 664..entry..",RMPRA,"...PLEASE CONTACT YOUR IRM or CANCEL THIS ENTRY!!!" G EX1 "RTN","RMPR4E21",158,0) UNK W !,$C(7),"UNKNOWN 2319 RECORD TO UPDATE, 2319 NOT UPDATED!" G EXIT "RTN","RMPR4E21",159,0) M4 W !,$C(7),"This Transaction has already been CLOSED!" G EXIT "RTN","RMPR4E21",160,0) M6 W !,$C(7),"This Transaction has been CANCELED!" G EXIT "RTN","RMPR4E23") 0^4^B3734591 "RTN","RMPR4E23",1,0) RMPR4E23 ;HINES CIOFO/TH - PROMPT FOR SHIPMENT DATE ;08/05/03 "RTN","RMPR4E23",2,0) ;;3.0;PROSTHETICS;**78,114**;Feb 09, 1996 "RTN","RMPR4E23",3,0) ; "RTN","RMPR4E23",4,0) ;TH 08/05/03 Patch #78 - Add shipment date. "RTN","RMPR4E23",5,0) ; - DBIA #3427 "RTN","RMPR4E23",6,0) ; "RTN","RMPR4E23",7,0) ; RMIFCAP = IFCAP Order "RTN","RMPR4E23",8,0) ; RMPRTRDT = Transaction Date from file #440.6 "RTN","RMPR4E23",9,0) ; RMPRSHIP = Shipment Date "RTN","RMPR4E23",10,0) ; "RTN","RMPR4E23",11,0) S (RMIFCAP,RMPRTRDT,RMPRSHIP)="" "RTN","RMPR4E23",12,0) ; Set default to today's date "RTN","RMPR4E23",13,0) S RMPRTRDT=DT "RTN","RMPR4E23",14,0) I $D(^RMPR(664,RMPRA)) D "RTN","RMPR4E23",15,0) . Q:'$D(^RMPR(664,RMPRA,4)) "RTN","RMPR4E23",16,0) . S RMIFCAP=$P(^RMPR(664,RMPRA,4),U,6) Q:RMIFCAP="" "RTN","RMPR4E23",17,0) . I $D(^PRCH(440.6,"PO",RMIFCAP)) D "RTN","RMPR4E23",18,0) . . S D1="",D1=$O(^PRCH(440.6,"PO",RMIFCAP,D1),-1) Q:D1="" "RTN","RMPR4E23",19,0) . . Q:'$D(^PRCH(440.6,D1,0)) "RTN","RMPR4E23",20,0) . . S RMPRTRDT=$$GET1^DIQ(440.6,D1,6,"I") "RTN","RMPR4E23",21,0) S RMPRTRDT=$$FMTE^XLFDT(RMPRTRDT,"2D") "RTN","RMPR4E23",22,0) D GETDT,BILL,EXIT "RTN","RMPR4E23",23,0) Q "RTN","RMPR4E23",24,0) ; "RTN","RMPR4E23",25,0) GETDT ; DIR call to obtain the shipment date "RTN","RMPR4E23",26,0) Q:$G(DA)="" "RTN","RMPR4E23",27,0) K DIR,DIRUT "RTN","RMPR4E23",28,0) S DIR(0)="D",DIR("A")="Shipment Date",DIR("B")=$G(RMPRTRDT) "RTN","RMPR4E23",29,0) S DIR("?")="The date that the item shipped to the patient. The default" "RTN","RMPR4E23",30,0) S DIR("?")=DIR("?")_" date would be the transaction date from IFCAP." "RTN","RMPR4E23",31,0) D ^DIR "RTN","RMPR4E23",32,0) S RMPRSHIP=Y "RTN","RMPR4E23",33,0) G:'$D(^RMPR(660,DA)) EXIT "RTN","RMPR4E23",34,0) G:RMPRSHIP="" EXIT "RTN","RMPR4E23",35,0) ; Shipment Date/Date of Service filed in file #660. "RTN","RMPR4E23",36,0) I DA'="" S $P(^RMPR(660,DA,1),U,8)=RMPRSHIP "RTN","RMPR4E23",37,0) Q "RTN","RMPR4E23",38,0) ; "RTN","RMPR4E23",39,0) BILL ; File to #660.5 - ready to bill "RTN","RMPR4E23",40,0) Q ; taken out for phase II Billing Aware (WLC 02/26/04) "RTN","RMPR4E23",41,0) N DIC,X,DLAYGO,DIR "RTN","RMPR4E23",42,0) S DIC="^RMPR(660.5," "RTN","RMPR4E23",43,0) S DIC(0)="L",X="""N""" "RTN","RMPR4E23",44,0) S DLAYGO=660.5 D ^DIC K DLAYGO Q:Y<1 "RTN","RMPR4E23",45,0) S RMPRO=+Y,DIE=DIC "RTN","RMPR4E23",46,0) ; "RTN","RMPR4E23",47,0) L +^RMPR(660.5,RMPRO) "RTN","RMPR4E23",48,0) ; .01-Transaction Date; 2-Send Required; .02-Shipment Date "RTN","RMPR4E23",49,0) ; 3-ProsFile(pointer to file #660) "RTN","RMPR4E23",50,0) S DR=".01////^S X=DT;2////1;.02////^S X=RMPRSHIP;3////^S X=DA" "RTN","RMPR4E23",51,0) D ^DIE "RTN","RMPR4E23",52,0) L -^RMPR(660.5,RMPRO) "RTN","RMPR4E23",53,0) Q "RTN","RMPR4E23",54,0) ; "RTN","RMPR4E23",55,0) EXIT ; Exit "RTN","RMPR4E23",56,0) K DA,DIC,DIE,DR,RMIFCAP,RMPRTRDT,RMPRSHIP "RTN","RMPR4E23",57,0) Q "RTN","RMPRPCEA") 0^1^B50015987 "RTN","RMPRPCEA",1,0) RMPRPCEA ;HCIOFO/RVD - Prosthetics/PCE Interface; 05/31/01 "RTN","RMPRPCEA",2,0) ;;3.0;PROSTHETICS;**62,82,78,114**;Feb 09, 1996 "RTN","RMPRPCEA",3,0) ; "RTN","RMPRPCEA",4,0) ; RMS 10/1/03 Patch 78 - Change Service connected, and environmental "RTN","RMPRPCEA",5,0) ; indicators (Agent Orange, Ionizing Radiation, "RTN","RMPRPCEA",6,0) ; Environmental Contaminants, Military Sexual "RTN","RMPRPCEA",7,0) ; Trauma, Head/Neck Cancer, and Combat Veteran "RTN","RMPRPCEA",8,0) ; Status) to come from new BA fields if they "RTN","RMPRPCEA",9,0) ; exist. "RTN","RMPRPCEA",10,0) ; "RTN","RMPRPCEA",11,0) ;This routine contains the code for sending a Prosthetic visit to PCE. "RTN","RMPRPCEA",12,0) ; "RTN","RMPRPCEA",13,0) ;DBIA #1889-A - this API is used to add, edit and delete the "RTN","RMPRPCEA",14,0) ; of encounter, provider, diagnosis and procedure "RTN","RMPRPCEA",15,0) ; data to VISIT and V files in the PCE module. "RTN","RMPRPCEA",16,0) ; 04/23/2004 KAM RMPR*3*82 Make Background Message more Robust "RTN","RMPRPCEA",17,0) ; "RTN","RMPRPCEA",18,0) ;RMIE60 - ien in file #660 "RTN","RMPRPCEA",19,0) SENDPCE(RMIE60) ; send a Prosthetic Visit to PCE. "RTN","RMPRPCEA",20,0) ; D NEWVAR subroutine removed for functionality 01/31/05 WLC "RTN","RMPRPCEA",21,0) ; "RTN","RMPRPCEA",22,0) N RMPCE,RME2,RMSENT,RMLOCK,RMERR,RMPKG,RMSRC,RMDIAG,RMQTY "RTN","RMPRPCEA",23,0) N RMSCAT,RMPROC,RMUPD,RMIEPCE,RMHLOC,RMLOC,RMPAT,RMDATE,RMINST "RTN","RMPRPCEA",24,0) N RMETYP,RMCDAT,RMPCAT,RMDANOW,DIE,DA,DIC,RMAO,RMEC,RMIR,DFN,RMSCON "RTN","RMPRPCEA",25,0) N RMMST,RMHNC,RMCBV "RTN","RMPRPCEA",26,0) ; PATCH 78, RMS - 10/1/2003, Billing aware related variables "RTN","RMPRPCEA",27,0) N RMBASCON,RMBAAO,RMBAIR,RMBAEC,RMBAMST,RMBAHNC,RMBACBV,RMBAICD9,RMLOOP "RTN","RMPRPCEA",28,0) N RMPROV,RMCPDT "RTN","RMPRPCEA",29,0) ; "RTN","RMPRPCEA",30,0) S RMERR=1 "RTN","RMPRPCEA",31,0) S RMSRC="PROSTHETICS DATA" "RTN","RMPRPCEA",32,0) S RMPKG=$O(^DIC(9.4,"B","PROSTHETICS",0)) "RTN","RMPRPCEA",33,0) I '$G(RMPKG) S RMERR=-2 G SENDPCEX "RTN","RMPRPCEA",34,0) S RMSTA=$P(^RMPR(660,RMIE60,0),U,10) "RTN","RMPRPCEA",35,0) S (RMLOC,RERRMSG,RERRMSG2)="" "RTN","RMPRPCEA",36,0) F I=0:0 S I=$O(^RMPR(669.9,"C",RMSTA,I)) Q:I'>0 D "RTN","RMPRPCEA",37,0) .I ($D(^RMPR(669.9,I,0))),($D(^RMPR(669.9,I,"PCE"))) S RMLOC=$P(^RMPR(669.9,I,"PCE"),U,3) "RTN","RMPRPCEA",38,0) ;exit if Hospital Location (clinic) not defined. "RTN","RMPRPCEA",39,0) I '$G(RMLOC) D G SENDPCEX "RTN","RMPRPCEA",40,0) .S RMERR=-2 "RTN","RMPRPCEA",41,0) .;RMPR*3*82 04/23/2004 KAM Added next 8 lines "RTN","RMPRPCEA",42,0) .N SPACES,VNAME,ENDAT "RTN","RMPRPCEA",43,0) .S VNAME=$$GET1^DIQ(2,$P(^RMPR(660,RMIE60,0),U,2),.01) "RTN","RMPRPCEA",44,0) .S ENDAT=$$GET1^DIQ(660,RMIE60,.01),SPACES="" "RTN","RMPRPCEA",45,0) .I $G(ENDAT)="" S ENDAT=" No Entry Data Found" "RTN","RMPRPCEA",46,0) .F I=1:1:42-($L(VNAME)+$L(ENDAT)) S SPACES=$G(SPACES)_" " "RTN","RMPRPCEA",47,0) .S RERRMSG=" *** NAME = "_VNAME_" ENTRY DATE = "_ENDAT_SPACES "RTN","RMPRPCEA",48,0) .S RERRMSG=RERRMSG_" *** Clinic is not defined....Please ask your ADPAC to enter a prosthetics *** clinic in the Prosthetics Site Parameters file for station # = "_$G(RMSTA) "RTN","RMPRPCEA",49,0) .S RERRMSG2=" *** Using option 'Enter/Edit Station Site Parameters'" "RTN","RMPRPCEA",50,0) .W !,"*** Clinic is not defined....." "RTN","RMPRPCEA",51,0) .W !,"*** Please ask your ADPAC to enter a prosthetics clinic in the" "RTN","RMPRPCEA",52,0) .W !,"*** Prosthetics Site Parameters file for station # = ",RMSTA "RTN","RMPRPCEA",53,0) .W !,"*** Using option 'Enter/Edit Station Site Parameters'" "RTN","RMPRPCEA",54,0) S RMSENT=0,RMLOCK=0 "RTN","RMPRPCEA",55,0) ; initialize temp file. "RTN","RMPRPCEA",56,0) K ^TMP("RMPRPCE1",$J) "RTN","RMPRPCEA",57,0) ; "RTN","RMPRPCEA",58,0) ; get the visit data (#660) and place in temp file. "RTN","RMPRPCEA",59,0) D GETDATA "RTN","RMPRPCEA",60,0) ;don't create a PCE encounter if Date of Death is before the transaction "RTN","RMPRPCEA",61,0) I $D(VADM(6)),$P(VADM(6),U,1),$P(VADM(6),U,1)<(RMDATE) G SENDPCEX "RTN","RMPRPCEA",62,0) ; "RTN","RMPRPCEA",63,0) ; build the temp file for sending to PCE "RTN","RMPRPCEA",64,0) D BUILD "RTN","RMPRPCEA",65,0) ; "RTN","RMPRPCEA",66,0) ; now send "RTN","RMPRPCEA",67,0) D SENDIT "RTN","RMPRPCEA",68,0) ; "RTN","RMPRPCEA",69,0) SENDPCEX ; exit point "RTN","RMPRPCEA",70,0) ; "RTN","RMPRPCEA",71,0) ; clear the temp file "RTN","RMPRPCEA",72,0) K ^TMP("RMPRPCE1",$J) "RTN","RMPRPCEA",73,0) ; "RTN","RMPRPCEA",74,0) ; return "RTN","RMPRPCEA",75,0) Q RMERR "RTN","RMPRPCEA",76,0) ; "RTN","RMPRPCEA",77,0) GETDATA ; get the visit data and place in temp file "RTN","RMPRPCEA",78,0) K RMDA,RMDA2 "RTN","RMPRPCEA",79,0) S RMDA=$NA(^TMP("RMPRPCE1",$J,"RM")) "RTN","RMPRPCEA",80,0) D GETS^DIQ(660,RMIE60_",","*","I",RMDA,"") "RTN","RMPRPCEA",81,0) S RMDA2=$NA(^TMP("RMPRPCE1",$J,"RM",660,RMIE60_",")) "RTN","RMPRPCEA",82,0) D NOW^%DTC "RTN","RMPRPCEA",83,0) S RMDANOW=% "RTN","RMPRPCEA",84,0) S RMDATE=@RMDA2@(.01,"I"),RMDATE=RMDATE_"."_$P(%,".",2) "RTN","RMPRPCEA",85,0) S (DFN,RMPAT)=@RMDA2@(.02,"I") "RTN","RMPRPCEA",86,0) S RMHLOC=RMLOC "RTN","RMPRPCEA",87,0) S RMINST=@RMDA2@(8.11,"I") "RTN","RMPRPCEA",88,0) S RMPCAT=@RMDA2@(62,"I") "RTN","RMPRPCEA",89,0) S RMSCON=0 "RTN","RMPRPCEA",90,0) I (RMPCAT=1)!(RMPCAT=2) S RMSCON=1 "RTN","RMPRPCEA",91,0) ;============================== "RTN","RMPRPCEA",92,0) S RMSCAT="A" "RTN","RMPRPCEA",93,0) S RMETYP="P" "RTN","RMPRPCEA",94,0) S RMUSER=@RMDA2@(27,"I") "RTN","RMPRPCEA",95,0) S RMDIAG=@RMDA2@(8.8,"I") "RTN","RMPRPCEA",96,0) S RMPROC=@RMDA2@(4.1,"I") "RTN","RMPRPCEA",97,0) S RMPROV=@RMDA2@(8.6,"I") "RTN","RMPRPCEA",98,0) S RMCPDT=@RMDA2@(8.4,"I") "RTN","RMPRPCEA",99,0) S RMQTY=@RMDA2@(5,"I") "RTN","RMPRPCEA",100,0) S RMCDAT=@RMDA2@(10,"I") "RTN","RMPRPCEA",101,0) S (RMPCE,RMIEPCE)=@RMDA2@(8.12,"I") "RTN","RMPRPCEA",102,0) ; PATCH 78, RMS - 10/1/2003, billing aware related variables "RTN","RMPRPCEA",103,0) K RMBAICD9,RMBAAO,RMBASCON,RMBAAIR,RMBAEC,RMBAMST,RMBAHNC,RMBACBV "RTN","RMPRPCEA",104,0) I '$D(^RMPR(660,RMIE60,"BA1")) G GTDT ; no BA data, skip retrieval "RTN","RMPRPCEA",105,0) F RMLOOP=30:1:33 D "RTN","RMPRPCEA",106,0) . N RMBAREC S RMBAREC=RMLOOP-29 "RTN","RMPRPCEA",107,0) . S RMBAICD9(RMBAREC)=@RMDA2@(RMLOOP,"I") "RTN","RMPRPCEA",108,0) . S RMBAAO(RMBAREC)=@RMDA2@((RMLOOP+.1),"I") "RTN","RMPRPCEA",109,0) . S RMBAIR(RMBAREC)=@RMDA2@((RMLOOP+.2),"I") "RTN","RMPRPCEA",110,0) . S RMBASCON(RMBAREC)=@RMDA2@((RMLOOP+.3),"I") "RTN","RMPRPCEA",111,0) . S RMBAEC(RMBAREC)=@RMDA2@((RMLOOP+.4),"I") "RTN","RMPRPCEA",112,0) . S RMBAMST(RMBAREC)=@RMDA2@((RMLOOP+.5),"I") "RTN","RMPRPCEA",113,0) . S RMBAHNC(RMBAREC)=@RMDA2@((RMLOOP+.6),"I") "RTN","RMPRPCEA",114,0) . S RMBACBV(RMBAREC)=@RMDA2@((RMLOOP+.7),"I") "RTN","RMPRPCEA",115,0) ; Retrieve order number "RTN","RMPRPCEA",116,0) GTDT S RMPTR123=@RMDA2@(8.9,"I") "RTN","RMPRPCEA",117,0) S RMODENT=$$GET1^DIQ(123,RMPTR123_",",.03) "RTN","RMPRPCEA",118,0) ;get Date of Death. "RTN","RMPRPCEA",119,0) D DEM^VADPT "RTN","RMPRPCEA",120,0) ;get Agent Orange and Radiation. "RTN","RMPRPCEA",121,0) D SVC^VADPT S RMAO=VASV(2),RMIR=VASV(3) "RTN","RMPRPCEA",122,0) ;get environmental contaminants. "RTN","RMPRPCEA",123,0) S RMEC=$$GET1^DIQ(2,DFN,.322013,"I") I RMEC="Y" S RMEC=1 "RTN","RMPRPCEA",124,0) S:RMEC'=1 RMEC=0 "RTN","RMPRPCEA",125,0) ; "RTN","RMPRPCEA",126,0) S RMMST="",RMCBV="",RMHNC="" "RTN","RMPRPCEA",127,0) Q "RTN","RMPRPCEA",128,0) ; "RTN","RMPRPCEA",129,0) BUILD ; now build array for passing data to PCE "RTN","RMPRPCEA",130,0) K ^TMP("RMPRPCE1",$J,"PXAPI"),RMAPI "RTN","RMPRPCEA",131,0) S RMAPI=$NA(^TMP("RMPRPCE1",$J,"PXAPI")) "RTN","RMPRPCEA",132,0) ; ---------encounter date/time---------------- "RTN","RMPRPCEA",133,0) S @RMAPI@("ENCOUNTER",1,"ENC D/T")=RMDATE "RTN","RMPRPCEA",134,0) ; --------------patient----------------------- "RTN","RMPRPCEA",135,0) S @RMAPI@("ENCOUNTER",1,"PATIENT")=RMPAT "RTN","RMPRPCEA",136,0) ; ---------------clinic----------------------- "RTN","RMPRPCEA",137,0) S @RMAPI@("ENCOUNTER",1,"HOS LOC")=RMHLOC "RTN","RMPRPCEA",138,0) ; -------------checkout date/time------------- "RTN","RMPRPCEA",139,0) S @RMAPI@("ENCOUNTER",1,"CHECKOUT D/T")=RMDATE "RTN","RMPRPCEA",140,0) ; ------------agent orange-------------------- "RTN","RMPRPCEA",141,0) S @RMAPI@("ENCOUNTER",1,"AO")=RMAO "RTN","RMPRPCEA",142,0) ;--------------ionizing radiation------------- "RTN","RMPRPCEA",143,0) S @RMAPI@("ENCOUNTER",1,"IR")=RMIR "RTN","RMPRPCEA",144,0) ;-----------environmental contaminants-------- "RTN","RMPRPCEA",145,0) S @RMAPI@("ENCOUNTER",1,"EC")=RMEC "RTN","RMPRPCEA",146,0) ; --------------service connected-------------- "RTN","RMPRPCEA",147,0) S @RMAPI@("ENCOUNTER",1,"SC")=RMSCON "RTN","RMPRPCEA",148,0) ; ------------Military Sexual Trauma---------- "RTN","RMPRPCEA",149,0) S @RMAPI@("ENCOUNTER",1,"MST")=RMMST "RTN","RMPRPCEA",150,0) ; -------------Head/Neck Cancer--------------- "RTN","RMPRPCEA",151,0) S @RMAPI@("ENCOUNTER",1,"HNC")=RMHNC "RTN","RMPRPCEA",152,0) ; --------------Combat Veteran--------- "RTN","RMPRPCEA",153,0) S @RMAPI@("ENCOUNTER",1,"CV")=RMCBV "RTN","RMPRPCEA",154,0) ; --------------service category-------------- "RTN","RMPRPCEA",155,0) S @RMAPI@("ENCOUNTER",1,"SERVICE CATEGORY")=RMSCAT "RTN","RMPRPCEA",156,0) ; ---------------encounter type--------------- "RTN","RMPRPCEA",157,0) S @RMAPI@("ENCOUNTER",1,"ENCOUNTER TYPE")=RMETYP "RTN","RMPRPCEA",158,0) ; ------------primary provider---------------- "RTN","RMPRPCEA",159,0) S @RMAPI@("PROVIDER",1,"NAME")=RMUSER "RTN","RMPRPCEA",160,0) ; ----------------diagnosis------------------ "RTN","RMPRPCEA",161,0) S @RMAPI@("DX/PL",1,"DIAGNOSIS")=RMDIAG "RTN","RMPRPCEA",162,0) S @RMAPI@("DX/PL",1,"PRIMARY")=1 "RTN","RMPRPCEA",163,0) ; -------------- procedures ----------------- "RTN","RMPRPCEA",164,0) S @RMAPI@("PROCEDURE",1,"PROCEDURE")=RMPROC "RTN","RMPRPCEA",165,0) ; ---------------- Quantity ----------------- "RTN","RMPRPCEA",166,0) S @RMAPI@("PROCEDURE",1,"QTY")=RMQTY "RTN","RMPRPCEA",167,0) ; -------------- Procedures ----------------- "RTN","RMPRPCEA",168,0) I '$D(RMBAICD9(1)) D Q "RTN","RMPRPCEA",169,0) . S @RMAPI@("PROCEDURE",1,"DIAGNOSIS")=RMDIAG "RTN","RMPRPCEA",170,0) ; "RTN","RMPRPCEA",171,0) F RMLOOP=1:1:99 Q:$G(RMBAICD9(RMLOOP))="" D "RTN","RMPRPCEA",172,0) . S @RMAPI@("DX/PL",RMLOOP,"DIAGNOSIS")=$G(RMBAICD9(RMLOOP)) "RTN","RMPRPCEA",173,0) . S @RMAPI@("DX/PL",RMLOOP,"PL AO")=$G(RMBAAO(RMLOOP)) "RTN","RMPRPCEA",174,0) . S @RMAPI@("DX/PL",RMLOOP,"PL IR")=$G(RMBAIR(RMLOOP)) "RTN","RMPRPCEA",175,0) . S @RMAPI@("DX/PL",RMLOOP,"PL SC")=$G(RMBASCON(RMLOOP)) "RTN","RMPRPCEA",176,0) . S @RMAPI@("DX/PL",RMLOOP,"PL EC")=$G(RMBAEC(RMLOOP)) "RTN","RMPRPCEA",177,0) . S @RMAPI@("DX/PL",RMLOOP,"PL MST")=$G(RMBAMST(RMLOOP)) "RTN","RMPRPCEA",178,0) . S @RMAPI@("DX/PL",RMLOOP,"PL HNC")=$G(RMBAHNC(RMLOOP)) "RTN","RMPRPCEA",179,0) . S @RMAPI@("DX/PL",RMLOOP,"PL CV")=$G(RMBACBV(RMLOOP)) "RTN","RMPRPCEA",180,0) . I RMLOOP=1 D Q "RTN","RMPRPCEA",181,0) . . S @RMAPI@("DX/PL",RMLOOP,"PRIMARY")=RMLOOP "RTN","RMPRPCEA",182,0) . . S RMDIAG=$G(RMBAICD9(RMLOOP)) "RTN","RMPRPCEA",183,0) . . S @RMAPI@("PROCEDURE",1,"DIAGNOSIS")=$G(RMBAICD9(RMLOOP)) "RTN","RMPRPCEA",184,0) . S @RMAPI@("PROCEDURE",1,"DIAGNOSIS "_RMLOOP)=$G(RMBAICD9(RMLOOP)) ; only one procedure per send "RTN","RMPRPCEA",185,0) ; "RTN","RMPRPCEA",186,0) ; -----------------procedures---------------- "RTN","RMPRPCEA",187,0) S @RMAPI@("PROCEDURE",1,"PROCEDURE")=RMPROC "RTN","RMPRPCEA",188,0) S @RMAPI@("PROCEDURE",1,"ORD PROVIDER")=RMPROV "RTN","RMPRPCEA",189,0) S @RMAPI@("PROCEDURE",1,"EVENT D/T")=RMCPDT "RTN","RMPRPCEA",190,0) ; ------------- Order Reference ------------- "RTN","RMPRPCEA",191,0) S @RMAPI@("PROCEDURE",1,"ORD REFERENCE")=RMODENT "RTN","RMPRPCEA",192,0) ; -----------------Quantity------------------ "RTN","RMPRPCEA",193,0) S @RMAPI@("PROCEDURE",1,"QTY")=RMQTY "RTN","RMPRPCEA",194,0) ; -----------------diagnosis----------------- "RTN","RMPRPCEA",195,0) S @RMAPI@("PROCEDURE",1,"DIAGNOSIS")=RMDIAG "RTN","RMPRPCEA",196,0) Q "RTN","RMPRPCEA",197,0) ; "RTN","RMPRPCEA",198,0) SENDIT ; send the data to PCE. API (1891) "RTN","RMPRPCEA",199,0) K RMPROB "RTN","RMPRPCEA",200,0) S (RMPRCPER,RMPROB)=0 "RTN","RMPRPCEA",201,0) ; call the PCE package API. "RTN","RMPRPCEA",202,0) S RMERR=$$DATA2PCE^PXAPI($NA(^TMP("RMPRPCE1",$J,"PXAPI")),RMPKG,RMSRC,.RMPCE,RMUSER,0,,"",.RMPROB) "RTN","RMPRPCEA",203,0) ;To check for returned error messages, list the RMPROB array. "RTN","RMPRPCEA",204,0) I RMERR<1 W !,"File #660 IEN="_RMIE60_" - Error in PCE interface !!!" "RTN","RMPRPCEA",205,0) ;delete PCE entry if Provider and CPT CODE error, but send an error "RTN","RMPRPCEA",206,0) ;message to RMPR PCE mailgroup. "RTN","RMPRPCEA",207,0) I $D(RMPROB($J)) D CHECK^RMPRPCED "RTN","RMPRPCEA",208,0) I $G(RMPCE),$G(RMPRCPER) S RMCHK=$$DELVFILE^PXAPI("ALL",.RMPCE,RMPKG,RMSRC,0,0,"") Q "RTN","RMPRPCEA",209,0) ; "RTN","RMPRPCEA",210,0) Q:'$G(RMPCE) "RTN","RMPRPCEA",211,0) ;update PCE pointer and date last sent in #660. "RTN","RMPRPCEA",212,0) K RMUPD "RTN","RMPRPCEA",213,0) S RMUPD(660,RMIE60_",",8.12)=RMPCE "RTN","RMPRPCEA",214,0) S RMUPD(660,RMIE60_",",8.13)=RMDANOW "RTN","RMPRPCEA",215,0) D FILE^DIE("","RMUPD","") "RTN","RMPRPCEA",216,0) Q "RTN","RMPRPCEA",217,0) ; "RTN","RMPRPCEB") 0^2^B20818586 "RTN","RMPRPCEB",1,0) RMPRPCEB ;HIN/RVD-PROS PCE BACKGROUND UTILITY ; 1/23/04 8:09am "RTN","RMPRPCEB",2,0) ;;3.0;PROSTHETICS;**62,69,77,82,78,114**;Feb 09, 1996 "RTN","RMPRPCEB",3,0) ; "RTN","RMPRPCEB",4,0) ;RVD patch #69 - add STATION in the error message. "RTN","RMPRPCEB",5,0) ; QUIT if no data in specified date range. "RTN","RMPRPCEB",6,0) ;RVD patch #77 - only create 1 PCE entry for the same pt & same day. "RTN","RMPRPCEB",7,0) ; "RTN","RMPRPCEB",8,0) ;KAM Patch #82 06/21/2004 - Add more robust text to 'Missing "RTN","RMPRPCEB",9,0) ; Prosthetics Clinic PCE error message "RTN","RMPRPCEB",10,0) ; "RTN","RMPRPCEB",11,0) ;WLC Patch #78 02/03/3005 - added NEW statement for error message "RTN","RMPRPCEB",12,0) ; variables defined for Patch 82. "RTN","RMPRPCEB",13,0) ; "RTN","RMPRPCEB",14,0) W !,"Invalid Entry Point.....",! "RTN","RMPRPCEB",15,0) Q "RTN","RMPRPCEB",16,0) TASK ;entry point for task job to send pros encounters to PCE. "RTN","RMPRPCEB",17,0) N RERRMSG,RERRMSG2 ; correction for patch 82 02/03/05 WLC "RTN","RMPRPCEB",18,0) S IO=0,RMAIL=1 "RTN","RMPRPCEB",19,0) S Y=DT D DD^%DT S RMRDAT=Y K RMX,RMXMT,^TMP($J) "RTN","RMPRPCEB",20,0) D NOW^%DTC S RMSTDT=% "RTN","RMPRPCEB",21,0) S X="T-90" D ^%DT S RM90DAY=Y "RTN","RMPRPCEB",22,0) S RMBIEN=$O(^RMPR(660,"B",RM90DAY)) "RTN","RMPRPCEB",23,0) Q:RMBIEN="" "RTN","RMPRPCEB",24,0) S (RMENDT,RFLDAT)=0 "RTN","RMPRPCEB",25,0) F RS=0:0 S RS=$O(^RMPR(669.9,RS)) Q:RS'>0 D PCEFLG "RTN","RMPRPCEB",26,0) S RI=$O(^RMPR(660,"B",RMBIEN,0)) "RTN","RMPRPCEB",27,0) F S RI=$O(^RMPR(660,RI)) Q:RI'>0 D "RTN","RMPRPCEB",28,0) .S RM600=$G(^RMPR(660,RI,0)) "RTN","RMPRPCEB",29,0) .S RM611=$G(^RMPR(660,RI,1)) "RTN","RMPRPCEB",30,0) .S RM610=$G(^RMPR(660,RI,10)) "RTN","RMPRPCEB",31,0) .Q:$P(RM600,U,15) "RTN","RMPRPCEB",32,0) .Q:$P(RM600,U,17) "RTN","RMPRPCEB",33,0) .Q:'$P(RM610,U,8) "RTN","RMPRPCEB",34,0) .S RMSTA=$P(RM600,U,10) "RTN","RMPRPCEB",35,0) .;quit if already been processed. "RTN","RMPRPCEB",36,0) .Q:$P(RM610,U,12) "RTN","RMPRPCEB",37,0) .Q:(RMSTA="")!('$D(RSTAFLG(RMSTA))) "RTN","RMPRPCEB",38,0) .Q:'$P(RM611,U,4)!'$P(RM600,U,22) "RTN","RMPRPCEB",39,0) .S RMDATE=$P(RM600,U,1),RMDFN=$P(RM600,U,2) "RTN","RMPRPCEB",40,0) .S RMICD9=$P(RM610,U,8) "RTN","RMPRPCEB",41,0) .Q:$D(^TMP($J,RMSTA,RMDATE,RMDFN)) "RTN","RMPRPCEB",42,0) .S RMPROCF=0 "RTN","RMPRPCEB",43,0) .F J=0:0 S J=$O(^RMPR(660,"C",RMDFN,J)) Q:J'>0 D "RTN","RMPRPCEB",44,0) ..S RMJ60=$G(^RMPR(660,J,0)),RMJDT=$P(RMJ60,U,1),RMJST=$P(RMJ60,U,10) "RTN","RMPRPCEB",45,0) ..Q:(RMJST'=RMSTA)!(RMJDT'=RMDATE) "RTN","RMPRPCEB",46,0) ..S RMJ610=$G(^RMPR(660,J,10)),RMJ12=$P(RMJ610,U,12) "RTN","RMPRPCEB",47,0) ..I $G(RMJ12) S RMPROCF=1 "RTN","RMPRPCEB",48,0) .;don't process if PCE data was process for the same day. "RTN","RMPRPCEB",49,0) .Q:$G(RMPROCF) "RTN","RMPRPCEB",50,0) .S ^TMP($J,RMSTA,RMDATE,RMDFN,RI)="" "RTN","RMPRPCEB",51,0) ; "RTN","RMPRPCEB",52,0) D PROC "RTN","RMPRPCEB",53,0) I '$D(^TMP($J,"RMPRERR")) D "RTN","RMPRPCEB",54,0) .S ^TMP($J,"RMPR",5)="***** NO ERROR TO REPORT !!!!!" "RTN","RMPRPCEB",55,0) S RMSUBI=4 D BUILD D:$D(^XMB(3.8,"B","RMPR PCE")) MES1,MES2 "RTN","RMPRPCEB",56,0) G EXIT "RTN","RMPRPCEB",57,0) ; "RTN","RMPRPCEB",58,0) PCEFLG ; "RTN","RMPRPCEB",59,0) S:$D(^RMPR(669.9,RS,"PCE")) RFLDAT=$P($G(^RMPR(669.9,RS,"PCE")),U,2) "RTN","RMPRPCEB",60,0) S:'$D(^RMPR(669.9,RS,"PCE")) RFLDAT=0 "RTN","RMPRPCEB",61,0) S RSTAFLG($P(^RMPR(669.9,RS,0),U,2))=RFLDAT "RTN","RMPRPCEB",62,0) S $P(^RMPR(669.9,RS,"PCE"),U,1)=RMSTDT "RTN","RMPRPCEB",63,0) Q "RTN","RMPRPCEB",64,0) ; "RTN","RMPRPCEB",65,0) PROC ;process "RTN","RMPRPCEB",66,0) F RS=0:0 S RS=$O(^TMP($J,RS)) Q:RS'>0 F RII=0:0 S RII=$O(^TMP($J,RS,RII)) Q:RII'>0 F RJ=0:0 S RJ=$O(^TMP($J,RS,RII,RJ)) Q:RJ'>0 S RK=$O(^TMP($J,RS,RII,RJ,0)) D "RTN","RMPRPCEB",67,0) .;call PCE Interface "RTN","RMPRPCEB",68,0) .S RMIE60RK=RK "RTN","RMPRPCEB",69,0) .S RMC=$$SENDPCE^RMPRPCEA(RK) "RTN","RMPRPCEB",70,0) . I RMC<1 D "RTN","RMPRPCEB",71,0) ..S RSNAM=" " "RTN","RMPRPCEB",72,0) ..I $G(RS),$D(^DIC(4,RS,0)) S RSNAM=$E($P(^DIC(4,RS,0),U,1),1,8) "RTN","RMPRPCEB",73,0) ..S ^TMP($J,"RMPRERR",RK)="Station: "_RSNAM_", File #660 IEN="_RK_" - Error in PCE interface!!!" "RTN","RMPRPCEB",74,0) ..;Added next line for RMPR*3*82 "RTN","RMPRPCEB",75,0) ..I '$G(RMLOC) S ^TMP($J,"RMPRERR",RK)=^TMP($J,"RMPRERR",RK)_$G(RERRMSG)_$G(RERRMSG2) "RTN","RMPRPCEB",76,0) ..I $D(RMPROB($J,1))!$D(RMPROB($J,2)) D "RTN","RMPRPCEB",77,0) ...S (R2,R3,RMMESS)="",R6I=RK,RC=0 "RTN","RMPRPCEB",78,0) ...F R1=0:0 S R1=$O(RMPROB($J,R1)) Q:R1'>0 S RC=RC+1 F S R2=$O(RMPROB($J,R1,"ERROR1",R2)) Q:R2="" F S R3=$O(RMPROB($J,R1,"ERROR1",R2,R3)) Q:R3="" D "RTN","RMPRPCEB",79,0) ....F R4=0:0 S R4=$O(RMPROB($J,R1,"ERROR1",R2,R3,R4)) Q:R4'>0 D "RTN","RMPRPCEB",80,0) .....S RMMESS=RMPROB($J,R1,"ERROR1",R2,R3,R4),RMK=R6I_"."_RC,^TMP($J,"RMPRERR",RMK)=" ???? "_$E(RMMESS,1,65) "RTN","RMPRPCEB",81,0) .....K RMPROB($J,R1,"ERROR1",R2,R3,R4) "RTN","RMPRPCEB",82,0) K RMPROB "RTN","RMPRPCEB",83,0) Q "RTN","RMPRPCEB",84,0) ; "RTN","RMPRPCEB",85,0) MES1 ; "RTN","RMPRPCEB",86,0) S XMY("G.RMPR PCE")="",XMDUZ=.5,XMTEXT="^TMP($J,""RMPR""," "RTN","RMPRPCEB",87,0) S XMSUB="PROSTHETICS PCE BACKGROUND MESSAGE" "RTN","RMPRPCEB",88,0) S ^TMP($J,"RMPR",1)="Run Date: "_RMRDAT "RTN","RMPRPCEB",89,0) S ^TMP($J,"RMPR",2)="This is a notification from the Prosthetics Department........" "RTN","RMPRPCEB",90,0) S ^TMP($J,"RMPR",3)="" "RTN","RMPRPCEB",91,0) S ^TMP($J,"RMPR",4)="" "RTN","RMPRPCEB",92,0) Q "RTN","RMPRPCEB",93,0) MES2 ; "RTN","RMPRPCEB",94,0) S ^TMP($J,"RMPR",RMSUBI+2)="" "RTN","RMPRPCEB",95,0) I $D(^TMP($J,"RMPRERR")) S ^TMP($J,"RMPR",RMSUBI+3)="*** Please contact your PCE Coordinator or IRM ***" "RTN","RMPRPCEB",96,0) I '$D(^TMP($J,"RMPRERR")) S ^TMP($J,"RMPR",RMSUBI+3)="" "RTN","RMPRPCEB",97,0) S ^TMP($J,"RMPR",RMSUBI+4)="" "RTN","RMPRPCEB",98,0) S ^TMP($J,"RMPR",RMSUBI+5)="Thank You!!!" "RTN","RMPRPCEB",99,0) S ^TMP($J,"RMPR",RMSUBI+6)="" "RTN","RMPRPCEB",100,0) S ^TMP($J,"RMPR",RMSUBI+7)="PROSTHETICS DEPARTMENT" "RTN","RMPRPCEB",101,0) D ^XMD "RTN","RMPRPCEB",102,0) D NOW^%DTC "RTN","RMPRPCEB",103,0) ;if task finish to completion and; "RTN","RMPRPCEB",104,0) ;if no errors, set the PCE end date of the background job in #669.9. "RTN","RMPRPCEB",105,0) F RS=0:0 S RS=$O(^RMPR(669.9,RS)) Q:RS'>0 S $P(^RMPR(669.9,RS,"PCE"),U,2)=% "RTN","RMPRPCEB",106,0) Q "RTN","RMPRPCEB",107,0) ; "RTN","RMPRPCEB",108,0) BUILD ; "RTN","RMPRPCEB",109,0) F I=0:0 S I=$O(^TMP($J,"RMPRERR",I)) Q:I'>0 D "RTN","RMPRPCEB",110,0) .S RMMAIL=^TMP($J,"RMPRERR",I) "RTN","RMPRPCEB",111,0) .S RMSUBI=RMSUBI+1 "RTN","RMPRPCEB",112,0) .S ^TMP($J,"RMPR",RMSUBI)=RMMAIL "RTN","RMPRPCEB",113,0) Q "RTN","RMPRPCEB",114,0) ; "RTN","RMPRPCEB",115,0) EXIT ;MAIN EXIT POINT "RTN","RMPRPCEB",116,0) K ^TMP($J) "RTN","RMPRPCEB",117,0) N RMPRSITE,RMPR D KILL^XUSCLEAN "RTN","RMPRPCEB",118,0) Q "VER") 8.0^22.0 "BLD",5915,6) ^SEQ #90 **END** **END**