Released RMPR*3*178 SEQ #159 Extracted from mail message **KIDS**:RMPR*3.0*178^ **INSTALL NAME** RMPR*3.0*178 "BLD",9398,0) RMPR*3.0*178^PROSTHETICS^0^3160802^y "BLD",9398,4,0) ^9.64PA^^ "BLD",9398,6.3) 14 "BLD",9398,"ABPKG") n "BLD",9398,"INIT") EN^RMPR178P "BLD",9398,"KRN",0) ^9.67PA^779.2^20 "BLD",9398,"KRN",.4,0) .4 "BLD",9398,"KRN",.401,0) .401 "BLD",9398,"KRN",.402,0) .402 "BLD",9398,"KRN",.403,0) .403 "BLD",9398,"KRN",.5,0) .5 "BLD",9398,"KRN",.84,0) .84 "BLD",9398,"KRN",3.6,0) 3.6 "BLD",9398,"KRN",3.8,0) 3.8 "BLD",9398,"KRN",9.2,0) 9.2 "BLD",9398,"KRN",9.8,0) 9.8 "BLD",9398,"KRN",9.8,"NM",0) ^9.68A^2^2 "BLD",9398,"KRN",9.8,"NM",1,0) RMPRSTL^^0^B24867541 "BLD",9398,"KRN",9.8,"NM",2,0) RMPRSTK^^0^B62842699 "BLD",9398,"KRN",9.8,"NM","B","RMPRSTK",2) "BLD",9398,"KRN",9.8,"NM","B","RMPRSTL",1) "BLD",9398,"KRN",19,0) 19 "BLD",9398,"KRN",19,"NM",0) ^9.68A^2^2 "BLD",9398,"KRN",19,"NM",1,0) RMPR PURCHASING MENU^^2 "BLD",9398,"KRN",19,"NM",2,0) RMPR GIP STOCK^^0^ "BLD",9398,"KRN",19,"NM","B","RMPR GIP STOCK",2) "BLD",9398,"KRN",19,"NM","B","RMPR PURCHASING MENU",1) "BLD",9398,"KRN",19.1,0) 19.1 "BLD",9398,"KRN",19.1,"NM",0) ^9.68A^^ "BLD",9398,"KRN",101,0) 101 "BLD",9398,"KRN",409.61,0) 409.61 "BLD",9398,"KRN",771,0) 771 "BLD",9398,"KRN",779.2,0) 779.2 "BLD",9398,"KRN",870,0) 870 "BLD",9398,"KRN",8989.51,0) 8989.51 "BLD",9398,"KRN",8989.52,0) 8989.52 "BLD",9398,"KRN",8994,0) 8994 "BLD",9398,"KRN","B",.4,.4) "BLD",9398,"KRN","B",.401,.401) "BLD",9398,"KRN","B",.402,.402) "BLD",9398,"KRN","B",.403,.403) "BLD",9398,"KRN","B",.5,.5) "BLD",9398,"KRN","B",.84,.84) "BLD",9398,"KRN","B",3.6,3.6) "BLD",9398,"KRN","B",3.8,3.8) "BLD",9398,"KRN","B",9.2,9.2) "BLD",9398,"KRN","B",9.8,9.8) "BLD",9398,"KRN","B",19,19) "BLD",9398,"KRN","B",19.1,19.1) "BLD",9398,"KRN","B",101,101) "BLD",9398,"KRN","B",409.61,409.61) "BLD",9398,"KRN","B",771,771) "BLD",9398,"KRN","B",779.2,779.2) "BLD",9398,"KRN","B",870,870) "BLD",9398,"KRN","B",8989.51,8989.51) "BLD",9398,"KRN","B",8989.52,8989.52) "BLD",9398,"KRN","B",8994,8994) "BLD",9398,"QDEF") ^^^^^^^^^^YES "BLD",9398,"QUES",0) ^9.62^^ "BLD",9398,"REQB",0) ^9.611^2^2 "BLD",9398,"REQB",1,0) RMPR*3.0*41^2 "BLD",9398,"REQB",2,0) RMPR*3.0*45^2 "BLD",9398,"REQB","B","RMPR*3.0*41",1) "BLD",9398,"REQB","B","RMPR*3.0*45",2) "INIT") EN^RMPR178P "KRN",19,5636,-1) 2^1 "KRN",19,5636,0) RMPR PURCHASING MENU^Purchasing^^M^.5^^^^^^^101^^1 "KRN",19,5636,10,0) ^19.01IP^26^25 "KRN",19,5636,10,26,0) 13522^GI^3 "KRN",19,5636,10,26,"^") RMPR GIP STOCK "KRN",19,5636,"U") PURCHASING "KRN",19,13522,-1) 0^2 "KRN",19,13522,0) RMPR GIP STOCK^Generic Inventory (GIP) Stock Issues^^R^^^^^^^^PROSTHETICS^^^ "KRN",19,13522,1,0) ^^7^7^3160311^ "KRN",19,13522,1,1,0) This option provides the capability to issue prosthetics stock that is "KRN",19,13522,1,2,0) maintained by the IFCAP Generic Inventory Package (GIP). This option "KRN",19,13522,1,3,0) will automatically update inventory in IFCAP GIP. However, when the "KRN",19,13522,1,4,0) items issued are from an INVENTORY POINT that is linked to a Point of "KRN",19,13522,1,5,0) Use (POU) supply cabinet then this option does not update the inventory, "KRN",19,13522,1,6,0) since these are special cabinets that automatically update GIP inventory "KRN",19,13522,1,7,0) balances, via HL7 messaging, when stock is removed. "KRN",19,13522,10.1) GIP Issue Stock "KRN",19,13522,15) "KRN",19,13522,25) RMPRSTK "KRN",19,13522,"U") GENERIC INVENTORY (GIP) STOCK "MBREQ") 0 "ORD",18,19) 19;18;;;OPT^XPDTA;OPTF1^XPDIA;OPTE1^XPDIA;OPTF2^XPDIA;;OPTDEL^XPDIA "ORD",18,19,0) OPTION "PKG",101,-1) 1^1 "PKG",101,0) PROSTHETICS^RMPR^PROSTHETICS VERSION 3.0 ALPHA "PKG",101,20,0) ^9.402P^^0 "PKG",101,22,0) ^9.49I^1^1 "PKG",101,22,1,0) 3.0^2960209^2960214 "PKG",101,22,1,"PAH",1,0) 178^3160802 "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") NO "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") NO "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") 3 "RTN","RMPR178P") 0^^B12159958^n/a "RTN","RMPR178P",1,0) RMPR178P ;CEP-JAH/OIFO - PATCH 178 POST INSTALLATION ;02/26/16 "RTN","RMPR178P",2,0) ;;3.0;Prosthetics;**178**;13/27/08;Build 14 "RTN","RMPR178P",3,0) ;; "RTN","RMPR178P",4,0) Q "RTN","RMPR178P",5,0) EN ; "RTN","RMPR178P",6,0) D MSG("Starting Post Install") ;TODO: IS THIS NEEDED? "RTN","RMPR178P",7,0) D MSG("Checking for existance of PRGIP Site Parameter") "RTN","RMPR178P",8,0) I '$$FIND1^DIC(8989.51,"","","PRGIP","","","RMPRERR") D Q "RTN","RMPR178P",9,0) . D MSG("PRGIP Site Parameter does not exist - Good To Go!") "RTN","RMPR178P",10,0) D MSG("Removing PRGIP Site Parameter") "RTN","RMPR178P",11,0) D XPARDEL("PRGIP",0) "RTN","RMPR178P",12,0) Q "RTN","RMPR178P",13,0) ; "RTN","RMPR178P",14,0) MSG(TEXT) ; [Procedure] Display message to user "RTN","RMPR178P",15,0) ; Input parameters "RTN","RMPR178P",16,0) ; 1. TEXT [Literal/Required] Text to display to the user "RTN","RMPR178P",17,0) ; "RTN","RMPR178P",18,0) D BMES^XPDUTL(" "_TEXT_"...") "RTN","RMPR178P",19,0) Q "" "RTN","RMPR178P",20,0) ; "RTN","RMPR178P",21,0) XPARDEL(RMPRPAR,VALUES) ; [Procedure] Remove a parameter for XPAR "RTN","RMPR178P",22,0) ; VALUES determines the mode of deletion. "RTN","RMPR178P",23,0) ; 0: Will delete *BOTH* the values and the parameter definition (DEFAULT) "RTN","RMPR178P",24,0) ; 1: Will only delete the values of the parameter "RTN","RMPR178P",25,0) ; "RTN","RMPR178P",26,0) ; Input parameters "RTN","RMPR178P",27,0) ; 1. RMPRPAR [Literal/Required] Name of the parameter definition "RTN","RMPR178P",28,0) ; 2. VALUES [Literal/] Values Only 0/1 "RTN","RMPR178P",29,0) ; "RTN","RMPR178P",30,0) ; Variables: "RTN","RMPR178P",31,0) ; DA: [Private] Fileman variable "RTN","RMPR178P",32,0) ; DIK: [Private] Fileman variable "RTN","RMPR178P",33,0) ; RMPRENT: [Private] Parameter entity "RTN","RMPR178P",34,0) NEW DA,DIK,RMPRENT,RMPRERR "RTN","RMPR178P",35,0) S VALUES=$G(VALUES,0) "RTN","RMPR178P",36,0) K ^TMP("RMPRPOST",$J) "RTN","RMPR178P",37,0) D ENVAL^XPAR($NA(^TMP("RMPRPOST",$J)),RMPRPAR,"","",1) "RTN","RMPR178P",38,0) S RMPRENT="" F S RMPRENT=$O(^TMP("RMPRPOST",$J,RMPRENT)) Q:RMPRENT="" D "RTN","RMPR178P",39,0) . D NDEL^XPAR(RMPRENT,RMPRPAR,.RMPRERR) "RTN","RMPR178P",40,0) . I +$G(RMPRERR) D "RTN","RMPR178P",41,0) .. D MSG(RMPRPAR_": "_RMPRERR) "RTN","RMPR178P",42,0) . E D "RTN","RMPR178P",43,0) .. D MSG(RMPRPAR_" Site Parameter Value was deleted") "RTN","RMPR178P",44,0) Q:VALUES "RTN","RMPR178P",45,0) S DA=$$FIND1^DIC(8989.51,"","",RMPRPAR,"B") "RTN","RMPR178P",46,0) I DA'>0 D MSG(RMPRPAR_" Site Parameter Definition was not found") Q "RTN","RMPR178P",47,0) S DIK="^XTV(8989.51," D ^DIK "RTN","RMPR178P",48,0) D MSG(RMPRPAR_" Site Parameter Definition was deleted") "RTN","RMPR178P",49,0) Q "RTN","RMPR178P",50,0) ; "RTN","RMPR178P",51,0) ;ALL BELOW FOR TESTING PURPOSES ONLY "RTN","RMPR178P",52,0) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; "RTN","RMPR178P",53,0) PRGIPDEF ;ADDS PRGIP PARAMETER DEFINITION "RTN","RMPR178P",54,0) ;FOR TESTING PURPOSES ONLY "RTN","RMPR178P",55,0) ;SOME SITES ADDED PRGIP SITE PARAMETER THAT NOW NEEDS TO BE DELETED "RTN","RMPR178P",56,0) ;THIS FUNCTION CREATES THE SITE PARAMETER TO FACILITATE TESTING ITS DELETION "RTN","RMPR178P",57,0) ;;;;;;;;;; "RTN","RMPR178P",58,0) I $$FIND1^DIC(8989.51,"","","PRGIP","","","RMPRERR") D Q "RTN","RMPR178P",59,0) . D MSG("PARAMETER VALUE ALREADY EXISTED") "RTN","RMPR178P",60,0) N RMPR,RMPRIEN,RMPRMSG "RTN","RMPR178P",61,0) S RMPR(8989.51,"+1,",.01)="PRGIP" "RTN","RMPR178P",62,0) S RMPR(8989.51,"+1,",.02)="Prosthetics GIP IN USE SITE PARAMETER" "RTN","RMPR178P",63,0) S RMPR(8989.51,"+1,",.03)=0 "RTN","RMPR178P",64,0) S RMPR(8989.51,"+1,",.06)=0 "RTN","RMPR178P",65,0) S RMPR(8989.51,"+1,",1.1)="Y" "RTN","RMPR178P",66,0) D UPDATE^DIE("","RMPR","RMPRIEN","RMPRMSG") "RTN","RMPR178P",67,0) D MSG($G(RMPRMSG)) "RTN","RMPR178P",68,0) Q "RTN","RMPR178P",69,0) SETPAR(PAR,INS,VAL,ERR) ; [Procedure] Set value into XPAR parameter "RTN","RMPR178P",70,0) ; Input parameters "RTN","RMPR178P",71,0) ; NOT PART OF P178 BUT INCLUDED FOR TESTING PURPOSES FOR ADDING "PRGIP" SITE PARAM "RTN","RMPR178P",72,0) ; 1. PAR [Literal/Required] Parameter "RTN","RMPR178P",73,0) ; 2. INS [Literal/Required] Instance "RTN","RMPR178P",74,0) ; 3. VAL [Literal/Required] New value "RTN","RMPR178P",75,0) ; 4. ERR (CALL BY REF) ERROR ARRAY "RTN","RMPR178P",76,0) ; "RTN","RMPR178P",77,0) D EN^XPAR("SYS",PAR,INS,VAL,.ERR) "RTN","RMPR178P",78,0) Q "RTN","RMPR178P",79,0) ; "RTN","RMPRSTK") 0^2^B62842699^B48665872 "RTN","RMPRSTK",1,0) RMPRSTK ;PHX/RFM,RVD-ISSUE FROM STOCK ;8/29/1994 "RTN","RMPRSTK",2,0) ;;3.0;PROSTHETICS;**12,13,16,19,21,26,28,33,41,45,178**;Feb 09, 1996;Build 14 "RTN","RMPRSTK",3,0) ;JAH-p178-add caution msg to user if selected site not GIP flagged "RTN","RMPRSTK",4,0) S (RMPRG,RMPRF)="" "RTN","RMPRSTK",5,0) D HOME^%ZIS W @IOF "RTN","RMPRSTK",6,0) I '$D(RMPR) D DIV4^RMPRSIT G:$D(X) EXIT^RMPRSTL "RTN","RMPRSTK",7,0) ; check pre-requisites--Option won't run if DYNAMED is setup and "RTN","RMPRSTK",8,0) ; give a single caution if GIP flag is not set. "RTN","RMPRSTK",9,0) ; "RTN","RMPRSTK",10,0) I $$DYNAMED() D EXIT^RMPRSTL Q "RTN","RMPRSTK",11,0) D CAUTION($G(RMPRSITE),$G(RMPR("NAME"))) "RTN","RMPRSTK",12,0) I $D(RMPRDFN) D LINK^RMPRS "RTN","RMPRSTK",13,0) D GETPAT^RMPRUTIL G:'$D(RMPRDFN) EXIT^RMPRSTL "RTN","RMPRSTK",14,0) VIEW N RMPRBAC1,RMDES "RTN","RMPRSTK",15,0) S RMPRBAC1=1 D ^RMPRPAT K RMPRBAC1 "RTN","RMPRSTK",16,0) I $D(RMPRKILL)!($D(DTOUT)) W $C(7),!,"Deleted..." G EXIT^RMPRSTL "RTN","RMPRSTK",17,0) S CK="W:$D(DUOUT) @IOF,!!!?28,$C(7),""Deleted..."" G EXIT^RMPRSTL" "RTN","RMPRSTK",18,0) S CK1="W $C(7),!,""Timed-Out, Deleted..."" G EXIT^RMPRSTL" "RTN","RMPRSTK",19,0) S R3("D")="" "RTN","RMPRSTK",20,0) RES ;ENTRY POINT TO ADD ADDITIONAL ITEMS FOR ISSUE FROM STOCK "RTN","RMPRSTK",21,0) ;I RMPRG]"" D LINK^RMPRS "RTN","RMPRSTK",22,0) Q:$G(RMPRDFN)<1 "RTN","RMPRSTK",23,0) K PRCP("ITEM"),DA,DD,DIC,PRC,X,Y,RMSO,RMQTY,RMHCPC,RMLOC,RMLACO,RMITDA,RMINVF,RMSAL "RTN","RMPRSTK",24,0) S R1(0)=DT_U_RMPRDFN_U_DT,$P(R1(0),U,10)=RMPR("STA"),$P(R1(0),U,27)=DUZ "RTN","RMPRSTK",25,0) S (R1(1),R3("D"),R4("D"),R1("AM"),RMPRI("AMS"),R1("D"))="" "RTN","RMPRSTK",26,0) S DIR("?")="Enter V for VA or C for Commercial" "RTN","RMPRSTK",27,0) S RMINVF="OTHER" "RTN","RMPRSTK",28,0) 1 ;ENTRY POINT TO EDIT ITEM ON ISSUE FROM STOCK "RTN","RMPRSTK",29,0) K RMPRGIP,PRCP("ITEM"),RMPRIP,RMITFLG S RMPREVHC=$P(R1(1),U,4) "RTN","RMPRSTK",30,0) S DIR(0)="SBO^V:VA;C:COMMERCIAL",DIR("A")="Select VA or COMMERCIAL SOURCE" S:$P(R3("D"),U,14)?.A&($P(R3("D"),U,14)'="") DIR("B")=$P(R3("D"),U,14) "RTN","RMPRSTK",31,0) W @IOF,!?30,RMPRNAM,! D ^DIR I $P(R3("D"),U,14)?1A.A&($D(DUOUT)) G LIST^RMPRSTL "RTN","RMPRSTK",32,0) I $D(DTOUT) X CK1 Q "RTN","RMPRSTK",33,0) G:X="" ^RMPRSTK G:$D(DUOUT) ^RMPRSTK I $D(DIRUT) X CK Q "RTN","RMPRSTK",34,0) S $P(R1(0),U,14)=Y,RMSO=Y K DIR I Y["V" S $P(R1(0),U,16)=0 "RTN","RMPRSTK",35,0) S $P(R3("D"),U,14)=$S(Y="C":"COMMERCIAL",Y="V":"VA",1:"") "RTN","RMPRSTK",36,0) TRAN ;TYPE OF TRANSACTION "RTN","RMPRSTK",37,0) W ! S DIR(0)="660,2" S:$P(R1(0),U,4)?.E&($P(R3("D"),U,4)'="") DIR("B")=$P(R3("D"),U,4) D ^DIR I $P(R3("D"),U,4)'=""&($D(DUOUT)) G LIST^RMPRSTL "RTN","RMPRSTK",38,0) I $D(DTOUT) X CK1 Q "RTN","RMPRSTK",39,0) I $D(DIRUT) X CK Q "RTN","RMPRSTK",40,0) S $P(R1(0),U,4)=Y K DIR "RTN","RMPRSTK",41,0) S $P(R3("D"),U,4)=$S(Y="I":"INITIAL ISSUE",Y="X":"REPAIR",Y="R":"REPLACE",Y="S":"SPARE",1:"") "RTN","RMPRSTK",42,0) ; "RTN","RMPRSTK",43,0) PCAT S DIR(0)="660,62" S:$P(R1("AM"),U,3)?1N.N DIR("B")=$P(R4("D"),U,3) D ^DIR I $P(R1("AM"),U,3)'=""&($D(DUOUT)) G LIST^RMPRSTL "RTN","RMPRSTK",44,0) I $D(DTOUT) X CK1 Q "RTN","RMPRSTK",45,0) I $D(DIRUT) X CK Q "RTN","RMPRSTK",46,0) S $P(R1("AM"),U,3)=Y,$P(R4("D"),U,3)=$S(Y=1:"SC/OP",Y=2:"SC/IP",Y=3:"NSC/IP",Y=4:"NSC/OP",1:"") K DIR "RTN","RMPRSTK",47,0) I Y<4 S $P(R1("AM"),U,4)="",$P(R4("D"),U,4)="" G 2 "RTN","RMPRSTK",48,0) SPE I Y=4 S DIR(0)="660,63" S:$P(R1("AM"),U,4)?1N.N DIR("B")=$P(R4("D"),U,4) D ^DIR I $D(DTOUT) X CK1 Q "RTN","RMPRSTK",49,0) G:$D(DIRUT) 2 "RTN","RMPRSTK",50,0) I $P(R1("AM"),U,3)=4 S $P(R1("AM"),U,4)=Y,$P(R4("D"),U,4)=$S(Y=1:"SPECIAL LEGISLATION",Y=2:"A&A",Y=3:"PHC",Y=4:"ELIGIBILITY REFORM",1:"") "RTN","RMPRSTK",51,0) ; "RTN","RMPRSTK",52,0) 2 S DIC(0)="AEQM",DIC=661 S:$P(R1(0),U,6) DIC("B")=$P(^RMPR(661,$P(R1(0),U,6),0),U) S DIC("A")="ITEM: " "RTN","RMPRSTK",53,0) K DIC("S") D ^DIC "RTN","RMPRSTK",54,0) I $P(R3("D"),U,6)&$D(DUOUT) G LIST^RMPRSTL "RTN","RMPRSTK",55,0) I $D(DUOUT) X CK Q "RTN","RMPRSTK",56,0) I $D(DTOUT) X CK1 Q "RTN","RMPRSTK",57,0) I +Y'>0 W !!,?5,$C(7),"This is a required response. Enter '^' to exit",! G 2 "RTN","RMPRSTK",58,0) S $P(R1(0),U,6)=+Y,$P(R3("D"),U,6)=$P(Y,U,2) K DIC,Y,X "RTN","RMPRSTK",59,0) HCPCS ;HCPCS code "RTN","RMPRSTK",60,0) K DIC "RTN","RMPRSTK",61,0) S DIC(0)="AEQM",DIC="^RMPR(661.1,",DIC("A")="PSAS HCPCS: " S:$P(R1(1),U,4) DIC("B")=$P(R1(1),U,4) D ^DIC I $P(R1(1),U,4)'=""&($D(DUOUT)) G LIST^RMPRSTL "RTN","RMPRSTK",62,0) I $D(DTOUT) X CK1 Q "RTN","RMPRSTK",63,0) I $D(DUOUT) X CK Q "RTN","RMPRSTK",64,0) I Y=-1 W !,"HCPCS CODE IS MANDATORY!" G HCPCS "RTN","RMPRSTK",65,0) I +Y>0 G:$P(^RMPR(661.1,+Y,0),U,5)'=1 HCPCS S RMHCPC=+Y "RTN","RMPRSTK",66,0) S RDA=RMHCPC_"^"_$P(R1(0),U,4)_"^"_$P(R1(0),U,14)_"^"_660 "RTN","RMPRSTK",67,0) D:$D(RMCPT) CHK^RMPRED5 "RTN","RMPRSTK",68,0) W:$G(REDIT) !,"OLD CPT MODIFIER: ",$P(R1(1),U,6) "RTN","RMPRSTK",69,0) I RMPREVHC'=RMHCPC D CPT^RMPRCPTU(RDA) G:$D(DUOUT)!$D(DTOUT) LIST^RMPRSTL S $P(R1(1),U,6)=$G(RMCPT) W:$G(REDIT) !,"NEW CPT MODIFIER: ",$G(RMCPT) "RTN","RMPRSTK",70,0) I RMPREVHC'="",(RMPREVHC=RMHCPC),$G(REDIT) D "RTN","RMPRSTK",71,0) .S DIR(0)="Y",DIR("A")="Would you like to Edit CPT MODIFIER Entry ",DIR("B")="N" D ^DIR Q:$D(DTOUT)!$D(DUOUT) "RTN","RMPRSTK",72,0) .I $G(Y) D CPT^RMPRCPTU(RDA) Q:$D(DTOUT)!$D(DUOUT) S $P(R1(1),U,6)=$G(RMCPT) W !,"NEW CPT MODIFIER: ",$G(RMCPT) "RTN","RMPRSTK",73,0) ; "RTN","RMPRSTK",74,0) LOCDIC I $P(^RMPR(661.1,RMHCPC,0),U,9)'=1 S RMINVF="OTHER" K RMLOC,RMITDA "RTN","RMPRSTK",75,0) I $P(^RMPR(661.1,RMHCPC,0),U,9)=1 D ITEMLOC^RMPR5NU1 "RTN","RMPRSTK",76,0) I $P(R1(1),U,4)'="",$D(DUOUT),$G(RMITFLG) G LIST^RMPRSTL "RTN","RMPRSTK",77,0) I $P(R1(1),U,4)="",$D(DUOUT) X CK Q "RTN","RMPRSTK",78,0) I $G(RMLOC),'($G(RMHCDA)&$G(RMITDA)) W !,"PSAS Item was not selected!!" G LOCDIC "RTN","RMPRSTK",79,0) K DIC "RTN","RMPRSTK",80,0) G:'$D(RMLOC) GI "RTN","RMPRSTK",81,0) S RMPRGIP=0 W ! G:RMLOC VEN0 "RTN","RMPRSTK",82,0) ; "RTN","RMPRSTK",83,0) GI I $P(^RMPR(669.9,RMPRSITE,0),U,3),'$D(^PRCP(445,"AD",DUZ)) W $C(7),!,"You are not an authorized user of any Inventory Point, please see your ADPAC." H 2 G EXIT^RMPRSTL "RTN","RMPRSTK",84,0) S RMPRGIP=$P(^RMPR(669.9,RMPRSITE,0),U,3),RMPRF=$S(+RMPRGIP=0:"11",+RMPRGIP=1:"12"),$P(R1(0),U,13)=RMPRF I RMPRGIP S PRCPPRIV=1 G INV "RTN","RMPRSTK",85,0) ; "RTN","RMPRSTK",86,0) VEN K DIC("S"),DIC("B") "RTN","RMPRSTK",87,0) S X=" ",DIC=440,DIC(0)="ZM" D ^DIC S:+Y>0 DIC("B")=$P(^PRC(440,+Y,0),U,1) "RTN","RMPRSTK",88,0) S RO=0 I $O(^PRC(441,$P(R3("D"),U,6),2,RO))'=""&($P(R1(0),U,9)="") S DIC("B")=$O(^PRC(441,$P(R3("D"),U,6),2,RO)) "RTN","RMPRSTK",89,0) ; "RTN","RMPRSTK",90,0) VEN0 ;set HCPCS when PSAS required fields are set "RTN","RMPRSTK",91,0) S $P(R1(1),U,4)=RMHCPC,$P(R1(0),U,22)=$P(^RMPR(661.1,RMHCPC,0),U,4) "RTN","RMPRSTK",92,0) I $P(R3("D"),U,9)'=""&$G(RMITFLG) G LIST^RMPRSTL "RTN","RMPRSTK",93,0) I $G(RMITFLG) X CK Q "RTN","RMPRSTK",94,0) I $D(RMLOC),$D(RMVEN),'$D(DIC("B")) S DIC("B")=RMVEN "RTN","RMPRSTK",95,0) S DIC(0)="AEQM",DIC=440,DIC("A")="VENDOR: " S:$P(R1(0),U,9) DIC("B")=$P(R1(0),U,9) D ^DIC I $P(R3("D"),U,9)'=""&$D(DUOUT) G LIST^RMPRSTL "RTN","RMPRSTK",96,0) I $D(DTOUT) X CK1 Q "RTN","RMPRSTK",97,0) I $D(DUOUT) X CK Q "RTN","RMPRSTK",98,0) I +Y'>0 W !!,?5,$C(7),"This is a required response. Enter '^' to exit",! G VEN "RTN","RMPRSTK",99,0) S $P(R1(0),U,9)=+Y,$P(R3("D"),U,9)=$P(Y,U,2) K DIC,Y,X "RTN","RMPRSTK",100,0) G ^RMPRSTL "RTN","RMPRSTK",101,0) ; "RTN","RMPRSTK",102,0) INV S DIC="^PRCP(445,",DIC(0)="AEQM",DIC("S")="I $P(^(0),U,2)=""Y"",$D(^PRCP(445,+Y,4,DUZ,0))" S:$D(RMPRIP) DIC("B")=RMPRIP "RTN","RMPRSTK",103,0) INDIC D ^DIC I $G(REDIT),$D(DUOUT) G LIST^RMPRSTL "RTN","RMPRSTK",104,0) I $D(DUOUT) X CK Q "RTN","RMPRSTK",105,0) I $D(DTOUT) X CK1 Q "RTN","RMPRSTK",106,0) I +Y'>0 W !!,?5,$C(7),"This is a required response. Enter '^' to exit",! G INDIC "RTN","RMPRSTK",107,0) S (PRCP("I"),RMPRIP)=+Y,PRCP("ITEM")=$P(R3("D"),U,6) "RTN","RMPRSTK",108,0) INVITEM I $D(^PRCP(445,PRCP("I"),1,PRCP("ITEM"),0)) G GIP "RTN","RMPRSTK",109,0) W !!,"*** ITEM IS NOT IN GIP......." "RTN","RMPRSTK",110,0) K DIC W ! S DIC="^RMPR(661," "RTN","RMPRSTK",111,0) S DIC("S")="S PRCP(""ITEM"")=$P(^(0),U,1) I $D(^PRCP(445,PRCP(""I""),1,PRCP(""ITEM""),0))" "RTN","RMPRSTK",112,0) S DIC(0)="AEQM",DIC("A")="ITEM: " "RTN","RMPRSTK",113,0) ITDIC D ^DIC I $G(REDIT),$D(DUOUT) G LIST^RMPRSTL "RTN","RMPRSTK",114,0) I $D(DTOUT) X CK1 Q "RTN","RMPRSTK",115,0) I $D(DUOUT) X CK Q "RTN","RMPRSTK",116,0) I +Y'>0 W !!,?5,$C(7),"This is a required response. Enter '^' to exit",! G ITDIC "RTN","RMPRSTK",117,0) ; "RTN","RMPRSTK",118,0) S $P(R1(0),U,6)=+Y,$P(R3("D"),U,6)=$P(Y,U,2) "RTN","RMPRSTK",119,0) S PRCP("ITEM")=$P(R3("D"),U,6) K DIC("S") "RTN","RMPRSTK",120,0) GIP ;gip on "RTN","RMPRSTK",121,0) S RMPRUCST=0 I $P(R1(0),U,14)["C" S $P(R1(0),U,16)=$P(^PRCP(445,PRCP("I"),1,PRCP("ITEM"),0),U,15),RMPRUCST=$P(R1(0),U,16) I $P(R1(0),U,7) S $P(R1(0),U,16)=$P(R1(0),U,16)*$P(R1(0),U,7) "RTN","RMPRSTK",122,0) ;if cost is null,0, prompt for cost "RTN","RMPRSTK",123,0) I RMPRUCST'>0 D "RTN","RMPRSTK",124,0) .K DIR "RTN","RMPRSTK",125,0) .S DIR(0)="667.3,3" "RTN","RMPRSTK",126,0) .S DIR("A")="UNIT COST" "RTN","RMPRSTK",127,0) .D ^DIR "RTN","RMPRSTK",128,0) .K DIR "RTN","RMPRSTK",129,0) .Q:$D(DUOUT)!($D(DTOUT)) "RTN","RMPRSTK",130,0) .S RMPRUCST=Y "RTN","RMPRSTK",131,0) S RMINVF="GIP" "RTN","RMPRSTK",132,0) V I $P(^PRCP(445,PRCP("I"),0),U,3)="P",+$P(^PRCP(445,PRCP("I"),1,PRCP("ITEM"),0),U,12),$D(^PRC(440,+$P(^(0),U,12),0)),$P(R1(0),U,9)="" S $P(R1(0),U,9)=+$P(^PRCP(445,PRCP("I"),1,PRCP("ITEM"),0),U,12) "RTN","RMPRSTK",133,0) I $P(^PRCP(445,PRCP("I"),0),U,3)="S" D "RTN","RMPRSTK",134,0) .I $P(R1(0),U,9)="" K DIC S DIC="^PRCP(445,",DIC(0)="N",X=+$P(^PRCP(445,PRCP("I"),1,PRCP("ITEM"),0),U,12) D ^DIC Q:+Y<0 I $D(^PRCP(445,+Y,1,PRCP("ITEM"),0)) D "RTN","RMPRSTK",135,0) ..S RMPRVEN=+$P(^PRCP(445,+$P(^PRCP(445,PRCP("I"),1,PRCP("ITEM"),0),U,12),1,PRCP("ITEM"),0),U,12) I $D(^PRC(440,+RMPRVEN,0)) S $P(R1(0),U,9)=RMPRVEN "RTN","RMPRSTK",136,0) ; "RTN","RMPRSTK",137,0) DEF S X=" ",DIC=440,DIC(0)="ZM" D ^DIC S:+Y>0 DIC("B")=$P(^PRC(440,+Y,0),U,1) "RTN","RMPRSTK",138,0) G VEN "RTN","RMPRSTK",139,0) ; "RTN","RMPRSTK",140,0) HCPCG ;HCPCS code with GIP "RTN","RMPRSTK",141,0) K DIC "RTN","RMPRSTK",142,0) S DIC(0)="AEQM",DIC="^RMPR(661.1,",DIC("A")="PSAS HCPCS: " S:$P(R1(1),U,4) DIC("B")=$P(R1(1),U,4) D ^DIC "RTN","RMPRSTK",143,0) I $D(DTOUT) X CK1 Q "RTN","RMPRSTK",144,0) I $D(DUOUT) X CK Q "RTN","RMPRSTK",145,0) I Y=-1 W !,"HCPCS CODE IS MANDATORY!" G HCPCG "RTN","RMPRSTK",146,0) I +Y>0 G:$P(^RMPR(661.1,+Y,0),U,5)'=1 HCPCS S $P(R1(1),U,4)=+Y,$P(R1(0),U,22)=$P(^RMPR(661.1,+Y,0),U,4) "RTN","RMPRSTK",147,0) S RMHCPC=+Y I $P(^RMPR(661.1,+Y,0),U,9)=1 D ITEMLOC^RMPR5NU1 I '$D(RMLOC) X CK Q "RTN","RMPRSTK",148,0) Q "RTN","RMPRSTK",149,0) CAUTION(SELSITE,NAME) ; issue a caution message only once during the option "RTN","RMPRSTK",150,0) ; if GIP flag is not set for this division "RTN","RMPRSTK",151,0) Q:$G(SELSITE)'>0 "RTN","RMPRSTK",152,0) Q:+$G(^TMP($J,"RMRP CAUTION")) "RTN","RMPRSTK",153,0) Q:+$P(^RMPR(669.9,SELSITE,0),U,3) "RTN","RMPRSTK",154,0) ; "RTN","RMPRSTK",155,0) W !!,"CAUTION: This option is intended for use with GIP Inventory." "RTN","RMPRSTK",156,0) W !," The Prosthetics Site Parameter [AUTOMATED INVENTORY (GIP)]" "RTN","RMPRSTK",157,0) W !," is not set to 'YES' for the selected site, ",NAME,".",! "RTN","RMPRSTK",158,0) N X S X=$$ASK(1) "RTN","RMPRSTK",159,0) S ^TMP($J,"RMRP CAUTION")=1 "RTN","RMPRSTK",160,0) Q "RTN","RMPRSTK",161,0) DYNAMED() ; If this system is flagged as using DYNAMED for inventory, "RTN","RMPRSTK",162,0) ; then inform user and then quit. "RTN","RMPRSTK",163,0) ; DBIA 6394--Lookup DynaMed flag in IFCAP Sys param. Sites using "RTN","RMPRSTK",164,0) ; DynaMed will continue to use Prosthetics Inventory Package (PIP) "RTN","RMPRSTK",165,0) ; until a better solution is devised. "RTN","RMPRSTK",166,0) ; "RTN","RMPRSTK",167,0) N SYSINV "RTN","RMPRSTK",168,0) S SYSINV=$$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q") "RTN","RMPRSTK",169,0) I SYSINV&($E(IOST,1,2)="C-") D "RTN","RMPRSTK",170,0) . W !!,"This system is flagged as using DYNAMED Inventory." "RTN","RMPRSTK",171,0) . W !,"You can not use GIP for Prosthetics." "RTN","RMPRSTK",172,0) . W !,"Please contact your Application Coordinator.",! "RTN","RMPRSTK",173,0) . N X S X=$$ASK(1) "RTN","RMPRSTK",174,0) Q +SYSINV "RTN","RMPRSTK",175,0) ; "RTN","RMPRSTK",176,0) ASK(HOLD) ;ask user 2 continue function "RTN","RMPRSTK",177,0) ;return true (1) if user want's 2 stop, false (0) 2 continue. "RTN","RMPRSTK",178,0) ;If HOLD defined, use prompt 2 hold display until user hits return. "RTN","RMPRSTK",179,0) ;If not terminal then, do nothing, return FALSE. "RTN","RMPRSTK",180,0) ; "RTN","RMPRSTK",181,0) N STOP S STOP=0 "RTN","RMPRSTK",182,0) I $E(IOST,1,2)="C-" D "RTN","RMPRSTK",183,0) .; "RTN","RMPRSTK",184,0) .N RESP,DIR S RESP=0 "RTN","RMPRSTK",185,0) .I $G(HOLD) S DIR(0)="EA",DIR("A")="Enter return to continue. " "RTN","RMPRSTK",186,0) .E S DIR(0)="E" "RTN","RMPRSTK",187,0) .D ^DIR I Y="" S STOP=0 "RTN","RMPRSTK",188,0) .I $D(DIRUT) S STOP=1 "RTN","RMPRSTK",189,0) Q STOP "RTN","RMPRSTL") 0^1^B24867541^B22270638 "RTN","RMPRSTL",1,0) RMPRSTL ;PHX/RFM,RVD-ISSUE FROM STOCK ;8/29/1994 "RTN","RMPRSTL",2,0) ;;3.0;PROSTHETICS;**14,28,33,41,178**;Feb 09, 1996;Build 14 "RTN","RMPRSTL",3,0) ;modified for cpt modifier "RTN","RMPRSTL",4,0) ;p178 JAH/CEP OIFO updates for GIP and Point of Use Supply Stations "RTN","RMPRSTL",5,0) ; DBIA #6374 "RTN","RMPRSTL",6,0) ;Per VHA Directive 10-93-142, this routine should not be modified. "RTN","RMPRSTL",7,0) NEX K DIR,Y,X I $G(RMPRGIP) G INV1 "RTN","RMPRSTL",8,0) I $P(R1(0),U,14)="C" S DIR(0)="667.3,3",DIR("A")="UNIT COST" "RTN","RMPRSTL",9,0) ;DISPLAY DEFAULT UNIT COST FOR NON-GIP ISSUES "RTN","RMPRSTL",10,0) ; "RTN","RMPRSTL",11,0) I S RO=0 I $O(^PRC(441,$P(R3("D"),U,6),2,RO))'="" D "RTN","RMPRSTL",12,0) .Q:'$D(^PRC(441,$P(R3("D"),U,6),2,$P(R1(0),U,9),0)) "RTN","RMPRSTL",13,0) .S (RMPRUCST,DIR("B"))=$J($P(^PRC(441,$P(R3("D"),U,6),2,$P(R1(0),U,9),0),U,2)/$S($P(^(0),U,10)]"":$P(^(0),U,10),1:1),9,2),(RMPRUCST,DIR("B"))=$$STRIP^XLFSTR(RMPRUCST," ") "RTN","RMPRSTL",14,0) S:+$P(R1(0),U,16) DIR("B")=$P(R1(0),U,16)/$P(R1(0),U,7) "RTN","RMPRSTL",15,0) I $G(RMLOC),$G(RMHCDA),$G(RMITDA) S (DIR("B"),RMPRUCST)=$P($G(^RMPR(661.3,RMLOC,1,RMHCDA,1,RMITDA,0)),U,10) G:RMPRUCST>0 QTY "RTN","RMPRSTL",16,0) I $P(R1(0),U,14)="C" D ^DIR K DIR I +$P(R1(0),U,16)&($D(DUOUT)) G LIST "RTN","RMPRSTL",17,0) I $D(DUOUT) X CK Q "RTN","RMPRSTL",18,0) I $D(DTOUT) X CK1 Q "RTN","RMPRSTL",19,0) I $P(R1(0),U,14)="C" S RMPRUCST=Y S:$P(R1(0),U,16) $P(R1(0),U,16)=RMPRUCST*$P(R1(0),U,7) I $D(DIRUT) X CK Q "RTN","RMPRSTL",20,0) I $P(R1(0),U,6)="C" S $P(R1(0),U,16)=Y,$P(R3("D"),U,16)=Y "RTN","RMPRSTL",21,0) I $P(R1(0),U,14)="V" S $P(R1(0),U,16)=0,RMPRUCST=0 "RTN","RMPRSTL",22,0) QTY K DIR,Y S DIR(0)="660,5" S:$P(R1(0),U,7) DIR("B")=$P(R1(0),U,7) D ^DIR I $P(R1(0),U,7)'=""&$D(DUOUT) G LIST "RTN","RMPRSTL",23,0) I $D(DTOUT) X CK1 Q "RTN","RMPRSTL",24,0) I $D(DIRUT) X CK Q "RTN","RMPRSTL",25,0) S $P(R1(0),U,7)=Y,$P(R1(0),U,16)=Y*RMPRUCST K DIR "RTN","RMPRSTL",26,0) ;SET DELIVERY DATE to today "RTN","RMPRSTL",27,0) ; "RTN","RMPRSTL",28,0) DATE ;K DIR,Y S DIR(0)="660,10" S:$P(R3("D"),U,12)'="" DIR("B")=$P(R3("D"),U,12) D ^DIR K DIR G:X["^" LIST I $D(DTOUT) X CK1 Q "RTN","RMPRSTL",29,0) ;W:$P(R1(0),U,12)&(X="@") $C(7),!?5,"Deleted..." I $P(R1(0),U,12)=""&(X="@") W ?17,"??" G DATE "RTN","RMPRSTL",30,0) S $P(R1(0),U,12)=DT,Y=DT D DD^%DT S $P(R3("D"),U,12)=Y "RTN","RMPRSTL",31,0) LI S DIR(0)="660,9" S:$P(R1(0),U,11)'="" DIR("B")=$P(R1(0),U,11) D ^DIR I $D(DTOUT) X CK1 Q "RTN","RMPRSTL",32,0) G:$D(DUOUT) LIST "RTN","RMPRSTL",33,0) I X["^" W !,"Jumping not allowed" G LI "RTN","RMPRSTL",34,0) I $P(R1(0),U,11)'=""&(X="@") S $P(R1(0),U,11)="" W $C(7),!?5,"Deleted..." H 1 G LOT "RTN","RMPRSTL",35,0) S $P(R1(0),U,11)=X "RTN","RMPRSTL",36,0) LOT K DIR S DIR(0)="660,21" S:$P(R1(0),U,24)'="" DIR("B")=$P(R1(0),U,24) D ^DIR I $D(DTOUT) X CK1 Q "RTN","RMPRSTL",37,0) G:$D(DUOUT) LIST "RTN","RMPRSTL",38,0) I X["^" W !,"Jumping not allowed" G LOT "RTN","RMPRSTL",39,0) I $P(R1(0),U,24)'=""&(X="@") S $P(R1(0),U,24)="" W $C(7),!?5,"Deleted..." H 1 G REMA "RTN","RMPRSTL",40,0) S $P(R1(0),U,24)=X "RTN","RMPRSTL",41,0) REMA K DIR S DIR(0)="660,16" S:$P(R1(0),U,18)'="" DIR("B")=$P(R1(0),U,18) D ^DIR I $D(DTOUT) X CK1 Q "RTN","RMPRSTL",42,0) G:$D(DUOUT) LIST "RTN","RMPRSTL",43,0) I X["^" W !,"Jumping not allowed" G REMA "RTN","RMPRSTL",44,0) I $P(R1(0),U,18)'=""&(X="@") S $P(R1(0),U,18)="" W $C(7),!?5,"Deleted..." H 1 G LIST "RTN","RMPRSTL",45,0) S $P(R1(0),U,18)=X "RTN","RMPRSTL",46,0) LIST ;ENTRY POINT FOR STOCK ISSUE ROUTINES TO DISPLAY TRANSACTION DATA "RTN","RMPRSTL",47,0) I $G(RMLOC),$G(RMITDA) S RMINVF="PROS INVENTORY" "RTN","RMPRSTL",48,0) D:$D(RMCPT) CHK^RMPRED5 "RTN","RMPRSTL",49,0) K DIR D ^RMPRST2 "RTN","RMPRSTL",50,0) S DIR("A")="Do you wish to POST this entry",DIR("B")="YES",DIR(0)="Y",DIR("?")="Answer `YES` to post the transaction, `NO` to delete/edit the transaction" D ^DIR K DIR G:Y=1 POST G:Y=0 DEA I $D(DIRUT) X CK Q "RTN","RMPRSTL",51,0) DEA S DIR("A")="Do you wish to Delete this entry",DIR("?")="Answer `YES` to delete the transaction, `NO` to edit the transaction, `^` to exit",DIR("B")="NO",DIR(0)="Y" "RTN","RMPRSTL",52,0) D ^DIR K DIR I Y=1 W $C(7),?50,"Deleted..." H 2 G RES^RMPRSTK "RTN","RMPRSTL",53,0) I Y=0 S REDIT=1 G 1^RMPRSTK "RTN","RMPRSTL",54,0) G:$D(DUOUT) LIST I $D(DIRUT) X CK Q "RTN","RMPRSTL",55,0) ; "RTN","RMPRSTL",56,0) ; Patch 178 Use PIP for inventory--OR--Update Inventory in GIP --OR--if Inventory "RTN","RMPRSTL",57,0) ; Point is linked to a POU cabinet, then do not call the GIP API to update inventory, "RTN","RMPRSTL",58,0) ; since POU sends HL7 to update the inventory. "RTN","RMPRSTL",59,0) ; "RTN","RMPRSTL",60,0) ; PRCPUSA DBIA #10085--Routine: PRCPUSA "RTN","RMPRSTL",61,0) ; "RTN","RMPRSTL",62,0) POST ; "RTN","RMPRSTL",63,0) I $G(RMPRGIP),'$$POU(PRCP("I")) D I $D(PRCP("ITEM")) D ERR1 N A S A=$$ASK^RMPRSTK(1) G RES^RMPRSTK "RTN","RMPRSTL",64,0) . S PRCP("QTY")=$P(R1(0),U,7)*-1,PRCP("TYP")="R" D ^PRCPUSA "RTN","RMPRSTL",65,0) ; "RTN","RMPRSTL",66,0) I RMPRG'="" G GGC "RTN","RMPRSTL",67,0) L +^RMPR(669.9,RMPRSITE,0):999 I $T=0 S RMPRG=DT_99 G GGC "RTN","RMPRSTL",68,0) S RMPRG=$P(^RMPR(669.9,RMPRSITE,0),U,7),RMPRG=RMPRG-1,$P(^RMPR(669.9,RMPRSITE,0),U,7)=RMPRG L -^RMPR(669.9,RMPRSITE,0) "RTN","RMPRSTL",69,0) GGC S $P(RMPRI("AMS"),U,1)=RMPRG,RMSER=$P(R1(0),U,11) "RTN","RMPRSTL",70,0) ;update inventory balance "RTN","RMPRSTL",71,0) S RMHCPC=$P(R1(1),U,4) "RTN","RMPRSTL",72,0) I $P(^RMPR(661.1,RMHCPC,0),U,9)=1&($D(RMLOC)) S RMQTY=$P(R1(0),U,7) D ADD^RMPR5NU1 I '$D(RMLOC) X CK Q "RTN","RMPRSTL",73,0) S:$D(RMLOC) $P(R1(1),U,2)=RDESC,$P(R1(0),U,13)=11,$P(R1(1),U,5)=RM6612 "RTN","RMPRSTL",74,0) ; "RTN","RMPRSTL",75,0) ;create 2319 "RTN","RMPRSTL",76,0) K Y,DD,DO,DA S DIC="^RMPR(660,",DIC(0)="L",X=DT,DLAYGO=660 D FILE^DICN K DLAYGO I Y'>0 W !,"** Error posting to 2319...entry deleted..." G RES^RMPRSTK "RTN","RMPRSTL",77,0) S ^RMPR(660,+Y,0)=R1(0),^(1)=R1(1),^("AM")=R1("AM"),^("AMS")=RMPRI("AMS") S:$G(RMPRGIP)=1 $P(^(1),U,3)=$G(RMPRIP) "RTN","RMPRSTL",78,0) ; "RTN","RMPRSTL",79,0) ; This sets up data for the AMIS Grouper Field in 668. ^TMP is "RTN","RMPRSTL",80,0) ; checked later and will be later if appropriate. "RTN","RMPRSTL",81,0) ; "RTN","RMPRSTL",82,0) S ^TMP($J,"RMPRPCE",660,+Y)=RMPRI("AMS") "RTN","RMPRSTL",83,0) ; "RTN","RMPRSTL",84,0) I $D(RMLOC) MERGE ^RMPR(660,+Y,"DES")=^RMPR(661.1,RMDAHC,2) S $P(^RMPR(660,+Y,"DES",0),U,2)="" "RTN","RMPRSTL",85,0) S DIK="^RMPR(660,",DA=+Y D IX1^DIK K DIC "RTN","RMPRSTL",86,0) G RES^RMPRSTK "RTN","RMPRSTL",87,0) ; "RTN","RMPRSTL",88,0) EXIT ;EXIT FOR STOCK ISSUES "RTN","RMPRSTL",89,0) K ^TMP($J,"RMRP CAUTION") "RTN","RMPRSTL",90,0) N RMPRSITE,RMPR D KILL^XUSCLEAN "RTN","RMPRSTL",91,0) Q "RTN","RMPRSTL",92,0) ERR1 ; "RTN","RMPRSTL",93,0) W !!,"Error encountered while posting to GIP. Inventory Issue did not post" "RTN","RMPRSTL",94,0) W !,"Patient 10-2319 not updated!! Please check with your Application Coordinator." "RTN","RMPRSTL",95,0) Q "RTN","RMPRSTL",96,0) ERR W !,"PLEASE EDIT GIP IN YOUR SITE PARAMETER FILE!" G EXIT "RTN","RMPRSTL",97,0) INV1 I $P(R1(0),U,14)="C" S $P(R1(0),U,16)=RMPRUCST*$P(R1(0),U,7) "RTN","RMPRSTL",98,0) G QTY "RTN","RMPRSTL",99,0) POU(INVPIEN) ; Return true if POU, false otherwise "RTN","RMPRSTL",100,0) ; DBIA 6374 to read IFCAP GIP files "RTN","RMPRSTL",101,0) ;JAH p178--check IFCAP Generic Inventory Package (GIP) "RTN","RMPRSTL",102,0) ; to determine if a Point of Use (POU) Automated Supply Cabinet is "RTN","RMPRSTL",103,0) ; linked to the secondary inventory point. "RTN","RMPRSTL",104,0) ; SSPROPTR- supply station provider pointer "RTN","RMPRSTL",105,0) ; SSPROID - supply station provider ID "RTN","RMPRSTL",106,0) ; "RTN","RMPRSTL",107,0) ; Test Loop to Run through Inventory Point File to see if any are linked to POU Cab "RTN","RMPRSTL",108,0) ; This tests this function "RTN","RMPRSTL",109,0) ; "RTN","RMPRSTL",110,0) ; S X=0 F S X=$O(^PRCP(445,X)) Q:X'>0 S Y=$$POU^RMPRSTL(X) W !,$S(Y=0:"NON-",1:""),"POU" "RTN","RMPRSTL",111,0) ; "RTN","RMPRSTL",112,0) ; $P($G(^PRCP(445,PRCPINPT,5)),"^",1)]"" supply cabinet linked to inventory point "RTN","RMPRSTL",113,0) ; "RTN","RMPRSTL",114,0) N POU S POU=0 "RTN","RMPRSTL",115,0) ; "RTN","RMPRSTL",116,0) N SSPROPTR S SSPROPTR=$$GET1^DIQ(445,INVPIEN,22,"I") "RTN","RMPRSTL",117,0) ; "RTN","RMPRSTL",118,0) ; Unit test code: "RTN","RMPRSTL",119,0) ; N SPRONAM S SSPRONAM=$$GET1^DIQ(445,INVPIEN,22) W !,"Point of Use Automated Supply: ",SSPRONAM "RTN","RMPRSTL",120,0) ; "RTN","RMPRSTL",121,0) Q:SSPROPTR'>0 POU "RTN","RMPRSTL",122,0) ; "RTN","RMPRSTL",123,0) Q 1 "VER") 8.0^22.0 "BLD",9398,6) ^159 **END** **END**