RMPR29CA ;OI-HINES/HNC,SPS -WORK ORDER SUSPENSE RPC;12/27/2004
;;3.0;PROSTHETICS;**75,122,142,144**;Feb 09, 1996;Build 17
A1(RMIE68,RMPRDUZ,RMSUSTAT,RMPR6641,RMPRTXT) ;roll and scroll entry point
G A2
EN(RESULTS,RMIE68,RMPRDUZ,RMSUSTAT,RMPR6641,RMPRTXT) ;RPC entry point
A2 ;
S RESULTS(0)="",STP=0
K ^TMP($J)
;
CONT ;RMSUSTAT is status 1=complete or 0=initial note or 2=pending (incomplete)
;3=cancel or 4=cancel and clone
S RMIE=0
F S RMIE=$O(^RMPR(664.1,RMPR6641,2,RMIE)) Q:RMIE'>0 D Q:STP=1
.S RMIE60=$P(^RMPR(664.1,RMPR6641,2,RMIE,0),U,5) Q:'RMIE60
.S ^TMP($J,RMIE60)=""
.D FD
.I STP=1 Q
.D UPD
I STP=1 G EXIT
I RMSUSTAT=1 D CNOTE
I RMSUSTAT=0 D INOTE,FD
I RMSUSTAT=2 D ONOTE,FD
I RMSUSTAT=3 D CANOTE^RMPR29CB
I RMSUSTAT=4 D CANOTE^RMPR29CB
;set status
G EXIT
CNOTE ;(#12) COMPLETION NOTE
;set file 668
;^RMPR(668,D0,4,0)=^668.012^^
;if status is close, or 1
;RMPRTXT ;load into field #12
;^RMPR(668,D0,4,D1,0)
;
;Update file 664.1 on Close out
I +$P(^RMPR(664.1,RMPR6641,0),U,16)'>0 S $P(^(0),U,16)=DUZ,$P(^(7),U,1)=DT,$P(^(7),U,3)=DUZ
S DIE="^RMPR(664.1,",DA=RMPR6641
S DR="16////^S X=""C"";22////^S X=DUZ;23///^S X=DT" D ^DIE
K DR,DA,DIE
S RMIE=0 D NOW^%DTC S (RMPREODT,GMRCAD)=%
F S RMIE=$O(^RMPR(664.1,RMPR6641,2,RMIE)) Q:RMIE'>0 D
.S DIE="^RMPR(664.2,",DA=$P($G(^RMPR(664.1,RMPR6641,2,RMIE,0)),U,6)
.Q:DA'>0
.S DR="8////^S X=DT;9////^S X=DUZ" D ^DIE
.K DA,DR,DIE
.S DIE="^RMPR(660,",DA=$P($G(^RMPR(664.1,RMPR6641,2,RMIE,0)),U,5)
.Q:DA'>0
.S DR="8.4////^S X=RMPREODT;10////^S X=RMPREODT;50////^S X=DT" D ^DIE
.K DA,DR,DIE
S DA=RMIE68
S DIE="^RMPR(668,"
S DR="5////^S X=RMPREODT;6////^S X=DUZ;14///^S X=""C""" D ^DIE
N RMPRC
S L="",LN=0
F S L=$O(RMPRTXT(L)) Q:L="" D
. I 'LN D Q:RMPRC="" ;strip leading space from 1st line, ignore blank line
.. S RMPRC=$E($TR(RMPRTXT(L)," ","")) ;1st non space char
.. 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
.. Q
. S LN=LN+1,^RMPR(668,RMIE68,4,LN,0)=RMPRTXT(L)
. Q
S $P(^RMPR(668,RMIE68,4,0),"^",3)=LN
K L,LN
;S DA=RMIE68,DIK="^RMPR(668," D IX1^DIK
I '$P(^RMPR(668,DA,0),U,9) D
.S DIE="^RMPR(668,"
.S DR="7///^S X=""See Completion Note for Initial Action Taken."""
.D ^DIE
.S DR="10////^S X=RMPREODT;16////^S X=DUZ" D ^DIE
K RMPREODT
S GMRCO=$P(^RMPR(668,RMIE68,0),U,15)
I GMRCO="" S RESULTS(0)="0^Completed Manual Suspense Action. Suspense status has been updated to CLOSED." Q
S RMPRCOM=0
F S RMPRCOM=$O(^RMPR(668,RMIE68,4,RMPRCOM)) Q:RMPRCOM="" D
.S GMRCOM(RMPRCOM)=^RMPR(668,RMIE68,4,RMPRCOM,0)
I $G(GMRCOM)="" S GMRCOM="Not Noted"
S GMRCSF="U"
S GMRCA=10
S GMRCALF="N"
S GMRCATO=""
S (GMRCORNP,GMRCDUZ)=DUZ
S BDC=$$SFILE^GMRCGUIB(.GMRCO,.GMRCA,.GMRCSF,.GMRCORNP,.GMRCDUZ,.GMRCOM,.GMRCALF,.GMRCATO,.GMRCAD)
I +BDC=1 S RESULTS(0)=1_"^"_$P(BDC,U,2)
K GMRCO,GMRCA,GMRCSF,GMRCORNP,GMRCDUZ,GMRCOM,GMRCALF,GMRCATO,GMRCAD
I RESULTS(0)="" S RESULTS(0)="0^Completed Suspense Action, and Posted note to CPRS Consult. Suspense status has been updated to CLOSED."
Q
ONOTE ;Other note
;set file 668
;^RMPR(668,D0,4,0)=^668.012^^
;if status is pending, and already initial action note or 0
;^RMPR(668,D0,1,D1,0)= (#.01) ACTION DATE [1D]
;RMPRTXT ;load into field #11, #1
;^RMPR(668,D0,1,D1,1,0)=^668.111^^
;
S RMPRDA1=RMIE68,DA(1)=RMIE68,DA=RMIE68
D NOW^%DTC S X=%,GMRCWHN=%
S DIC="^RMPR(668,"_RMIE68_",1,"
S DIC(0)="CQL"
S DIC("P")="668.011DA"
S DLAYGO=668
D ^DIC
I Y=-1 S RESULTS(0)="1^Error Modifying Record!" Q
S (DA,RMPRDA2)=+Y
K DIE,DR,Y
N RMPRC
S L="",LN=0
F S L=$O(RMPRTXT(L)) Q:L="" D
. I 'LN D Q:RMPRC="" ;strip leading space from 1st line, ignore blank line
.. S RMPRC=$E($TR(RMPRTXT(L)," ","")) ;1st non space char
.. 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
.. Q
. S LN=LN+1,^RMPR(668,RMIE68,1,RMPRDA2,1,LN,0)=RMPRTXT(L)
. Q
S $P(^RMPR(668,RMIE68,1,RMPRDA2,1,0),"^",3)=LN
K L,LN
S GMRCO=$P(^RMPR(668,RMIE68,0),U,15)
I GMRCO="" S RESULTS(0)="0^Completed Manual Suspense Action. Suspense status has not changed." Q
S RMPRCOM=0
F S RMPRCOM=$O(^RMPR(668,RMIE68,1,RMPRDA2,1,RMPRCOM)) Q:RMPRCOM="" D
.S GMRCOM(RMPRCOM)=^RMPR(668,RMIE68,1,RMPRDA2,1,RMPRCOM,0)
D CMT^GMRCGUIB(.GMRCO,.GMRCOM,"",GMRCWHN,DUZ)
K DA,RMPRDA1,RMPRDA2,RMPRCOM,GMRCOM,GMRCO,GMRCWHN
S RESULTS(0)="0^Completed Suspense Action, and Posted note to CPRS Consult. Suspense status has not changed."
Q
INOTE ;initial action note
;set file 668
;^RMPR(668,D0,3,0)=^668.07^^
;if status is pending, or 0
;RMPRTXT ;load into field #7
;^RMPR(668,D0,3,0)=^668.07^^
;
I $D(^RMPR(668,RMIE68,3,1,0)) S RESULTS(0)="1^Initial Action Note Already Posted!" Q
D NOW^%DTC S RMPREODT=%
N RMPRC
S ^RMPR(668,RMIE68,3,0)="^^^"_DT_"^"
S L="",LN=0
F S L=$O(RMPRTXT(L)) Q:L="" D
. I 'LN D Q:RMPRC="" ;strip leading space from 1st line, ignore blank line
.. S RMPRC=$E($TR(RMPRTXT(L)," ","")) ;1st non space char
.. 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
.. Q
. S LN=LN+1,^RMPR(668,RMIE68,3,LN,0)=RMPRTXT(L)
. Q
S $P(^RMPR(668,RMIE68,3,0),"^",3)=LN
K L,LN
S DIE="^RMPR(668,"
S DA=RMIE68
S DR="10////^S X=RMPREODT;16////^S X=DUZ;14///^S X=""P"""
D ^DIE
S GMRCO=$P(^RMPR(668,RMIE68,0),U,15)
I GMRCO="" S RESULTS(0)="0^Completed Manual Suspense Action. Suspense status has been updated to PENDING" Q
S RMPRCMT=0
F S RMPRCMT=$O(^RMPR(668,RMIE68,3,RMPRCMT)) Q:RMPRCMT="" D
.S GMRCMT(RMPRCMT)=^RMPR(668,RMIE68,3,RMPRCMT,0)
D CMT^GMRCGUIB(GMRCO,.GMRCMT,DUZ,RMPREODT,DUZ)
K RMPREODT,GMRCO,RMGMRCO,GMRCMT,RMPRCMT
S RESULTS(0)="0^Completed Suspense Action, and Posted note to CPRS Consult. Suspense status has changed to PENDING."
Q
;
FD ;file date
N DIE,DIC,I,J,Y,RMDFN,RMI,RMDATE,RM680,RM6810,RMERROR,RM60L,RC
N RMERR,RMCHK,DLAYGO,X,DR,RM668,RM60DAT,RMSTATUS
N RM68CNT,RM60CNT,RMREQU,RMSI,RMSAMIS,RM68IEN,RM60IEN,RMSUS60,RMSUS68,RMD
N RM68DATA,RM60TYP,RM68D,RM68TRAN,RMPRPRC,RM60IT,RMENTSUS,RMQUIT
;
S RMERR=0
S:RMSUSTAT="" RMSUSTAT=0
L +^RMPR(660,RMIE60):2
I $T=0 S RESULTS(0)="1^Someone else is Editing this entry! If this problem persists contact your IRM to clear the Lock Table",STP=1 Q
S RM680=$G(^RMPR(668,RMIE68,0))
S RM688=$G(^RMPR(668,RMIE68,8))
S RM6810=$G(^RMPR(668,RMIE68,10))
S RMAMIS=$P($G(^RMPR(660,RMIE60,"AMS")),U,1)
;code here for 668 fields
S RMDATE=$P(RM680,U,1)
S RMCODT=$P(RM680,U,5)
S RMINDT=$P(RM680,U,9)
S RMPRCO=$P(RM680,U,15)
S RMDWRT=$P(RM680,U,16)
S RMSTAT=$P(RM680,U,7)
S RMTRES=$P(RM680,U,8)
S RMTYRE=$S(RMTRES=1:"ROUTINE",RMTRES=2:"EYEGLASS",RMTRES=3:"CONTACT LENS",RMTRES=4:"OXYGEN",RMTRES=5:"MANUAL",RMTRES=11:"LAB",1:"")
S RMREQU=$P(RM680,U,11)
S RMSERV=""
I $G(RMREQU) D GETS^DIQ(200,RMREQU,"29","E","RMAA") S RMSERV=RMAA(200,RMREQU_",",29,"E")
S RMPRDI=$E($P(RM688,U,2),1,16)
S RMICD9=$P(RM688,U,3)
;
S RMDAT(660,RMIE60_",",8.1)=RMDATE
S RMDAT(660,RMIE60_",",8.2)=RMDWRT
S RMDAT(660,RMIE60_",",8.3)=RMINDT
S RMDAT(660,RMIE60_",",8.4)=RMCODT
S RMDAT(660,RMIE60_",",8.5)=RMTYRE
S RMDAT(660,RMIE60_",",8.6)=RMREQU
S RMDAT(660,RMIE60_",",8.61)=RMSERV
S RMDAT(660,RMIE60_",",8.7)=RMPRDI
S RMDAT(660,RMIE60_",",8.8)=RMICD9
S RMDAT(660,RMIE60_",",8.9)=RMPRCO
S RMDAT(660,RMIE60_",",8.11)=RMSTAT
I RMSUSTAT=2 S RMDAT(660,RMIE60_",",8.14)=0
I RMSUSTAT'=2 S RMDAT(660,RMIE60_",",8.14)=RMSUSTAT
D FILE^DIE("","RMDAT","RMERROR")
L -^RMPR(660,RMIE60)
I $D(RMERROR) S RMERR=1,STP=1 G ERR
;
Q
UPD ;update file 668 with 2319 records
K DD,DO,DIC
S DA(1)=RMIE68
S DIC="^RMPR(668,"_DA(1)_","_"10,"
S DIC(0)="L",DLAYGO=668,X=RMIE60
D FILE^DICN
K X,DD,DO,DIC
S DA(1)=RMIE68,DIC(0)="L",DLAYGO=668
S DIC="^RMPR(668,"_DA(1)_","_"11,"
S X=RMAMIS
D FILE^DICN
K DIC,X,DLAYGO,DO
Q
A3 G A4
EN1(RESULTS,DA) ;Broker entry to kill WO
;DA is passed
S DIK="^RMPR(664.1," D ^DIK
K DIK
A4 ;
Q
ERR ;exit on error
S RESULTS(0)="1^ERROR WAS "_RMERROR("DIERR",1,"TEXT",1)
Q
EXIT ;
K %,BDC,RM688,RMAA,RMAMIS,RMCODT,RMDAT,RMDWRT,RMICD9,RMIE,RMIE60,RMINDT
K RMPRCO,RMPRDI,RMSERV,RMSTAT,RMTRES,RMTYRE,STP
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPR29CA 8410 printed Dec 13, 2024@02:32:06 Page 2
RMPR29CA ;OI-HINES/HNC,SPS -WORK ORDER SUSPENSE RPC;12/27/2004
+1 ;;3.0;PROSTHETICS;**75,122,142,144**;Feb 09, 1996;Build 17
A1(RMIE68,RMPRDUZ,RMSUSTAT,RMPR6641,RMPRTXT) ;roll and scroll entry point
+1 GOTO A2
EN(RESULTS,RMIE68,RMPRDUZ,RMSUSTAT,RMPR6641,RMPRTXT) ;RPC entry point
A2 ;
+1 SET RESULTS(0)=""
SET STP=0
+2 KILL ^TMP($JOB)
+3 ;
CONT ;RMSUSTAT is status 1=complete or 0=initial note or 2=pending (incomplete)
+1 ;3=cancel or 4=cancel and clone
+2 SET RMIE=0
+3 FOR
SET RMIE=$ORDER(^RMPR(664.1,RMPR6641,2,RMIE))
if RMIE'>0
QUIT
Begin DoDot:1
+4 SET RMIE60=$PIECE(^RMPR(664.1,RMPR6641,2,RMIE,0),U,5)
if 'RMIE60
QUIT
+5 SET ^TMP($JOB,RMIE60)=""
+6 DO FD
+7 IF STP=1
QUIT
+8 DO UPD
End DoDot:1
if STP=1
QUIT
+9 IF STP=1
GOTO EXIT
+10 IF RMSUSTAT=1
DO CNOTE
+11 IF RMSUSTAT=0
DO INOTE
DO FD
+12 IF RMSUSTAT=2
DO ONOTE
DO FD
+13 IF RMSUSTAT=3
DO CANOTE^RMPR29CB
+14 IF RMSUSTAT=4
DO CANOTE^RMPR29CB
+15 ;set status
+16 GOTO EXIT
CNOTE ;(#12) COMPLETION NOTE
+1 ;set file 668
+2 ;^RMPR(668,D0,4,0)=^668.012^^
+3 ;if status is close, or 1
+4 ;RMPRTXT ;load into field #12
+5 ;^RMPR(668,D0,4,D1,0)
+6 ;
+7 ;Update file 664.1 on Close out
+8 IF +$PIECE(^RMPR(664.1,RMPR6641,0),U,16)'>0
SET $PIECE(^(0),U,16)=DUZ
SET $PIECE(^(7),U,1)=DT
SET $PIECE(^(7),U,3)=DUZ
+9 SET DIE="^RMPR(664.1,"
SET DA=RMPR6641
+10 SET DR="16////^S X=""C"";22////^S X=DUZ;23///^S X=DT"
DO ^DIE
+11 KILL DR,DA,DIE
+12 SET RMIE=0
DO NOW^%DTC
SET (RMPREODT,GMRCAD)=%
+13 FOR
SET RMIE=$ORDER(^RMPR(664.1,RMPR6641,2,RMIE))
if RMIE'>0
QUIT
Begin DoDot:1
+14 SET DIE="^RMPR(664.2,"
SET DA=$PIECE($GET(^RMPR(664.1,RMPR6641,2,RMIE,0)),U,6)
+15 if DA'>0
QUIT
+16 SET DR="8////^S X=DT;9////^S X=DUZ"
DO ^DIE
+17 KILL DA,DR,DIE
+18 SET DIE="^RMPR(660,"
SET DA=$PIECE($GET(^RMPR(664.1,RMPR6641,2,RMIE,0)),U,5)
+19 if DA'>0
QUIT
+20 SET DR="8.4////^S X=RMPREODT;10////^S X=RMPREODT;50////^S X=DT"
DO ^DIE
+21 KILL DA,DR,DIE
End DoDot:1
+22 SET DA=RMIE68
+23 SET DIE="^RMPR(668,"
+24 SET DR="5////^S X=RMPREODT;6////^S X=DUZ;14///^S X=""C"""
DO ^DIE
+25 NEW RMPRC
+26 SET L=""
SET LN=0
+27 FOR
SET L=$ORDER(RMPRTXT(L))
if L=""
QUIT
Begin DoDot:1
+28 ;strip leading space from 1st line, ignore blank line
IF 'LN
Begin DoDot:2
+29 ;1st non space char
SET RMPRC=$EXTRACT($TRANSLATE(RMPRTXT(L)," ",""))
+30 ;extract from 1st non space char to end of line
if RMPRC'=""
SET RMPRTXT(L)=$EXTRACT(RMPRTXT(L),$FIND(RMPRTXT(L),RMPRC)-1,$LENGTH(RMPRTXT(L)))
+31 QUIT
End DoDot:2
if RMPRC=""
QUIT
+32 SET LN=LN+1
SET ^RMPR(668,RMIE68,4,LN,0)=RMPRTXT(L)
+33 QUIT
End DoDot:1
+34 SET $PIECE(^RMPR(668,RMIE68,4,0),"^",3)=LN
+35 KILL L,LN
+36 ;S DA=RMIE68,DIK="^RMPR(668," D IX1^DIK
+37 IF '$PIECE(^RMPR(668,DA,0),U,9)
Begin DoDot:1
+38 SET DIE="^RMPR(668,"
+39 SET DR="7///^S X=""See Completion Note for Initial Action Taken."""
+40 DO ^DIE
+41 SET DR="10////^S X=RMPREODT;16////^S X=DUZ"
DO ^DIE
End DoDot:1
+42 KILL RMPREODT
+43 SET GMRCO=$PIECE(^RMPR(668,RMIE68,0),U,15)
+44 IF GMRCO=""
SET RESULTS(0)="0^Completed Manual Suspense Action. Suspense status has been updated to CLOSED."
QUIT
+45 SET RMPRCOM=0
+46 FOR
SET RMPRCOM=$ORDER(^RMPR(668,RMIE68,4,RMPRCOM))
if RMPRCOM=""
QUIT
Begin DoDot:1
+47 SET GMRCOM(RMPRCOM)=^RMPR(668,RMIE68,4,RMPRCOM,0)
End DoDot:1
+48 IF $GET(GMRCOM)=""
SET GMRCOM="Not Noted"
+49 SET GMRCSF="U"
+50 SET GMRCA=10
+51 SET GMRCALF="N"
+52 SET GMRCATO=""
+53 SET (GMRCORNP,GMRCDUZ)=DUZ
+54 SET BDC=$$SFILE^GMRCGUIB(.GMRCO,.GMRCA,.GMRCSF,.GMRCORNP,.GMRCDUZ,.GMRCOM,.GMRCALF,.GMRCATO,.GMRCAD)
+55 IF +BDC=1
SET RESULTS(0)=1_"^"_$PIECE(BDC,U,2)
+56 KILL GMRCO,GMRCA,GMRCSF,GMRCORNP,GMRCDUZ,GMRCOM,GMRCALF,GMRCATO,GMRCAD
+57 IF RESULTS(0)=""
SET RESULTS(0)="0^Completed Suspense Action, and Posted note to CPRS Consult. Suspense status has been updated to CLOSED."
+58 QUIT
ONOTE ;Other note
+1 ;set file 668
+2 ;^RMPR(668,D0,4,0)=^668.012^^
+3 ;if status is pending, and already initial action note or 0
+4 ;^RMPR(668,D0,1,D1,0)= (#.01) ACTION DATE [1D]
+5 ;RMPRTXT ;load into field #11, #1
+6 ;^RMPR(668,D0,1,D1,1,0)=^668.111^^
+7 ;
+8 SET RMPRDA1=RMIE68
SET DA(1)=RMIE68
SET DA=RMIE68
+9 DO NOW^%DTC
SET X=%
SET GMRCWHN=%
+10 SET DIC="^RMPR(668,"_RMIE68_",1,"
+11 SET DIC(0)="CQL"
+12 SET DIC("P")="668.011DA"
+13 SET DLAYGO=668
+14 DO ^DIC
+15 IF Y=-1
SET RESULTS(0)="1^Error Modifying Record!"
QUIT
+16 SET (DA,RMPRDA2)=+Y
+17 KILL DIE,DR,Y
+18 NEW RMPRC
+19 SET L=""
SET LN=0
+20 FOR
SET L=$ORDER(RMPRTXT(L))
if L=""
QUIT
Begin DoDot:1
+21 ;strip leading space from 1st line, ignore blank line
IF 'LN
Begin DoDot:2
+22 ;1st non space char
SET RMPRC=$EXTRACT($TRANSLATE(RMPRTXT(L)," ",""))
+23 ;extract from 1st non space char to end of line
if RMPRC'=""
SET RMPRTXT(L)=$EXTRACT(RMPRTXT(L),$FIND(RMPRTXT(L),RMPRC)-1,$LENGTH(RMPRTXT(L)))
+24 QUIT
End DoDot:2
if RMPRC=""
QUIT
+25 SET LN=LN+1
SET ^RMPR(668,RMIE68,1,RMPRDA2,1,LN,0)=RMPRTXT(L)
+26 QUIT
End DoDot:1
+27 SET $PIECE(^RMPR(668,RMIE68,1,RMPRDA2,1,0),"^",3)=LN
+28 KILL L,LN
+29 SET GMRCO=$PIECE(^RMPR(668,RMIE68,0),U,15)
+30 IF GMRCO=""
SET RESULTS(0)="0^Completed Manual Suspense Action. Suspense status has not changed."
QUIT
+31 SET RMPRCOM=0
+32 FOR
SET RMPRCOM=$ORDER(^RMPR(668,RMIE68,1,RMPRDA2,1,RMPRCOM))
if RMPRCOM=""
QUIT
Begin DoDot:1
+33 SET GMRCOM(RMPRCOM)=^RMPR(668,RMIE68,1,RMPRDA2,1,RMPRCOM,0)
End DoDot:1
+34 DO CMT^GMRCGUIB(.GMRCO,.GMRCOM,"",GMRCWHN,DUZ)
+35 KILL DA,RMPRDA1,RMPRDA2,RMPRCOM,GMRCOM,GMRCO,GMRCWHN
+36 SET RESULTS(0)="0^Completed Suspense Action, and Posted note to CPRS Consult. Suspense status has not changed."
+37 QUIT
INOTE ;initial action note
+1 ;set file 668
+2 ;^RMPR(668,D0,3,0)=^668.07^^
+3 ;if status is pending, or 0
+4 ;RMPRTXT ;load into field #7
+5 ;^RMPR(668,D0,3,0)=^668.07^^
+6 ;
+7 IF $DATA(^RMPR(668,RMIE68,3,1,0))
SET RESULTS(0)="1^Initial Action Note Already Posted!"
QUIT
+8 DO NOW^%DTC
SET RMPREODT=%
+9 NEW RMPRC
+10 SET ^RMPR(668,RMIE68,3,0)="^^^"_DT_"^"
+11 SET L=""
SET LN=0
+12 FOR
SET L=$ORDER(RMPRTXT(L))
if L=""
QUIT
Begin DoDot:1
+13 ;strip leading space from 1st line, ignore blank line
IF 'LN
Begin DoDot:2
+14 ;1st non space char
SET RMPRC=$EXTRACT($TRANSLATE(RMPRTXT(L)," ",""))
+15 ;extract from 1st non space char to end of line
if RMPRC'=""
SET RMPRTXT(L)=$EXTRACT(RMPRTXT(L),$FIND(RMPRTXT(L),RMPRC)-1,$LENGTH(RMPRTXT(L)))
+16 QUIT
End DoDot:2
if RMPRC=""
QUIT
+17 SET LN=LN+1
SET ^RMPR(668,RMIE68,3,LN,0)=RMPRTXT(L)
+18 QUIT
End DoDot:1
+19 SET $PIECE(^RMPR(668,RMIE68,3,0),"^",3)=LN
+20 KILL L,LN
+21 SET DIE="^RMPR(668,"
+22 SET DA=RMIE68
+23 SET DR="10////^S X=RMPREODT;16////^S X=DUZ;14///^S X=""P"""
+24 DO ^DIE
+25 SET GMRCO=$PIECE(^RMPR(668,RMIE68,0),U,15)
+26 IF GMRCO=""
SET RESULTS(0)="0^Completed Manual Suspense Action. Suspense status has been updated to PENDING"
QUIT
+27 SET RMPRCMT=0
+28 FOR
SET RMPRCMT=$ORDER(^RMPR(668,RMIE68,3,RMPRCMT))
if RMPRCMT=""
QUIT
Begin DoDot:1
+29 SET GMRCMT(RMPRCMT)=^RMPR(668,RMIE68,3,RMPRCMT,0)
End DoDot:1
+30 DO CMT^GMRCGUIB(GMRCO,.GMRCMT,DUZ,RMPREODT,DUZ)
+31 KILL RMPREODT,GMRCO,RMGMRCO,GMRCMT,RMPRCMT
+32 SET RESULTS(0)="0^Completed Suspense Action, and Posted note to CPRS Consult. Suspense status has changed to PENDING."
+33 QUIT
+34 ;
FD ;file date
+1 NEW DIE,DIC,I,J,Y,RMDFN,RMI,RMDATE,RM680,RM6810,RMERROR,RM60L,RC
+2 NEW RMERR,RMCHK,DLAYGO,X,DR,RM668,RM60DAT,RMSTATUS
+3 NEW RM68CNT,RM60CNT,RMREQU,RMSI,RMSAMIS,RM68IEN,RM60IEN,RMSUS60,RMSUS68,RMD
+4 NEW RM68DATA,RM60TYP,RM68D,RM68TRAN,RMPRPRC,RM60IT,RMENTSUS,RMQUIT
+5 ;
+6 SET RMERR=0
+7 if RMSUSTAT=""
SET RMSUSTAT=0
+8 LOCK +^RMPR(660,RMIE60):2
+9 IF $TEST=0
SET RESULTS(0)="1^Someone else is Editing this entry! If this problem persists contact your IRM to clear the Lock Table"
SET STP=1
QUIT
+10 SET RM680=$GET(^RMPR(668,RMIE68,0))
+11 SET RM688=$GET(^RMPR(668,RMIE68,8))
+12 SET RM6810=$GET(^RMPR(668,RMIE68,10))
+13 SET RMAMIS=$PIECE($GET(^RMPR(660,RMIE60,"AMS")),U,1)
+14 ;code here for 668 fields
+15 SET RMDATE=$PIECE(RM680,U,1)
+16 SET RMCODT=$PIECE(RM680,U,5)
+17 SET RMINDT=$PIECE(RM680,U,9)
+18 SET RMPRCO=$PIECE(RM680,U,15)
+19 SET RMDWRT=$PIECE(RM680,U,16)
+20 SET RMSTAT=$PIECE(RM680,U,7)
+21 SET RMTRES=$PIECE(RM680,U,8)
+22 SET RMTYRE=$SELECT(RMTRES=1:"ROUTINE",RMTRES=2:"EYEGLASS",RMTRES=3:"CONTACT LENS",RMTRES=4:"OXYGEN",RMTRES=5:"MANUAL",RMTRES=11:"LAB",1:"")
+23 SET RMREQU=$PIECE(RM680,U,11)
+24 SET RMSERV=""
+25 IF $GET(RMREQU)
DO GETS^DIQ(200,RMREQU,"29","E","RMAA")
SET RMSERV=RMAA(200,RMREQU_",",29,"E")
+26 SET RMPRDI=$EXTRACT($PIECE(RM688,U,2),1,16)
+27 SET RMICD9=$PIECE(RM688,U,3)
+28 ;
+29 SET RMDAT(660,RMIE60_",",8.1)=RMDATE
+30 SET RMDAT(660,RMIE60_",",8.2)=RMDWRT
+31 SET RMDAT(660,RMIE60_",",8.3)=RMINDT
+32 SET RMDAT(660,RMIE60_",",8.4)=RMCODT
+33 SET RMDAT(660,RMIE60_",",8.5)=RMTYRE
+34 SET RMDAT(660,RMIE60_",",8.6)=RMREQU
+35 SET RMDAT(660,RMIE60_",",8.61)=RMSERV
+36 SET RMDAT(660,RMIE60_",",8.7)=RMPRDI
+37 SET RMDAT(660,RMIE60_",",8.8)=RMICD9
+38 SET RMDAT(660,RMIE60_",",8.9)=RMPRCO
+39 SET RMDAT(660,RMIE60_",",8.11)=RMSTAT
+40 IF RMSUSTAT=2
SET RMDAT(660,RMIE60_",",8.14)=0
+41 IF RMSUSTAT'=2
SET RMDAT(660,RMIE60_",",8.14)=RMSUSTAT
+42 DO FILE^DIE("","RMDAT","RMERROR")
+43 LOCK -^RMPR(660,RMIE60)
+44 IF $DATA(RMERROR)
SET RMERR=1
SET STP=1
GOTO ERR
+45 ;
+46 QUIT
UPD ;update file 668 with 2319 records
+1 KILL DD,DO,DIC
+2 SET DA(1)=RMIE68
+3 SET DIC="^RMPR(668,"_DA(1)_","_"10,"
+4 SET DIC(0)="L"
SET DLAYGO=668
SET X=RMIE60
+5 DO FILE^DICN
+6 KILL X,DD,DO,DIC
+7 SET DA(1)=RMIE68
SET DIC(0)="L"
SET DLAYGO=668
+8 SET DIC="^RMPR(668,"_DA(1)_","_"11,"
+9 SET X=RMAMIS
+10 DO FILE^DICN
+11 KILL DIC,X,DLAYGO,DO
+12 QUIT
A3 GOTO A4
EN1(RESULTS,DA) ;Broker entry to kill WO
+1 ;DA is passed
+2 SET DIK="^RMPR(664.1,"
DO ^DIK
+3 KILL DIK
A4 ;
+1 QUIT
ERR ;exit on error
+1 SET RESULTS(0)="1^ERROR WAS "_RMERROR("DIERR",1,"TEXT",1)
+2 QUIT
EXIT ;
+1 KILL %,BDC,RM688,RMAA,RMAMIS,RMCODT,RMDAT,RMDWRT,RMICD9,RMIE,RMIE60,RMINDT
+2 KILL RMPRCO,RMPRDI,RMSERV,RMSTAT,RMTRES,RMTYRE,STP
+3 QUIT
