- 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 Feb 18, 2025@23:58:35 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
