RMPRPCE1 ;HCIOFO/RVD - Prosthetics/PCE UPDATE UTILITY ;5/7/03 09:12
;;3.0;PROSTHETICS;**62,69,77,78,146,163,171**;Feb 09, 1996;Build 1
;
;patch #69
;RVD 4/10/02 - validate the length (16 c) of provisional diagnosis
; before filing. Change Routine Prosthetic to ROUTINE
; Type of Request field in 660.
;RVD 5/6/03 patch #77 - SET Consult Request Service field in #660.
; - POST init for setting Consult Request Service.
;TH 9/29/03 Patch #78 - Add Billing Aware related fields.
;
;DBIA # 10060, Fileman read of file #200.
;
;This routine contains the code for updating file #660 and #668.
;
;RMIE60 - ien of file #660
UP60(RMIE60,RMIE68,RMSUSTAT) ; update file #660.
D NEWVAR
S RMERR=0
S:RMSUSTAT="" RMSUSTAT=0
L +^RMPR(660,RMIE60):2
I $T=0 W !,"Someone else is Editing this entry!!!",! H 3 S RMERR=1 G UP60X
S RM680=$G(^RMPR(668,RMIE68,0))
S RM688=$G(^RMPR(668,RMIE68,8))
S RM6810=$G(^RMPR(668,RMIE68,10))
;code here for 668 fields
S RMDATE=$P(RM680,U,1) ;Suspense Date
S RMCODT=$P(RM680,U,5) ;Completion Date
S RMINDT=$P(RM680,U,9) ;Initial Action Date
S RMPRCO=$P(RM680,U,15) ;Consult
S RMDWRT=$P(RM680,U,16) ;Date RX Written
S RMSTAT=$P(RM680,U,7) ;Station
S RMTRES=$P(RM680,U,8) ;Type of Request
S RMTYRE=$S(RMTRES=1:"ROUTINE",RMTRES=2:"EYEGLASS",RMTRES=3:"CONTACT LENS",RMTRES=4:"OXYGEN",RMTRES=5:"MANUAL",1:"")
S RMREQU=$P(RM680,U,11) ;Requestor (Ordering Provider)
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) ;Provisional Diagnosis
S RMICD9=$P(RM688,U,3) ;ICD9
;
S RMDAT(660,RMIE60_",",8.1)=RMDATE ;Suspense Date
S RMDAT(660,RMIE60_",",8.2)=RMDWRT ;Date RX Written
S RMDAT(660,RMIE60_",",8.3)=RMINDT ;Initial Action Date
S RMDAT(660,RMIE60_",",8.4)=RMCODT ;Completion Date
S RMDAT(660,RMIE60_",",8.5)=RMTYRE ;Type of Request
S RMDAT(660,RMIE60_",",8.6)=RMREQU ;Ordering Provider
S RMDAT(660,RMIE60_",",8.61)=RMSERV ;Consult Request Service
S RMDAT(660,RMIE60_",",8.7)=RMPRDI ;Provisional Diagnosis
S RMDAT(660,RMIE60_",",8.8)=RMICD9 ;Suspense ICD9
S RMDAT(660,RMIE60_",",8.9)=RMPRCO ;Pointer to Request/Consultation
S RMDAT(660,RMIE60_",",8.11)=RMSTAT ;Suspense Station
S RMDAT(660,RMIE60_",",8.14)=RMSUSTAT ;Suspense Status
;
; Patch #78
; #668,BA nodes
F RMPRL=1:1:99 S RM68BA=$G(^RMPR(668,RMIE68,"BA"_RMPRL)) Q:RM68BA="" D
. N RMICD,RMAO,RMIR,RMSC,RMEC,RMMST,RMHNC,RMCBV
. S RMICD=$P(RM68BA,U,1)
. S RMAO=$P(RM68BA,U,2)
. S RMIR=$P(RM68BA,U,3)
. S RMSC=$P(RM68BA,U,4)
. S RMEC=$P(RM68BA,U,5)
. S RMMST=$P(RM68BA,U,6)
. S RMHNC=$P(RM68BA,U,7)
. S RMCBV=$P(RM68BA,U,8)
. N RMPTR
. S RMPTR=29+RMPRL
. S RMDAT(660,RMIE60_",",RMPTR)=RMICD
. S RMDAT(660,RMIE60_",",RMPTR_".1")=RMAO
. S RMDAT(660,RMIE60_",",RMPTR_".2")=RMIR
. S RMDAT(660,RMIE60_",",RMPTR_".3")=RMSC
. S RMDAT(660,RMIE60_",",RMPTR_".4")=RMEC
. S RMDAT(660,RMIE60_",",RMPTR_".5")=RMMST
. S RMDAT(660,RMIE60_",",RMPTR_".6")=RMHNC
. S RMDAT(660,RMIE60_",",RMPTR_".7")=RMCBV
;
D UPDATE^DIE("","RMDAT",,"RMERROR")
I $D(RMERROR) S RMERR=1 D ERR0
;
L -^RMPR(660,RMIE60)
UP60X ; exit point
Q RMERR
;
;RMIE60 = IEN of file #660.
;RMIE68 = IEN of file #668.
UP68(RMIE60,RMIE68,RMAMIS) ; update file #668.
D NEWVAR
S (RMI,RMERR)=0
;S RMAMIS=$G(^RMPR(660,RMIE60,"AMS"))
I '$G(RMAMIS) D ERR8 S RMERR=1 G UP68X
;L +^RMPR(668,RMIE68):2
;I $T=0 W !,"Someone else is Editing this entry!!!",! H 3 S RMERR=1 G UP68X
I $D(^RMPR(668,RMIE68,10,"B",RMIE60)) G UP68X
S DA(1)=RMIE68 K DD,DO
S DIC="^RMPR(668,"_DA(1)_","_"10,",DIC(0)="L",DLAYGO=668,X=RMIE60
D FILE^DICN K DIC,X,DLAYGO,DD,DO
I Y=-1 S RMERR=1 D ERR8 G UNL68
I $D(^RMPR(668,RMIE68,11,"B",RMAMIS)) G UP68X
S DA(1)=RMIE68
S DIC="^RMPR(668,"_DA(1)_","_"11,",DIC(0)="L",DLAYGO=668,X=RMAMIS
D FILE^DICN K DIC
I Y=-1 S RMERR=1 D ERR8 G UNL68
;
UNL68 ;L -^RMPR(668,RMIE68)
UP68X ; exit point
Q RMERR
;
ERR0 ;error updating file #660
W !,"*** Error updating file #660 in PCE module!!!",!
Q
ERR8 ;error updating file #668
W !,"*** Error updating file #668 in PCE module!!!",!
Q
LINK ;link 2319 to suspense
N IEN660,XIEN,CTR,R10
D DIV4^RMPRSIT Q:$D(X)
K ^TMP($J)
;Patch RMPR*3.0*163 will first find the patient in the suspense file to insure there are unlinked transactions, message/exit if not
;if unlinked transactions it will then make call to file 660 to display available items to be linked
D GETPAT^RMPRUTIL G:$D(X) EXIT
S IEN660=+DFN,XIEN=0,CTR=0
;Patch RMPR*3.0*171 Insure node ^RMPR(660,IEN660,10) exists, if not, count as unlinked
F I=1:1 S XIEN=$O(^RMPR(660,"C",IEN660,XIEN)) Q:XIEN="" S R10=$G(^RMPR(660,XIEN,10)) S:R10="" CTR=1 Q:CTR I $P(R10,U,14)'=1,$D(^RMPR(660,XIEN,"AMS")),RMPR("STA")=$P($G(^RMPR(660,XIEN,0)),U,10) S CTR=1 Q
I CTR'=1 W !,?2,$C(7),">> NO patient unlinked items available to be posted to Suspense, hit return" R CTR:15 G EXIT
W ! S DIC="^RMPR(660,",DIC(0)="EQZ",D="C",X=+DFN
S DIC("S")="S RMZ=$G(^RMPR(660,+Y,10)) I $P(RMZ,U,14)'=1,$D(^(""AMS"")),RMPR(""STA"")=$P(^(0),U,10)"
S DIC("W")="D EN^RMPRD1"
W !
D IX^DIC G:Y'>0 EXIT
L +^RMPR(660,+Y):1 I $T=0 W !,?5,$C(7),"Someone else is Editing this entry!" G EXIT
S RMPRDA=+Y
S RMPRDFN=$P(^RMPR(660,+Y,0),U,2)
I $D(^RMPR(660,+Y,"AMS")) N RMPRAMIS S RMPRAMIS=$P(^RMPR(660,+Y,"AMS"),U,1)
S ^TMP($J,"RMPRPCE",660,+Y)=RMPRAMIS_"^"_RMPRDFN
D LINK^RMPRS
I $G(RMPRDA)="" S RMPRDA=$O(^TMP($J,"RMPRPCE",660,0))
I $G(RMPRDA)="" L G EXIT
L -^RMPR(660,RMPRDA)
EXIT ;quit
K ^TMP($J)
K RMPR,RMPRSTE
K RMCODT
D KILL^XUSCLEAN
Q
;
SCRS ;set consult request service.
;start conversion on 1/1/2002, the date of PCE/Link to suspense patch.
W !!,"Setting Consult Request Service in file #660....."
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
.K RMAA
.S RMREQU=$P(^RMPR(660,RJ,10),U,6)
.S RMSERV=""
.I $G(RMREQU) D GETS^DIQ(200,RMREQU,"29","E","RMAA") S RMSERV=RMAA(200,RMREQU_",",29,"E")
.S:RMSERV'="" $P(^RMPR(660,RJ,4),U,3)=RMSERV
W !!,"Done setting Consult Request Service!!",!
Q
;
NEWVAR N DA,DIE,DIC,I,J,RMDFN,RMI,RMDATE,RM680,RM688,RM6810,RMERROR
N RMERR,RMCHK,RMAMIS,DLAYGO,X,DR,RMAA,RMSERV,RMREQU,RMDAT
N RMPRL,RM68BA,RMDWRT,RMICD9,RMINDT,RMPRCO,RMPRDI,RMSTAT,RMTRES,RMTYRE
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRPCE1 6521 printed Oct 16, 2024@18:36:21 Page 2
RMPRPCE1 ;HCIOFO/RVD - Prosthetics/PCE UPDATE UTILITY ;5/7/03 09:12
+1 ;;3.0;PROSTHETICS;**62,69,77,78,146,163,171**;Feb 09, 1996;Build 1
+2 ;
+3 ;patch #69
+4 ;RVD 4/10/02 - validate the length (16 c) of provisional diagnosis
+5 ; before filing. Change Routine Prosthetic to ROUTINE
+6 ; Type of Request field in 660.
+7 ;RVD 5/6/03 patch #77 - SET Consult Request Service field in #660.
+8 ; - POST init for setting Consult Request Service.
+9 ;TH 9/29/03 Patch #78 - Add Billing Aware related fields.
+10 ;
+11 ;DBIA # 10060, Fileman read of file #200.
+12 ;
+13 ;This routine contains the code for updating file #660 and #668.
+14 ;
+15 ;RMIE60 - ien of file #660
UP60(RMIE60,RMIE68,RMSUSTAT) ; update file #660.
+1 DO NEWVAR
+2 SET RMERR=0
+3 if RMSUSTAT=""
SET RMSUSTAT=0
+4 LOCK +^RMPR(660,RMIE60):2
+5 IF $TEST=0
WRITE !,"Someone else is Editing this entry!!!",!
HANG 3
SET RMERR=1
GOTO UP60X
+6 SET RM680=$GET(^RMPR(668,RMIE68,0))
+7 SET RM688=$GET(^RMPR(668,RMIE68,8))
+8 SET RM6810=$GET(^RMPR(668,RMIE68,10))
+9 ;code here for 668 fields
+10 ;Suspense Date
SET RMDATE=$PIECE(RM680,U,1)
+11 ;Completion Date
SET RMCODT=$PIECE(RM680,U,5)
+12 ;Initial Action Date
SET RMINDT=$PIECE(RM680,U,9)
+13 ;Consult
SET RMPRCO=$PIECE(RM680,U,15)
+14 ;Date RX Written
SET RMDWRT=$PIECE(RM680,U,16)
+15 ;Station
SET RMSTAT=$PIECE(RM680,U,7)
+16 ;Type of Request
SET RMTRES=$PIECE(RM680,U,8)
+17 SET RMTYRE=$SELECT(RMTRES=1:"ROUTINE",RMTRES=2:"EYEGLASS",RMTRES=3:"CONTACT LENS",RMTRES=4:"OXYGEN",RMTRES=5:"MANUAL",1:"")
+18 ;Requestor (Ordering Provider)
SET RMREQU=$PIECE(RM680,U,11)
+19 SET RMSERV=""
+20 ;I $G(RMREQU) D GETS^DIQ(200,RMREQU,"29","E","RMAA") S RMSERV=RMAA(200,RMREQU_",",29,"E")
+21 ;Provisional Diagnosis
SET RMPRDI=$EXTRACT($PIECE(RM688,U,2),1,16)
+22 ;ICD9
SET RMICD9=$PIECE(RM688,U,3)
+23 ;
+24 ;Suspense Date
SET RMDAT(660,RMIE60_",",8.1)=RMDATE
+25 ;Date RX Written
SET RMDAT(660,RMIE60_",",8.2)=RMDWRT
+26 ;Initial Action Date
SET RMDAT(660,RMIE60_",",8.3)=RMINDT
+27 ;Completion Date
SET RMDAT(660,RMIE60_",",8.4)=RMCODT
+28 ;Type of Request
SET RMDAT(660,RMIE60_",",8.5)=RMTYRE
+29 ;Ordering Provider
SET RMDAT(660,RMIE60_",",8.6)=RMREQU
+30 ;Consult Request Service
SET RMDAT(660,RMIE60_",",8.61)=RMSERV
+31 ;Provisional Diagnosis
SET RMDAT(660,RMIE60_",",8.7)=RMPRDI
+32 ;Suspense ICD9
SET RMDAT(660,RMIE60_",",8.8)=RMICD9
+33 ;Pointer to Request/Consultation
SET RMDAT(660,RMIE60_",",8.9)=RMPRCO
+34 ;Suspense Station
SET RMDAT(660,RMIE60_",",8.11)=RMSTAT
+35 ;Suspense Status
SET RMDAT(660,RMIE60_",",8.14)=RMSUSTAT
+36 ;
+37 ; Patch #78
+38 ; #668,BA nodes
+39 FOR RMPRL=1:1:99
SET RM68BA=$GET(^RMPR(668,RMIE68,"BA"_RMPRL))
if RM68BA=""
QUIT
Begin DoDot:1
+40 NEW RMICD,RMAO,RMIR,RMSC,RMEC,RMMST,RMHNC,RMCBV
+41 SET RMICD=$PIECE(RM68BA,U,1)
+42 SET RMAO=$PIECE(RM68BA,U,2)
+43 SET RMIR=$PIECE(RM68BA,U,3)
+44 SET RMSC=$PIECE(RM68BA,U,4)
+45 SET RMEC=$PIECE(RM68BA,U,5)
+46 SET RMMST=$PIECE(RM68BA,U,6)
+47 SET RMHNC=$PIECE(RM68BA,U,7)
+48 SET RMCBV=$PIECE(RM68BA,U,8)
+49 NEW RMPTR
+50 SET RMPTR=29+RMPRL
+51 SET RMDAT(660,RMIE60_",",RMPTR)=RMICD
+52 SET RMDAT(660,RMIE60_",",RMPTR_".1")=RMAO
+53 SET RMDAT(660,RMIE60_",",RMPTR_".2")=RMIR
+54 SET RMDAT(660,RMIE60_",",RMPTR_".3")=RMSC
+55 SET RMDAT(660,RMIE60_",",RMPTR_".4")=RMEC
+56 SET RMDAT(660,RMIE60_",",RMPTR_".5")=RMMST
+57 SET RMDAT(660,RMIE60_",",RMPTR_".6")=RMHNC
+58 SET RMDAT(660,RMIE60_",",RMPTR_".7")=RMCBV
End DoDot:1
+59 ;
+60 DO UPDATE^DIE("","RMDAT",,"RMERROR")
+61 IF $DATA(RMERROR)
SET RMERR=1
DO ERR0
+62 ;
+63 LOCK -^RMPR(660,RMIE60)
UP60X ; exit point
+1 QUIT RMERR
+2 ;
+3 ;RMIE60 = IEN of file #660.
+4 ;RMIE68 = IEN of file #668.
UP68(RMIE60,RMIE68,RMAMIS) ; update file #668.
+1 DO NEWVAR
+2 SET (RMI,RMERR)=0
+3 ;S RMAMIS=$G(^RMPR(660,RMIE60,"AMS"))
+4 IF '$GET(RMAMIS)
DO ERR8
SET RMERR=1
GOTO UP68X
+5 ;L +^RMPR(668,RMIE68):2
+6 ;I $T=0 W !,"Someone else is Editing this entry!!!",! H 3 S RMERR=1 G UP68X
+7 IF $DATA(^RMPR(668,RMIE68,10,"B",RMIE60))
GOTO UP68X
+8 SET DA(1)=RMIE68
KILL DD,DO
+9 SET DIC="^RMPR(668,"_DA(1)_","_"10,"
SET DIC(0)="L"
SET DLAYGO=668
SET X=RMIE60
+10 DO FILE^DICN
KILL DIC,X,DLAYGO,DD,DO
+11 IF Y=-1
SET RMERR=1
DO ERR8
GOTO UNL68
+12 IF $DATA(^RMPR(668,RMIE68,11,"B",RMAMIS))
GOTO UP68X
+13 SET DA(1)=RMIE68
+14 SET DIC="^RMPR(668,"_DA(1)_","_"11,"
SET DIC(0)="L"
SET DLAYGO=668
SET X=RMAMIS
+15 DO FILE^DICN
KILL DIC
+16 IF Y=-1
SET RMERR=1
DO ERR8
GOTO UNL68
+17 ;
UNL68 ;L -^RMPR(668,RMIE68)
UP68X ; exit point
+1 QUIT RMERR
+2 ;
ERR0 ;error updating file #660
+1 WRITE !,"*** Error updating file #660 in PCE module!!!",!
+2 QUIT
ERR8 ;error updating file #668
+1 WRITE !,"*** Error updating file #668 in PCE module!!!",!
+2 QUIT
LINK ;link 2319 to suspense
+1 NEW IEN660,XIEN,CTR,R10
+2 DO DIV4^RMPRSIT
if $DATA(X)
QUIT
+3 KILL ^TMP($JOB)
+4 ;Patch RMPR*3.0*163 will first find the patient in the suspense file to insure there are unlinked transactions, message/exit if not
+5 ;if unlinked transactions it will then make call to file 660 to display available items to be linked
+6 DO GETPAT^RMPRUTIL
if $DATA(X)
GOTO EXIT
+7 SET IEN660=+DFN
SET XIEN=0
SET CTR=0
+8 ;Patch RMPR*3.0*171 Insure node ^RMPR(660,IEN660,10) exists, if not, count as unlinked
+9 FOR I=1:1
SET XIEN=$ORDER(^RMPR(660,"C",IEN660,XIEN))
if XIEN=""
QUIT
SET R10=$GET(^RMPR(660,XIEN,10))
if R10=""
SET CTR=1
if CTR
QUIT
IF $PIECE(R10,U,14)'=1
IF $DATA(^RMPR(660,XIEN,"AMS"))
IF RMPR("STA")=$PIECE($GET(^RMPR(660,XIEN,0)),U,10)
SET CTR=1
QUIT
+10 IF CTR'=1
WRITE !,?2,$CHAR(7),">> NO patient unlinked items available to be posted to Suspense, hit return"
READ CTR:15
GOTO EXIT
+11 WRITE !
SET DIC="^RMPR(660,"
SET DIC(0)="EQZ"
SET D="C"
SET X=+DFN
+12 SET DIC("S")="S RMZ=$G(^RMPR(660,+Y,10)) I $P(RMZ,U,14)'=1,$D(^(""AMS"")),RMPR(""STA"")=$P(^(0),U,10)"
+13 SET DIC("W")="D EN^RMPRD1"
+14 WRITE !
+15 DO IX^DIC
if Y'>0
GOTO EXIT
+16 LOCK +^RMPR(660,+Y):1
IF $TEST=0
WRITE !,?5,$CHAR(7),"Someone else is Editing this entry!"
GOTO EXIT
+17 SET RMPRDA=+Y
+18 SET RMPRDFN=$PIECE(^RMPR(660,+Y,0),U,2)
+19 IF $DATA(^RMPR(660,+Y,"AMS"))
NEW RMPRAMIS
SET RMPRAMIS=$PIECE(^RMPR(660,+Y,"AMS"),U,1)
+20 SET ^TMP($JOB,"RMPRPCE",660,+Y)=RMPRAMIS_"^"_RMPRDFN
+21 DO LINK^RMPRS
+22 IF $GET(RMPRDA)=""
SET RMPRDA=$ORDER(^TMP($JOB,"RMPRPCE",660,0))
+23 IF $GET(RMPRDA)=""
LOCK
GOTO EXIT
+24 LOCK -^RMPR(660,RMPRDA)
EXIT ;quit
+1 KILL ^TMP($JOB)
+2 KILL RMPR,RMPRSTE
+3 KILL RMCODT
+4 DO KILL^XUSCLEAN
+5 QUIT
+6 ;
SCRS ;set consult request service.
+1 ;start conversion on 1/1/2002, the date of PCE/Link to suspense patch.
+2 WRITE !!,"Setting Consult Request Service in file #660....."
+3 NEW RI,RJ
FOR RI=3020100:0
SET RI=$ORDER(^RMPR(660,"B",RI))
if RI'>0
QUIT
FOR RJ=0:0
SET RJ=$ORDER(^RMPR(660,"B",RI,RJ))
if RJ'>0
QUIT
IF $DATA(^RMPR(660,RJ,10))
Begin DoDot:1
+4 KILL RMAA
+5 SET RMREQU=$PIECE(^RMPR(660,RJ,10),U,6)
+6 SET RMSERV=""
+7 IF $GET(RMREQU)
DO GETS^DIQ(200,RMREQU,"29","E","RMAA")
SET RMSERV=RMAA(200,RMREQU_",",29,"E")
+8 if RMSERV'=""
SET $PIECE(^RMPR(660,RJ,4),U,3)=RMSERV
End DoDot:1
+9 WRITE !!,"Done setting Consult Request Service!!",!
+10 QUIT
+11 ;
NEWVAR NEW DA,DIE,DIC,I,J,RMDFN,RMI,RMDATE,RM680,RM688,RM6810,RMERROR
+1 NEW RMERR,RMCHK,RMAMIS,DLAYGO,X,DR,RMAA,RMSERV,RMREQU,RMDAT
+2 NEW RMPRL,RM68BA,RMDWRT,RMICD9,RMINDT,RMPRCO,RMPRDI,RMSTAT,RMTRES,RMTYRE
+3 QUIT
