Released RMPR*3*146 SEQ #127 Extracted from mail message **KIDS**:RMPR*3.0*146^ **INSTALL NAME** RMPR*3.0*146 "BLD",6947,0) RMPR*3.0*146^PROSTHETICS^0^3080507^y "BLD",6947,1,0) ^^5^5^3080324^^ "BLD",6947,1,1,0) 1. UPD+1^RMPR9CA Close GUI PO error "BLD",6947,1,2,0) "BLD",6947,1,3,0) 2. DIS+2^RMPRPAT2 Display/Print 2319 "BLD",6947,1,4,0) "BLD",6947,1,5,0) 3. LINK+14^RMPRPCE1 Suspense Link Error "BLD",6947,4,0) ^9.64PA^^ "BLD",6947,6.3) 4 "BLD",6947,"ABPKG") n "BLD",6947,"KRN",0) ^9.67PA^8989.52^19 "BLD",6947,"KRN",.4,0) .4 "BLD",6947,"KRN",.401,0) .401 "BLD",6947,"KRN",.402,0) .402 "BLD",6947,"KRN",.403,0) .403 "BLD",6947,"KRN",.5,0) .5 "BLD",6947,"KRN",.84,0) .84 "BLD",6947,"KRN",3.6,0) 3.6 "BLD",6947,"KRN",3.8,0) 3.8 "BLD",6947,"KRN",9.2,0) 9.2 "BLD",6947,"KRN",9.8,0) 9.8 "BLD",6947,"KRN",9.8,"NM",0) ^9.68A^3^3 "BLD",6947,"KRN",9.8,"NM",1,0) RMPR9CA^^0^B61400785 "BLD",6947,"KRN",9.8,"NM",2,0) RMPRPAT2^^0^B29516719 "BLD",6947,"KRN",9.8,"NM",3,0) RMPRPCE1^^0^B30024794 "BLD",6947,"KRN",9.8,"NM","B","RMPR9CA",1) "BLD",6947,"KRN",9.8,"NM","B","RMPRPAT2",2) "BLD",6947,"KRN",9.8,"NM","B","RMPRPCE1",3) "BLD",6947,"KRN",19,0) 19 "BLD",6947,"KRN",19.1,0) 19.1 "BLD",6947,"KRN",101,0) 101 "BLD",6947,"KRN",409.61,0) 409.61 "BLD",6947,"KRN",771,0) 771 "BLD",6947,"KRN",870,0) 870 "BLD",6947,"KRN",8989.51,0) 8989.51 "BLD",6947,"KRN",8989.52,0) 8989.52 "BLD",6947,"KRN",8994,0) 8994 "BLD",6947,"KRN","B",.4,.4) "BLD",6947,"KRN","B",.401,.401) "BLD",6947,"KRN","B",.402,.402) "BLD",6947,"KRN","B",.403,.403) "BLD",6947,"KRN","B",.5,.5) "BLD",6947,"KRN","B",.84,.84) "BLD",6947,"KRN","B",3.6,3.6) "BLD",6947,"KRN","B",3.8,3.8) "BLD",6947,"KRN","B",9.2,9.2) "BLD",6947,"KRN","B",9.8,9.8) "BLD",6947,"KRN","B",19,19) "BLD",6947,"KRN","B",19.1,19.1) "BLD",6947,"KRN","B",101,101) "BLD",6947,"KRN","B",409.61,409.61) "BLD",6947,"KRN","B",771,771) "BLD",6947,"KRN","B",870,870) "BLD",6947,"KRN","B",8989.51,8989.51) "BLD",6947,"KRN","B",8989.52,8989.52) "BLD",6947,"KRN","B",8994,8994) "BLD",6947,"QUES",0) ^9.62^^ "BLD",6947,"REQB",0) ^9.611^3^3 "BLD",6947,"REQB",1,0) RMPR*3.0*141^2 "BLD",6947,"REQB",2,0) RMPR*3.0*137^2 "BLD",6947,"REQB",3,0) RMPR*3.0*78^2 "BLD",6947,"REQB","B","RMPR*3.0*137",2) "BLD",6947,"REQB","B","RMPR*3.0*141",1) "BLD",6947,"REQB","B","RMPR*3.0*78",3) "MBREQ") 0 "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) 146^3080507 "PKG",101,22,1,"PAH",1,1,0) ^^5^5^3080507 "PKG",101,22,1,"PAH",1,1,1,0) 1. UPD+1^RMPR9CA Close GUI PO error "PKG",101,22,1,"PAH",1,1,2,0) "PKG",101,22,1,"PAH",1,1,3,0) 2. DIS+2^RMPRPAT2 Display/Print 2319 "PKG",101,22,1,"PAH",1,1,4,0) "PKG",101,22,1,"PAH",1,1,5,0) 3. LINK+14^RMPRPCE1 Suspense Link Error "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") NO "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","RMPR9CA") 0^1^B61400785^B60297006 "RTN","RMPR9CA",1,0) RMPR9CA ;OI-HINES/HNC -SUSPENSE RPC;12/27/2004 "RTN","RMPR9CA",2,0) ;;3.0;PROSTHETICS;**90,135,141,146**;Feb 09, 1996;Build 4 "RTN","RMPR9CA",3,0) A1 ;roll and scroll entry point "RTN","RMPR9CA",4,0) G A2 "RTN","RMPR9CA",5,0) EN(RESULTS,RMIE68,RMPRDUZ,RMSUSTAT,RMPR664,RMPRTXT) ;RPC entry point "RTN","RMPR9CA",6,0) A2 ; "RTN","RMPR9CA",7,0) S RESULTS(0)="",STP=0 "RTN","RMPR9CA",8,0) K ^TMP($J) "RTN","RMPR9CA",9,0) ; "RTN","RMPR9CA",10,0) CONT ;RMSUSTAT is status 1=complete or 0=incomplete or 2=pending (incomplete) "RTN","RMPR9CA",11,0) ; "RTN","RMPR9CA",12,0) S RMIE=0 "RTN","RMPR9CA",13,0) F S RMIE=$O(^RMPR(664,RMPR664,1,RMIE)) Q:RMIE'>0 D Q:STP=1 "RTN","RMPR9CA",14,0) .S RMIE60=$P(^RMPR(664,RMPR664,1,RMIE,0),U,13) Q:'RMIE60 "RTN","RMPR9CA",15,0) .S ^TMP($J,RMIE60)="" "RTN","RMPR9CA",16,0) .D FD Q:STP=1 "RTN","RMPR9CA",17,0) .D UPD "RTN","RMPR9CA",18,0) I STP=1 G EXIT "RTN","RMPR9CA",19,0) I RMSUSTAT=1 D CNOTE,FD "RTN","RMPR9CA",20,0) I RMSUSTAT=0 D INOTE,FD "RTN","RMPR9CA",21,0) I RMSUSTAT=2 D ONOTE,FD "RTN","RMPR9CA",22,0) ;set status "RTN","RMPR9CA",23,0) Q "RTN","RMPR9CA",24,0) CNOTE ;(#12) COMPLETION NOTE "RTN","RMPR9CA",25,0) ;set file 668 "RTN","RMPR9CA",26,0) ;^RMPR(668,D0,4,0)=^668.012^^ "RTN","RMPR9CA",27,0) ;if status is close, or 1 "RTN","RMPR9CA",28,0) ;RMPRTXT ;load into field #12 "RTN","RMPR9CA",29,0) ;^RMPR(668,D0,4,D1,0) "RTN","RMPR9CA",30,0) ; "RTN","RMPR9CA",31,0) I $P(^RMPR(668,RMIE68,0),U,10)="C" S RESULTS(0)="0^This Suspense has already been Closed!" "RTN","RMPR9CA",32,0) S DA=RMIE68 "RTN","RMPR9CA",33,0) D NOW^%DTC S RMPREODT=%,GMRCAD=% "RTN","RMPR9CA",34,0) S DIE="^RMPR(668," "RTN","RMPR9CA",35,0) S DR="5////^S X=RMPREODT;6////^S X=DUZ;14///^S X=""C""" D ^DIE "RTN","RMPR9CA",36,0) N RMPRC "RTN","RMPR9CA",37,0) S L="",LN=0 "RTN","RMPR9CA",38,0) F S L=$O(RMPRTXT(L)) Q:L="" D "RTN","RMPR9CA",39,0) . I 'LN D Q:RMPRC="" ;strip leading space from 1st line, ignore blank line "RTN","RMPR9CA",40,0) .. S RMPRC=$E($TR(RMPRTXT(L)," ","")) ;1st non space char "RTN","RMPR9CA",41,0) .. S:RMPRC'="" RMPRTXT(L)=$E(RMPRTXT(L),$F(RMPRTXT(L),RMPRC)-1,$L(RMPRTXT(L))) ;extract from 1st non space char to end of line "RTN","RMPR9CA",42,0) .. Q "RTN","RMPR9CA",43,0) . S LN=LN+1,^RMPR(668,RMIE68,4,LN,0)=RMPRTXT(L) "RTN","RMPR9CA",44,0) . Q "RTN","RMPR9CA",45,0) S $P(^RMPR(668,RMIE68,4,0),"^",3)=LN "RTN","RMPR9CA",46,0) K L,LN "RTN","RMPR9CA",47,0) ;S DA=RMIE68,DIK="^RMPR(668," D IX1^DIK "RTN","RMPR9CA",48,0) I '$P(^RMPR(668,DA,0),U,9) D "RTN","RMPR9CA",49,0) .S DIE="^RMPR(668," "RTN","RMPR9CA",50,0) .S DR="7///^S X=""See Completion Note for Initial Action Taken.""" "RTN","RMPR9CA",51,0) .D ^DIE "RTN","RMPR9CA",52,0) .S DR="10////^S X=RMPREODT;16////^S X=DUZ" D ^DIE "RTN","RMPR9CA",53,0) K RMPREODT "RTN","RMPR9CA",54,0) S GMRCO=$P(^RMPR(668,RMIE68,0),U,15) "RTN","RMPR9CA",55,0) I GMRCO="" S RESULTS(0)="0^Completed Manual Suspense Action. Suspense status has been updated to CLOSED." Q "RTN","RMPR9CA",56,0) S RMPRCOM=0 "RTN","RMPR9CA",57,0) F S RMPRCOM=$O(^RMPR(668,RMIE68,4,RMPRCOM)) Q:RMPRCOM="" D "RTN","RMPR9CA",58,0) .S GMRCOM(RMPRCOM)=^RMPR(668,RMIE68,4,RMPRCOM,0) "RTN","RMPR9CA",59,0) I $G(GMRCOM)="" S GMRCOM="Not Noted" "RTN","RMPR9CA",60,0) S GMRCSF="U" "RTN","RMPR9CA",61,0) S GMRCA=10 "RTN","RMPR9CA",62,0) S GMRCALF="N" "RTN","RMPR9CA",63,0) S GMRCATO="" "RTN","RMPR9CA",64,0) S (GMRCORNP,GMRCDUZ)=DUZ "RTN","RMPR9CA",65,0) S BDC=$$SFILE^GMRCGUIB(.GMRCO,.GMRCA,.GMRCSF,.GMRCORNP,.GMRCDUZ,.GMRCOM,.GMRCALF,.GMRCATO,.GMRCAD) "RTN","RMPR9CA",66,0) I +BDC=1 S RESULTS(0)=1_"^"_$P(BDC,U,2) "RTN","RMPR9CA",67,0) K GMRCO,GMRCA,GMRCSF,GMRCORNP,GMRCDUZ,GMRCOM,GMRCALF,GMRCATO,GMRCAD "RTN","RMPR9CA",68,0) I RESULTS(0)="" S RESULTS(0)="0^Completed Suspense Action, and Posted note to CPRS Consult. Suspense status has been updated to CLOSED." "RTN","RMPR9CA",69,0) Q "RTN","RMPR9CA",70,0) ONOTE ;Other note "RTN","RMPR9CA",71,0) ;set file 668 "RTN","RMPR9CA",72,0) ;^RMPR(668,D0,4,0)=^668.012^^ "RTN","RMPR9CA",73,0) ;if status is pending, and already initial action note or 0 "RTN","RMPR9CA",74,0) ;^RMPR(668,D0,1,D1,0)= (#.01) ACTION DATE [1D] "RTN","RMPR9CA",75,0) ;RMPRTXT ;load into field #11, #1 "RTN","RMPR9CA",76,0) ;^RMPR(668,D0,1,D1,1,0)=^668.111^^ "RTN","RMPR9CA",77,0) ; "RTN","RMPR9CA",78,0) S RMPRDA1=RMIE68,DA(1)=RMIE68,DA=RMIE68 "RTN","RMPR9CA",79,0) D NOW^%DTC S X=%,GMRCWHN=% "RTN","RMPR9CA",80,0) S DIC="^RMPR(668,"_RMIE68_",1," "RTN","RMPR9CA",81,0) S DIC(0)="CQL" "RTN","RMPR9CA",82,0) S DIC("P")="668.011DA" "RTN","RMPR9CA",83,0) S DLAYGO=668 "RTN","RMPR9CA",84,0) D ^DIC "RTN","RMPR9CA",85,0) I Y=-1 S RESULTS(0)="1^Error Modifying Record!" Q "RTN","RMPR9CA",86,0) ;S DIE=DIC K DIC "RTN","RMPR9CA",87,0) S (DA,RMPRDA2)=+Y "RTN","RMPR9CA",88,0) ;S DR="1" D ^DIE "RTN","RMPR9CA",89,0) K DIE,DR,Y "RTN","RMPR9CA",90,0) ;S ^RMPR(668,RMIE68,1,0)="^668.011DA^1^1" "RTN","RMPR9CA",91,0) N RMPRC "RTN","RMPR9CA",92,0) S L="",LN=0 "RTN","RMPR9CA",93,0) F S L=$O(RMPRTXT(L)) Q:L="" D "RTN","RMPR9CA",94,0) . I 'LN D Q:RMPRC="" ;strip leading space from 1st line, ignore blank line "RTN","RMPR9CA",95,0) .. S RMPRC=$E($TR(RMPRTXT(L)," ","")) ;1st non space char "RTN","RMPR9CA",96,0) .. S:RMPRC'="" RMPRTXT(L)=$E(RMPRTXT(L),$F(RMPRTXT(L),RMPRC)-1,$L(RMPRTXT(L))) ;extract from 1st non space char to end of line "RTN","RMPR9CA",97,0) .. Q "RTN","RMPR9CA",98,0) . S LN=LN+1,^RMPR(668,RMIE68,1,RMPRDA2,1,LN,0)=RMPRTXT(L) "RTN","RMPR9CA",99,0) . Q "RTN","RMPR9CA",100,0) S $P(^RMPR(668,RMIE68,1,RMPRDA2,1,0),"^",3)=LN "RTN","RMPR9CA",101,0) K L,LN "RTN","RMPR9CA",102,0) S GMRCO=$P(^RMPR(668,RMIE68,0),U,15) "RTN","RMPR9CA",103,0) I GMRCO="" S RESULTS(0)="0^Completed Manual Suspense Action. Suspense status has not changed." Q "RTN","RMPR9CA",104,0) S RMPRCOM=0 "RTN","RMPR9CA",105,0) F S RMPRCOM=$O(^RMPR(668,RMIE68,1,RMPRDA2,1,RMPRCOM)) Q:RMPRCOM="" D "RTN","RMPR9CA",106,0) .S GMRCOM(RMPRCOM)=^RMPR(668,RMIE68,1,RMPRDA2,1,RMPRCOM,0) "RTN","RMPR9CA",107,0) D CMT^GMRCGUIB(.GMRCO,.GMRCOM,"",GMRCWHN,DUZ) "RTN","RMPR9CA",108,0) K DA,RMPRDA1,RMPRDA2,RMPRCOM,GMRCOM,GMRCO,GMRCWHN "RTN","RMPR9CA",109,0) S RESULTS(0)="0^Completed Suspense Action, and Posted note to CPRS Consult. Suspense status has not changed." "RTN","RMPR9CA",110,0) Q "RTN","RMPR9CA",111,0) INOTE ;initial action note "RTN","RMPR9CA",112,0) ;set file 668 "RTN","RMPR9CA",113,0) ;^RMPR(668,D0,3,0)=^668.07^^ "RTN","RMPR9CA",114,0) ;if status is pending, or 0 "RTN","RMPR9CA",115,0) ;RMPRTXT ;load into field #7 "RTN","RMPR9CA",116,0) ;^RMPR(668,D0,3,0)=^668.07^^ "RTN","RMPR9CA",117,0) ; "RTN","RMPR9CA",118,0) I $D(^RMPR(668,RMIE68,3,1,0)) S RESULTS(0)="1^Initial Action Note Already Posted!" Q "RTN","RMPR9CA",119,0) D NOW^%DTC S RMPREODT=% "RTN","RMPR9CA",120,0) N RMPRC "RTN","RMPR9CA",121,0) S ^RMPR(668,RMIE68,3,0)="^^^"_DT_"^" "RTN","RMPR9CA",122,0) S L="",LN=0 "RTN","RMPR9CA",123,0) F S L=$O(RMPRTXT(L)) Q:L="" D "RTN","RMPR9CA",124,0) . I 'LN D Q:RMPRC="" ;strip leading space from 1st line, ignore blank line "RTN","RMPR9CA",125,0) .. S RMPRC=$E($TR(RMPRTXT(L)," ","")) ;1st non space char "RTN","RMPR9CA",126,0) .. S:RMPRC'="" RMPRTXT(L)=$E(RMPRTXT(L),$F(RMPRTXT(L),RMPRC)-1,$L(RMPRTXT(L))) ;extract from 1st non space char to end of line "RTN","RMPR9CA",127,0) .. Q "RTN","RMPR9CA",128,0) . S LN=LN+1,^RMPR(668,RMIE68,3,LN,0)=RMPRTXT(L) "RTN","RMPR9CA",129,0) . Q "RTN","RMPR9CA",130,0) S $P(^RMPR(668,RMIE68,3,0),"^",3)=LN "RTN","RMPR9CA",131,0) K L,LN "RTN","RMPR9CA",132,0) S DIE="^RMPR(668," "RTN","RMPR9CA",133,0) S DA=RMIE68 "RTN","RMPR9CA",134,0) S DR="10////^S X=RMPREODT;16////^S X=DUZ;14///^S X=""P""" "RTN","RMPR9CA",135,0) D ^DIE "RTN","RMPR9CA",136,0) S GMRCO=$P(^RMPR(668,RMIE68,0),U,15) "RTN","RMPR9CA",137,0) I GMRCO="" S RESULTS(0)="0^Completed Manual Suspense Action. Suspense status has been updated to PENDING" Q "RTN","RMPR9CA",138,0) S RMPRCMT=0 "RTN","RMPR9CA",139,0) F S RMPRCMT=$O(^RMPR(668,RMIE68,3,RMPRCMT)) Q:RMPRCMT="" D "RTN","RMPR9CA",140,0) .S GMRCMT(RMPRCMT)=^RMPR(668,RMIE68,3,RMPRCMT,0) "RTN","RMPR9CA",141,0) D CMT^GMRCGUIB(GMRCO,.GMRCMT,DUZ,RMPREODT,DUZ) "RTN","RMPR9CA",142,0) K RMPREODT,GMRCO,RMGMRCO,GMRCMT,RMPRCMT "RTN","RMPR9CA",143,0) S RESULTS(0)="0^Completed Suspense Action, and Posted note to CPRS Consult. Suspense status has changed to PENDING." "RTN","RMPR9CA",144,0) Q "RTN","RMPR9CA",145,0) ; "RTN","RMPR9CA",146,0) FD ;file date "RTN","RMPR9CA",147,0) N DIE,DIC,I,J,Y,RMDFN,RMI,RMDATE,RM680,RM6810,RMERROR,RM60L,RC "RTN","RMPR9CA",148,0) N RMERR,RMCHK,DLAYGO,X,DR,RM668,RM60DAT,RMSTATUS "RTN","RMPR9CA",149,0) N RM68CNT,RM60CNT,RMSI,RMSAMIS,RM68IEN,RM60IEN,RMSUS60,RMSUS68,RMD "RTN","RMPR9CA",150,0) N RM68DATA,RM60TYP,RM68D,RM68TRAN,RMPRPRC,RM60IT,RMENTSUS,RMQUIT "RTN","RMPR9CA",151,0) ; "RTN","RMPR9CA",152,0) S RMERR=0 "RTN","RMPR9CA",153,0) S:RMSUSTAT="" RMSUSTAT=0 "RTN","RMPR9CA",154,0) L +^RMPR(660,RMIE60):2 "RTN","RMPR9CA",155,0) I $T=0 S RESULTS(0)="1^Someone else is Editing this entry!" S STP=1 Q "RTN","RMPR9CA",156,0) S RM680=$G(^RMPR(668,RMIE68,0)) "RTN","RMPR9CA",157,0) S RM688=$G(^RMPR(668,RMIE68,8)) "RTN","RMPR9CA",158,0) S RM6810=$G(^RMPR(668,RMIE68,10)) "RTN","RMPR9CA",159,0) S RMAMIS=$P($G(^RMPR(660,RMIE60,"AMS")),U,1) "RTN","RMPR9CA",160,0) ;code here for 668 fields "RTN","RMPR9CA",161,0) S RMDATE=$P(RM680,U,1) "RTN","RMPR9CA",162,0) S RMCODT=$P(RM680,U,5) "RTN","RMPR9CA",163,0) S RMINDT=$P(RM680,U,9) "RTN","RMPR9CA",164,0) S RMPRCO=$P(RM680,U,15) "RTN","RMPR9CA",165,0) S RMDWRT=$P(RM680,U,16) "RTN","RMPR9CA",166,0) S RMSTAT=$P(RM680,U,7) "RTN","RMPR9CA",167,0) S RMTRES=$P(RM680,U,8) "RTN","RMPR9CA",168,0) S RMTYRE=$S(RMTRES=1:"ROUTINE",RMTRES=2:"EYEGLASS",RMTRES=3:"CONTACT LENS",RMTRES=4:"OXYGEN",RMTRES=5:"MANUAL",1:"") "RTN","RMPR9CA",169,0) S RMREQU=$P(RM680,U,11) "RTN","RMPR9CA",170,0) S RMSERV="" "RTN","RMPR9CA",171,0) I $G(RMREQU) D GETS^DIQ(200,RMREQU,"29","E","RMAA") S RMSERV=RMAA(200,RMREQU_",",29,"E") "RTN","RMPR9CA",172,0) S RMPRDI=$E($P(RM688,U,2),1,16) "RTN","RMPR9CA",173,0) S RMICD9=$P(RM688,U,3) "RTN","RMPR9CA",174,0) ; "RTN","RMPR9CA",175,0) S RMDAT(660,RMIE60_",",8.1)=RMDATE "RTN","RMPR9CA",176,0) S RMDAT(660,RMIE60_",",8.2)=RMDWRT "RTN","RMPR9CA",177,0) S RMDAT(660,RMIE60_",",8.3)=RMINDT "RTN","RMPR9CA",178,0) S RMDAT(660,RMIE60_",",8.4)=RMCODT "RTN","RMPR9CA",179,0) S RMDAT(660,RMIE60_",",8.5)=RMTYRE "RTN","RMPR9CA",180,0) S RMDAT(660,RMIE60_",",8.6)=RMREQU "RTN","RMPR9CA",181,0) S RMDAT(660,RMIE60_",",8.61)=RMSERV "RTN","RMPR9CA",182,0) S RMDAT(660,RMIE60_",",8.7)=RMPRDI "RTN","RMPR9CA",183,0) S RMDAT(660,RMIE60_",",8.8)=RMICD9 "RTN","RMPR9CA",184,0) S RMDAT(660,RMIE60_",",8.9)=RMPRCO "RTN","RMPR9CA",185,0) S RMDAT(660,RMIE60_",",8.11)=RMSTAT "RTN","RMPR9CA",186,0) I RMSUSTAT=2 S RMDAT(660,RMIE60_",",8.14)=0 "RTN","RMPR9CA",187,0) I RMSUSTAT'=2 S RMDAT(660,RMIE60_",",8.14)=RMSUSTAT "RTN","RMPR9CA",188,0) D FILE^DIE("","RMDAT","RMERROR") "RTN","RMPR9CA",189,0) I $D(RMERROR) S RMERR=1 S STP=1 "RTN","RMPR9CA",190,0) ; "RTN","RMPR9CA",191,0) L -^RMPR(660,RMIE60) "RTN","RMPR9CA",192,0) Q "RTN","RMPR9CA",193,0) UPD ;update file 668 with 2319 records "RTN","RMPR9CA",194,0) S DA(1)=RMIE68 K DD,DO,DIC "RTN","RMPR9CA",195,0) S DIC="^RMPR(668,"_DA(1)_","_"10," "RTN","RMPR9CA",196,0) S DIC(0)="L",DLAYGO=668,X=RMIE60 "RTN","RMPR9CA",197,0) D FILE^DICN "RTN","RMPR9CA",198,0) K X,DD,DO,DIC "RTN","RMPR9CA",199,0) S DA(1)=RMIE68,DIC(0)="L",DLAYGO=668 "RTN","RMPR9CA",200,0) S DIC="^RMPR(668,"_DA(1)_","_"11," "RTN","RMPR9CA",201,0) S X=RMAMIS "RTN","RMPR9CA",202,0) D FILE^DICN "RTN","RMPR9CA",203,0) K DIC,X,DLAYGO,DD,DO "RTN","RMPR9CA",204,0) Q "RTN","RMPR9CA",205,0) A3 G A4 "RTN","RMPR9CA",206,0) EN1(RESULTS,DA) ;Broker entry to kill PO "RTN","RMPR9CA",207,0) ;DA is passed "RTN","RMPR9CA",208,0) S DIK="^RMPR(664," D ^DIK "RTN","RMPR9CA",209,0) K DIK "RTN","RMPR9CA",210,0) A4 ; "RTN","RMPR9CA",211,0) Q "RTN","RMPR9CA",212,0) ERR ;exit on error "RTN","RMPR9CA",213,0) EXIT ; "RTN","RMPR9CA",214,0) K RMTYRE,RMTRES,RMSUSTAT,RMSTAT,RMSERV,RMEQU,RMPRTST,RMPRDUZ,RMPRDI,RMPRCO,RMPR664,RMIE68 "RTN","RMPR9CA",215,0) K RMIE60,RMIE,RMICD9,RMDWRT,RMDAT,RMCODT,RMAMIS,RMAA,RM688,RMPRTXT "RTN","RMPR9CA",216,0) K BDC,BAD,%,RMINDT,RMPREQU,STP "RTN","RMPR9CA",217,0) Q "RTN","RMPRPAT2") 0^2^B29516719^B27661338 "RTN","RMPRPAT2",1,0) RMPRPAT2 ;PHX/RFM/JLT/HNC-DISPLAY PATIENT ITEM ACTIVITY ;10/19/1993 "RTN","RMPRPAT2",2,0) ;;3.0;PROSTHETICS;**32,34,29,44,99,75,137,146**;Feb 09, 1996;Build 4 "RTN","RMPRPAT2",3,0) D HDR N RMPRMERG S RMPRMERG=0 "RTN","RMPRPAT2",4,0) S (RA,AN,ANS,RK,RZ)=0 K ^TMP($J,"TT"),^TMP($J,"AG"),IT "RTN","RMPRPAT2",5,0) MERGE ^TMP($J,"TT")=^RMPR(660,"AC",RMPRDFN) "RTN","RMPRPAT2",6,0) ;Check for merged accounts "RTN","RMPRPAT2",7,0) I $D(^XDRM("B",RMPRDFN_";DPT(")) D "RTN","RMPRPAT2",8,0) . S RMPRMERG=$O(^XDRM("B",RMPRDFN_";DPT(",RMPRMERG)) Q:RMPRMERG="" "RTN","RMPRPAT2",9,0) . S RMPRMERG=+^XDRM(RMPRMERG,0) Q:RMPRMERG=0 "RTN","RMPRPAT2",10,0) . MERGE ^TMP($J,"TT")=^RMPR(660,"AC",RMPRMERG) "RTN","RMPRPAT2",11,0) S B=0 "RTN","RMPRPAT2",12,0) F S B=$O(^TMP($J,"TT",B)) Q:B'>0 D "RTN","RMPRPAT2",13,0) . S BC=0 "RTN","RMPRPAT2",14,0) . F S BC=$O(^TMP($J,"TT",B,BC)) Q:BC'>0 D "RTN","RMPRPAT2",15,0) . .Q:$P($G(^RMPR(660,BC,0)),U,10)'=RMPR("STA") "RTN","RMPRPAT2",16,0) . .S GN=$P($G(^RMPR(660,BC,"AMS")),U,1) "RTN","RMPRPAT2",17,0) . .S ND=$P($G(^RMPR(660,BC,1)),U,4) "RTN","RMPRPAT2",18,0) . .I ND S ND=$P(^RMPR(661.1,ND,0),U,8) "RTN","RMPRPAT2",19,0) . .S:ND="" ND=2 "RTN","RMPRPAT2",20,0) . .S:GN="" GN=BC "RTN","RMPRPAT2",21,0) . .S ^TMP($J,"AG",GN,ND,BC)=B "RTN","RMPRPAT2",22,0) S B="" "RTN","RMPRPAT2",23,0) F S B=$O(^TMP($J,"AG",B)) Q:+B=0 D "RTN","RMPRPAT2",24,0) .S BC="" "RTN","RMPRPAT2",25,0) .F S BC=$O(^TMP($J,"AG",B,BC)) Q:BC'>0 D "RTN","RMPRPAT2",26,0) . .Q:BC=2 "RTN","RMPRPAT2",27,0) . .MERGE ^TMP($J,"AGG")=^TMP($J,"AG",B) "RTN","RMPRPAT2",28,0) . .S HC="",GTCST=0 "RTN","RMPRPAT2",29,0) . .K HCC1 "RTN","RMPRPAT2",30,0) . .F S HC=$O(^TMP($J,"AGG",HC)) Q:HC'>0 D "RTN","RMPRPAT2",31,0) . . .S HCC=0 "RTN","RMPRPAT2",32,0) . . .;changes for Surgical Implants "RTN","RMPRPAT2",33,0) . . .S BDC="" "RTN","RMPRPAT2",34,0) . . .F BDC=1:1 S HCC=$O(^TMP($J,"AGG",HC,HCC)) Q:HCC'>0 D "RTN","RMPRPAT2",35,0) . . . .S GTCST=GTCST+$P(^RMPR(660,HCC,0),U,16) "RTN","RMPRPAT2",36,0) . . . .I BDC=1&(HC'=2) S HCC1=HCC "RTN","RMPRPAT2",37,0) . . . .I BDC'=1 K ^TMP($J,"TT",^TMP($J,"AGG",HC,HCC),HCC) "RTN","RMPRPAT2",38,0) . . . .I HC=2 K ^TMP($J,"TT",^TMP($J,"AGG",HC,HCC),HCC) "RTN","RMPRPAT2",39,0) . .I $G(HCC1) S $P(^TMP($J,"TT",^TMP($J,"AGG",1,HCC1),HCC1),U,3)=GTCST K HCC1 "RTN","RMPRPAT2",40,0) . .K GTCST,^TMP($J,"AGG") "RTN","RMPRPAT2",41,0) K ^TMP($J,"AG"),BDC "RTN","RMPRPAT2",42,0) S B=0,RC=1 "RTN","RMPRPAT2",43,0) F S B=$O(^TMP($J,"TT",B)) Q:B'>0 D "RTN","RMPRPAT2",44,0) .S RK=0 "RTN","RMPRPAT2",45,0) .F S RK=$O(^TMP($J,"TT",B,RK)) Q:RK'>0 D "RTN","RMPRPAT2",46,0) . .Q:$D(^RMPO(665.72,"AC",RK)) "RTN","RMPRPAT2",47,0) . .S IT(RC)=RK "RTN","RMPRPAT2",48,0) . .I $P(^TMP($J,"TT",B,RK),U,3) S $P(IT(RC),U,3)=$P(^TMP($J,"TT",B,RK),U,3) "RTN","RMPRPAT2",49,0) . .S RC=RC+1 "RTN","RMPRPAT2",50,0) S RK=0,RZ=0 "RTN","RMPRPAT2",51,0) K ^TMP($J,"TT"),B "RTN","RMPRPAT2",52,0) ; "RTN","RMPRPAT2",53,0) G:'$D(IT) END "RTN","RMPRPAT2",54,0) DIS ;DISPLAY APPLIANCES OR REPAIRS "RTN","RMPRPAT2",55,0) I $G(RK)="" S RK="",RC="" "RTN","RMPRPAT2",56,0) I (RK+1'>RC)&($G(IT(RK+1))) S RK=RK+1 S AN=+IT(RK),Y=$G(^RMPR(660,AN,0)) G:Y="" EXITD D PRT,OVER:((IOSL-4)<$Y) G:'$D(ANS)!(ANS=U)!($D(DUOUT))!($D(DTOUT)) EXIT G DIS "RTN","RMPRPAT2",57,0) END I RC=0 W !,"No Appliances or Repairs exist for this veteran!",!! H 3 G EXIT "RTN","RMPRPAT2",58,0) ; "RTN","RMPRPAT2",59,0) I RC>0 W !!,"End of Appliance/Repair records for this veteran!" D OVER I $G(RK)+1'>$G(RC)&($G(IT($G(RK)+1))) D DIS "RTN","RMPRPAT2",60,0) ; "RTN","RMPRPAT2",61,0) EXIT K I,J,L,R0,IT,RA "RTN","RMPRPAT2",62,0) Q:'$D(RMPRDFN) "RTN","RMPRPAT2",63,0) W ! "RTN","RMPRPAT2",64,0) I $D(DUOUT)!($D(DTOUT)) G ASK1^RMPRPAT "RTN","RMPRPAT2",65,0) S FL=4 G ASK2^RMPRPAT "RTN","RMPRPAT2",66,0) Q "RTN","RMPRPAT2",67,0) EXITD W !!,"Appliance/Repair record was deleted during view for this veteran",!,"...Enter 'return' to continue." R TYPE:20 "RTN","RMPRPAT2",68,0) G EXIT "RTN","RMPRPAT2",69,0) PRT S DATE=$P(Y,U,3),TYPE=$P(Y,U,6),QTY=$P(Y,U,7) "RTN","RMPRPAT2",70,0) S VEN=$P(Y,U,9),TRANS=$P(Y,U,4),STA=$P(Y,U,10),SN=$P(Y,U,11) "RTN","RMPRPAT2",71,0) S DEL=$P(Y,U,12) "RTN","RMPRPAT2",72,0) S CST=$S($P(Y,U,16)'="":$P(Y,U,16),$D(^RMPR(660,AN,"LB")):$P(^RMPR(660,AN,"LB"),U,9),1:"") "RTN","RMPRPAT2",73,0) ;lab source of procurement "RTN","RMPRPAT2",74,0) I $D(^RMPR(660,AN,"LB")) S RMPRLPRO=$P(^("LB"),U,3) D "RTN","RMPRPAT2",75,0) .I RMPRLPRO="O" S RMPRLPRO="ORTHOTIC" Q "RTN","RMPRPAT2",76,0) .I RMPRLPRO="R" S RMPRLPRO="RESTORATION" Q "RTN","RMPRPAT2",77,0) .I RMPRLPRO="S" S RMPRLPRO="SHOE" Q "RTN","RMPRPAT2",78,0) .I RMPRLPRO="W" S RMPRLPRO="WHEELCHAIR" Q "RTN","RMPRPAT2",79,0) .I RMPRLPRO="N" S RMPRLPRO="FOOT CENTER" Q "RTN","RMPRPAT2",80,0) .I RMPRLPRO="D" S RMPRLPRO="DDC" Q "RTN","RMPRPAT2",81,0) ;form requested on "RTN","RMPRPAT2",82,0) S FRM=$P(Y,U,13),REM=$P(Y,U,18) "RTN","RMPRPAT2",83,0) S DATE=$E(DATE,4,5)_"/"_$E(DATE,6,7)_"/"_$E(DATE,2,3) "RTN","RMPRPAT2",84,0) S TYPE=$P($G(^RMPR(660,AN,1)),U,4) "RTN","RMPRPAT2",85,0) ;S TYPE=$S(TYPE="":"",$D(^RMPR(661,TYPE,0)):$P(^(0),U,1),1:"") "RTN","RMPRPAT2",86,0) S AMIS=$P(Y,U,15),VEN=$S(VEN="":"",$D(^PRC(440,VEN,0)):$P(^(0),U,1),1:"") "RTN","RMPRPAT2",87,0) I $D(^RMPR(660.1,"AC",AN)),$P(^RMPR(660.1,$O(^RMPR(660.1,"AC",AN,0)),0),U,11)]"" S AMIS=AMIS_"+" "RTN","RMPRPAT2",88,0) S TRANS=$S(TRANS]"":TRANS,1:""),TRANS1="" S:TRANS="X" TRANS1=TRANS,TRANS="" "RTN","RMPRPAT2",89,0) S DEL=$E(DEL,4,5)_"/"_$E(DEL,6,7)_"/"_$E(DEL,2,3) S:DEL="//" DEL="" "RTN","RMPRPAT2",90,0) W !,RK,". ",DATE,?13,QTY,?17 "RTN","RMPRPAT2",91,0) ;W AMIS_$S(TYPE'="":$E($P(^PRC(441,TYPE,0),U,2),1,10),$P(Y,U,26)="D":"DELIVERY",$P(Y,U,26)="P":"PICKUP",$P(Y,U,17):"SHIPPING",1:"") "RTN","RMPRPAT2",92,0) W AMIS_$S(TYPE'="":$E($P($G(^RMPR(661.1,TYPE,0)),U,2),1,10),$P(Y,U,26)="D":"DELIVERY",$P(Y,U,26)="P":"PICKUP",$P(Y,U,17):"SHIPPING",1:"") "RTN","RMPRPAT2",93,0) ;historical item "RTN","RMPRPAT2",94,0) I TYPE=""&($D(^RMPR(660,$P(IT(RK),U,1),"HST"))) W $E($P(^("HST"),U,1),1,10) "RTN","RMPRPAT2",95,0) W ?30,TRANS,?31,TRANS1 "RTN","RMPRPAT2",96,0) ;display source of procurement for 2529-3 under vendor header "RTN","RMPRPAT2",97,0) I $D(RMPRLPRO) W ?33,RMPRLPRO "RTN","RMPRPAT2",98,0) ;I '$D(RMPRLPRO),VEN'="" W ?33,$E(VEN,1,10) "RTN","RMPRPAT2",99,0) I VEN'="" W ?33,$E(VEN,1,10) "RTN","RMPRPAT2",100,0) K RMPRLPRO "RTN","RMPRPAT2",101,0) ;historical vendor "RTN","RMPRPAT2",102,0) W:$D(^RMPR(660,$P(IT(RK),U,1),"HST")) $E($P(^("HST"),U,3),1,10) "RTN","RMPRPAT2",103,0) W:STA'="" ?45,$P(^DIC(4,STA,99),U,1) "RTN","RMPRPAT2",104,0) W ?50,$E(SN,1,9),?60,DEL "RTN","RMPRPAT2",105,0) I $P(IT(RK),U,3) S CST=$P(IT(RK),U,3) "RTN","RMPRPAT2",106,0) W ?71,$J($FN($S(CST'="":CST,$P(Y,U,17):$P(Y,U,17),1:""),"T",2),9) "RTN","RMPRPAT2",107,0) W:REM]"" !,?3,REM "RTN","RMPRPAT2",108,0) I $P(IT(RK),U,2)="" S $P(IT(RK),U,2)=RZ "RTN","RMPRPAT2",109,0) Q "RTN","RMPRPAT2",110,0) OVER ; "RTN","RMPRPAT2",111,0) N ANS "RTN","RMPRPAT2",112,0) S RZ=RK W !,"+=Turned-In *=Historical Data I=Initial X=Repair S=Spare R=Replacement",!,"Enter 1-",RK," to show full entry, '^' to exit or `return` to continue. " R ANS:DTIME S:'$T ANS="^" "RTN","RMPRPAT2",113,0) I ANS="^^" S ANS="^" G ASK1^RMPRPAT Q "RTN","RMPRPAT2",114,0) I ANS="^" G ASK1^RMPRPAT Q "RTN","RMPRPAT2",115,0) I ANS="",RK+1'>RC&($G(IT(RK+1))) D HDR Q "RTN","RMPRPAT2",116,0) I ANS="" Q "RTN","RMPRPAT2",117,0) I ANS'?1N.N!(ANS>RK)!(+ANS=0)!(+ANS'=ANS) W $C(7),!," Must be between 1 and ",RK," to be valid" G OVER "RTN","RMPRPAT2",118,0) I ANS>0,(ANS<(RK+1)) S AN=ANS,RZ=RK D ^RMPRPAT3 "RTN","RMPRPAT2",119,0) S RK=$P(IT(ANS),U,2) "RTN","RMPRPAT2",120,0) Q "RTN","RMPRPAT2",121,0) HDR ;Print Header, Screen 4 "RTN","RMPRPAT2",122,0) W @IOF "RTN","RMPRPAT2",123,0) S PAGE=3 "RTN","RMPRPAT2",124,0) W !,$E(RMPRNAM,1,20),?23,"SSN: " "RTN","RMPRPAT2",125,0) W $E(RMPRSSN,1,3)_"-"_$E(RMPRSSN,4,5)_"-"_$E(RMPRSSN,6,10) "RTN","RMPRPAT2",126,0) W ?42,"DOB: " "RTN","RMPRPAT2",127,0) S Y=RMPRDOB X ^DD("DD") W Y K Y "RTN","RMPRPAT2",128,0) W ?61,"CLAIM# ",$G(RMPRCNUM) "RTN","RMPRPAT2",129,0) W !?4,"Date",?12,"Qty",?19,"HCPCS",?28,"Type",?34,"Vendor",?45,"Sta",?50,"Serial",?58,"Delivery Date",?72,"Tot Cost" "RTN","RMPRPAT2",130,0) Q "RTN","RMPRPCE1") 0^3^B30024794^B29214954 "RTN","RMPRPCE1",1,0) RMPRPCE1 ;HCIOFO/RVD - Prosthetics/PCE UPDATE UTILITY ;5/7/03 09:12 "RTN","RMPRPCE1",2,0) ;;3.0;PROSTHETICS;**62,69,77,78,146**;Feb 09, 1996;Build 4 "RTN","RMPRPCE1",3,0) ; "RTN","RMPRPCE1",4,0) ;patch #69 "RTN","RMPRPCE1",5,0) ;RVD 4/10/02 - validate the length (16 c) of provisional diagnosis "RTN","RMPRPCE1",6,0) ; before filing. Change Routine Prosthetic to ROUTINE "RTN","RMPRPCE1",7,0) ; Type of Request field in 660. "RTN","RMPRPCE1",8,0) ;RVD 5/6/03 patch #77 - SET Consult Request Service field in #660. "RTN","RMPRPCE1",9,0) ; - POST init for setting Consult Request Service. "RTN","RMPRPCE1",10,0) ;TH 9/29/03 Patch #78 - Add Billing Aware related fields. "RTN","RMPRPCE1",11,0) ; "RTN","RMPRPCE1",12,0) ;DBIA # 10060, Fileman read of file #200. "RTN","RMPRPCE1",13,0) ; "RTN","RMPRPCE1",14,0) ;This routine contains the code for updating file #660 and #668. "RTN","RMPRPCE1",15,0) ; "RTN","RMPRPCE1",16,0) ;RMIE60 - ien of file #660 "RTN","RMPRPCE1",17,0) UP60(RMIE60,RMIE68,RMSUSTAT) ; update file #660. "RTN","RMPRPCE1",18,0) D NEWVAR "RTN","RMPRPCE1",19,0) S RMERR=0 "RTN","RMPRPCE1",20,0) S:RMSUSTAT="" RMSUSTAT=0 "RTN","RMPRPCE1",21,0) L +^RMPR(660,RMIE60):2 "RTN","RMPRPCE1",22,0) I $T=0 W !,"Someone else is Editing this entry!!!",! H 3 S RMERR=1 G UP60X "RTN","RMPRPCE1",23,0) S RM680=$G(^RMPR(668,RMIE68,0)) "RTN","RMPRPCE1",24,0) S RM688=$G(^RMPR(668,RMIE68,8)) "RTN","RMPRPCE1",25,0) S RM6810=$G(^RMPR(668,RMIE68,10)) "RTN","RMPRPCE1",26,0) ;code here for 668 fields "RTN","RMPRPCE1",27,0) S RMDATE=$P(RM680,U,1) ;Suspense Date "RTN","RMPRPCE1",28,0) S RMCODT=$P(RM680,U,5) ;Completion Date "RTN","RMPRPCE1",29,0) S RMINDT=$P(RM680,U,9) ;Initial Action Date "RTN","RMPRPCE1",30,0) S RMPRCO=$P(RM680,U,15) ;Consult "RTN","RMPRPCE1",31,0) S RMDWRT=$P(RM680,U,16) ;Date RX Written "RTN","RMPRPCE1",32,0) S RMSTAT=$P(RM680,U,7) ;Station "RTN","RMPRPCE1",33,0) S RMTRES=$P(RM680,U,8) ;Type of Request "RTN","RMPRPCE1",34,0) S RMTYRE=$S(RMTRES=1:"ROUTINE",RMTRES=2:"EYEGLASS",RMTRES=3:"CONTACT LENS",RMTRES=4:"OXYGEN",RMTRES=5:"MANUAL",1:"") "RTN","RMPRPCE1",35,0) S RMREQU=$P(RM680,U,11) ;Requestor (Ordering Provider) "RTN","RMPRPCE1",36,0) S RMSERV="" "RTN","RMPRPCE1",37,0) ;I $G(RMREQU) D GETS^DIQ(200,RMREQU,"29","E","RMAA") S RMSERV=RMAA(200,RMREQU_",",29,"E") "RTN","RMPRPCE1",38,0) S RMPRDI=$E($P(RM688,U,2),1,16) ;Provisional Diagnosis "RTN","RMPRPCE1",39,0) S RMICD9=$P(RM688,U,3) ;ICD9 "RTN","RMPRPCE1",40,0) ; "RTN","RMPRPCE1",41,0) S RMDAT(660,RMIE60_",",8.1)=RMDATE ;Suspense Date "RTN","RMPRPCE1",42,0) S RMDAT(660,RMIE60_",",8.2)=RMDWRT ;Date RX Written "RTN","RMPRPCE1",43,0) S RMDAT(660,RMIE60_",",8.3)=RMINDT ;Initial Action Date "RTN","RMPRPCE1",44,0) S RMDAT(660,RMIE60_",",8.4)=RMCODT ;Completion Date "RTN","RMPRPCE1",45,0) S RMDAT(660,RMIE60_",",8.5)=RMTYRE ;Type of Request "RTN","RMPRPCE1",46,0) S RMDAT(660,RMIE60_",",8.6)=RMREQU ;Ordering Provider "RTN","RMPRPCE1",47,0) S RMDAT(660,RMIE60_",",8.61)=RMSERV ;Consult Request Service "RTN","RMPRPCE1",48,0) S RMDAT(660,RMIE60_",",8.7)=RMPRDI ;Provisional Diagnosis "RTN","RMPRPCE1",49,0) S RMDAT(660,RMIE60_",",8.8)=RMICD9 ;Suspense ICD9 "RTN","RMPRPCE1",50,0) S RMDAT(660,RMIE60_",",8.9)=RMPRCO ;Pointer to Request/Consultation "RTN","RMPRPCE1",51,0) S RMDAT(660,RMIE60_",",8.11)=RMSTAT ;Suspense Station "RTN","RMPRPCE1",52,0) S RMDAT(660,RMIE60_",",8.14)=RMSUSTAT ;Suspense Status "RTN","RMPRPCE1",53,0) ; "RTN","RMPRPCE1",54,0) ; Patch #78 "RTN","RMPRPCE1",55,0) ; #668,BA nodes "RTN","RMPRPCE1",56,0) F RMPRL=1:1:99 S RM68BA=$G(^RMPR(668,RMIE68,"BA"_RMPRL)) Q:RM68BA="" D "RTN","RMPRPCE1",57,0) . N RMICD,RMAO,RMIR,RMSC,RMEC,RMMST,RMHNC,RMCBV "RTN","RMPRPCE1",58,0) . S RMICD=$P(RM68BA,U,1) "RTN","RMPRPCE1",59,0) . S RMAO=$P(RM68BA,U,2) "RTN","RMPRPCE1",60,0) . S RMIR=$P(RM68BA,U,3) "RTN","RMPRPCE1",61,0) . S RMSC=$P(RM68BA,U,4) "RTN","RMPRPCE1",62,0) . S RMEC=$P(RM68BA,U,5) "RTN","RMPRPCE1",63,0) . S RMMST=$P(RM68BA,U,6) "RTN","RMPRPCE1",64,0) . S RMHNC=$P(RM68BA,U,7) "RTN","RMPRPCE1",65,0) . S RMCBV=$P(RM68BA,U,8) "RTN","RMPRPCE1",66,0) . N RMPTR "RTN","RMPRPCE1",67,0) . S RMPTR=29+RMPRL "RTN","RMPRPCE1",68,0) . S RMDAT(660,RMIE60_",",RMPTR)=RMICD "RTN","RMPRPCE1",69,0) . S RMDAT(660,RMIE60_",",RMPTR_".1")=RMAO "RTN","RMPRPCE1",70,0) . S RMDAT(660,RMIE60_",",RMPTR_".2")=RMIR "RTN","RMPRPCE1",71,0) . S RMDAT(660,RMIE60_",",RMPTR_".3")=RMSC "RTN","RMPRPCE1",72,0) . S RMDAT(660,RMIE60_",",RMPTR_".4")=RMEC "RTN","RMPRPCE1",73,0) . S RMDAT(660,RMIE60_",",RMPTR_".5")=RMMST "RTN","RMPRPCE1",74,0) . S RMDAT(660,RMIE60_",",RMPTR_".6")=RMHNC "RTN","RMPRPCE1",75,0) . S RMDAT(660,RMIE60_",",RMPTR_".7")=RMCBV "RTN","RMPRPCE1",76,0) ; "RTN","RMPRPCE1",77,0) D UPDATE^DIE("","RMDAT",,"RMERROR") "RTN","RMPRPCE1",78,0) I $D(RMERROR) S RMERR=1 D ERR0 "RTN","RMPRPCE1",79,0) ; "RTN","RMPRPCE1",80,0) L -^RMPR(660,RMIE60) "RTN","RMPRPCE1",81,0) UP60X ; exit point "RTN","RMPRPCE1",82,0) Q RMERR "RTN","RMPRPCE1",83,0) ; "RTN","RMPRPCE1",84,0) ;RMIE60 = IEN of file #660. "RTN","RMPRPCE1",85,0) ;RMIE68 = IEN of file #668. "RTN","RMPRPCE1",86,0) UP68(RMIE60,RMIE68,RMAMIS) ; update file #668. "RTN","RMPRPCE1",87,0) D NEWVAR "RTN","RMPRPCE1",88,0) S (RMI,RMERR)=0 "RTN","RMPRPCE1",89,0) ;S RMAMIS=$G(^RMPR(660,RMIE60,"AMS")) "RTN","RMPRPCE1",90,0) I '$G(RMAMIS) D ERR8 S RMERR=1 G UP68X "RTN","RMPRPCE1",91,0) ;L +^RMPR(668,RMIE68):2 "RTN","RMPRPCE1",92,0) ;I $T=0 W !,"Someone else is Editing this entry!!!",! H 3 S RMERR=1 G UP68X "RTN","RMPRPCE1",93,0) I $D(^RMPR(668,RMIE68,10,"B",RMIE60)) G UP68X "RTN","RMPRPCE1",94,0) S DA(1)=RMIE68 K DD,DO "RTN","RMPRPCE1",95,0) S DIC="^RMPR(668,"_DA(1)_","_"10,",DIC(0)="L",DLAYGO=668,X=RMIE60 "RTN","RMPRPCE1",96,0) D FILE^DICN K DIC,X,DLAYGO,DD,DO "RTN","RMPRPCE1",97,0) I Y=-1 S RMERR=1 D ERR8 G UNL68 "RTN","RMPRPCE1",98,0) I $D(^RMPR(668,RMIE68,11,"B",RMAMIS)) G UP68X "RTN","RMPRPCE1",99,0) S DA(1)=RMIE68 "RTN","RMPRPCE1",100,0) S DIC="^RMPR(668,"_DA(1)_","_"11,",DIC(0)="L",DLAYGO=668,X=RMAMIS "RTN","RMPRPCE1",101,0) D FILE^DICN K DIC "RTN","RMPRPCE1",102,0) I Y=-1 S RMERR=1 D ERR8 G UNL68 "RTN","RMPRPCE1",103,0) ; "RTN","RMPRPCE1",104,0) UNL68 ;L -^RMPR(668,RMIE68) "RTN","RMPRPCE1",105,0) UP68X ; exit point "RTN","RMPRPCE1",106,0) Q RMERR "RTN","RMPRPCE1",107,0) ; "RTN","RMPRPCE1",108,0) ERR0 ;error updating file #660 "RTN","RMPRPCE1",109,0) W !,"*** Error updating file #660 in PCE module!!!",! "RTN","RMPRPCE1",110,0) Q "RTN","RMPRPCE1",111,0) ERR8 ;error updating file #668 "RTN","RMPRPCE1",112,0) W !,"*** Error updating file #668 in PCE module!!!",! "RTN","RMPRPCE1",113,0) Q "RTN","RMPRPCE1",114,0) LINK ;link 2319 to suspense "RTN","RMPRPCE1",115,0) D DIV4^RMPRSIT Q:$D(X) "RTN","RMPRPCE1",116,0) K ^TMP($J) "RTN","RMPRPCE1",117,0) W ! S DIC="^RMPR(660,",DIC(0)="AEMQZ",DIC("A")="Select PATIENT: " "RTN","RMPRPCE1",118,0) S DIC("S")="S RMZ=$G(^RMPR(660,+Y,10)) I $P(RMZ,U,14)'=1,$D(^(""AMS"")),RMPR(""STA"")=$P(^(0),U,10)" "RTN","RMPRPCE1",119,0) S DIC("W")="D EN^RMPRD1" "RTN","RMPRPCE1",120,0) W ! "RTN","RMPRPCE1",121,0) D ^DIC G:Y'>0 EXIT "RTN","RMPRPCE1",122,0) L +^RMPR(660,+Y):1 I $T=0 W !,?5,$C(7),"Someone else is Editing this entry!" G EXIT "RTN","RMPRPCE1",123,0) S RMPRDA=+Y "RTN","RMPRPCE1",124,0) S RMPRDFN=$P(^RMPR(660,+Y,0),U,2) "RTN","RMPRPCE1",125,0) I $D(^RMPR(660,+Y,"AMS")) N RMPRAMIS S RMPRAMIS=$P(^RMPR(660,+Y,"AMS"),U,1) "RTN","RMPRPCE1",126,0) S ^TMP($J,"RMPRPCE",660,+Y)=RMPRAMIS_"^"_RMPRDFN "RTN","RMPRPCE1",127,0) D LINK^RMPRS "RTN","RMPRPCE1",128,0) I $G(RMPRDA)="" S RMPRDA=$O(^TMP($J,"RMPRPCE",660,0)) "RTN","RMPRPCE1",129,0) I $G(RMPRDA)="" L G EXIT "RTN","RMPRPCE1",130,0) L -^RMPR(660,RMPRDA) "RTN","RMPRPCE1",131,0) EXIT ;quit "RTN","RMPRPCE1",132,0) K ^TMP($J) "RTN","RMPRPCE1",133,0) K RMPR,RMPRSTE "RTN","RMPRPCE1",134,0) K RMCODT "RTN","RMPRPCE1",135,0) D KILL^XUSCLEAN "RTN","RMPRPCE1",136,0) Q "RTN","RMPRPCE1",137,0) ; "RTN","RMPRPCE1",138,0) SCRS ;set consult request service. "RTN","RMPRPCE1",139,0) ;start conversion on 1/1/2002, the date of PCE/Link to suspense patch. "RTN","RMPRPCE1",140,0) W !!,"Setting Consult Request Service in file #660....." "RTN","RMPRPCE1",141,0) N RI,RJ F RI=3020100:0 S RI=$O(^RMPR(660,"B",RI)) Q:RI'>0 F RJ=0:0 S RJ=$O(^RMPR(660,"B",RI,RJ)) Q:RJ'>0 I $D(^RMPR(660,RJ,10)) D "RTN","RMPRPCE1",142,0) .K RMAA "RTN","RMPRPCE1",143,0) .S RMREQU=$P(^RMPR(660,RJ,10),U,6) "RTN","RMPRPCE1",144,0) .S RMSERV="" "RTN","RMPRPCE1",145,0) .I $G(RMREQU) D GETS^DIQ(200,RMREQU,"29","E","RMAA") S RMSERV=RMAA(200,RMREQU_",",29,"E") "RTN","RMPRPCE1",146,0) .S:RMSERV'="" $P(^RMPR(660,RJ,4),U,3)=RMSERV "RTN","RMPRPCE1",147,0) W !!,"Done setting Consult Request Service!!",! "RTN","RMPRPCE1",148,0) Q "RTN","RMPRPCE1",149,0) ; "RTN","RMPRPCE1",150,0) NEWVAR N DA,DIE,DIC,I,J,RMDFN,RMI,RMDATE,RM680,RM688,RM6810,RMERROR "RTN","RMPRPCE1",151,0) N RMERR,RMCHK,RMAMIS,DLAYGO,X,DR,RMAA,RMSERV,RMREQU,RMDAT "RTN","RMPRPCE1",152,0) N RMPRL,RM68BA,RMDWRT,RMICD9,RMINDT,RMPRCO,RMPRDI,RMSTAT,RMTRES,RMTYRE "RTN","RMPRPCE1",153,0) Q "VER") 8.0^22.0 "BLD",6947,6) ^127 **END** **END**