RMPRFC4 ;HINES CIOFO/HNC - Create 668 Record; Feb 6, 2009
;;3.0;PROSTHETICS;**83,193,213**;Feb 09, 1996;Build 12
;
;;Reference to $$ICDDX^ICDEX supported by DBIA #5747
;Helen Corkwell-new flow 3/9/05
;
; Patch 83 v18 - DC consult w/no 668 record error fixed
; Patch 83 v19 - DC consult properly display ****Discontinued**** in 668
; NW no longer errors if there is no ICD9 data
Q
EN ;
;RMPRISIT is station ien to 4
;RMPR123A is consult ien to 123
;RMPRFORM is form type other
;RMPRTYPE is IFC new with patch
;RMPRSTAT is status, open
;RMPROPRO is ordering provider free text
;RMPRMPI is Master Patient Index
;RMPRDFN is DFN
I RMPRST="NW" D
.S RMPRMPI=$P($G(^TMP("RMPRIF",$J,"PID")),"|",2)
.S RMPRDFN=$$GETDFN^MPIF001(RMPRMPI)
I $D(^TMP("RMPRIF",$J,"OBX",1)) D
. D TRIMWP^RMPRFC5($NA(^TMP("RMPRIF",$J,"OBX",1)),5)
;return sample
;^TMP("RMPRIF",570428439,"OBX",1,1) = Test #2
;
;ICD9
I RMPRST="NW" D
.S RMPRPD9=$P($G(^TMP("RMPRIF",$J,"OBX",2,1)),"|",5)
.I RMPRPD9="" S RMPRICD9=""
.I RMPRPD9'="" S RMPRICD9=$P(RMPRPD9,U,1)
.I RMPRICD9="" S RMPRICD=""
.I RMPRICD9'="" S RMPRICD=$$ICDDX^ICDEX(RMPRICD9,DT) ;RMPR213 corrects API
.;date rx written
.S RMPRDRXW=$P($G(^TMP("RMPRIF",$J,"OBR")),"|",6)
.I RMPRDRXW'="" S RMPRDRXW=$$FMDATE^HLFNC(RMPRDRXW)
.;
.S RMPRFORM=9
.S RMPRTYPE=9
.S RMPRSTAT="O"
.S RMPROPRO=$P($G(^TMP("RMPRIF",$J,"OBR")),"|",16)
.I RMPROPRO'="" S RMPROPRO=$P(RMPROPRO,U,1)_","_$P(RMPROPRO,U,2)_" "_$P(RMPROPRO,U,3)
;discontinued data from 1st 668 record
I RMPRST="DC" D
.S RMPR668=0
.S RMPR668=$O(^RMPR(668,"D",RMPR123A,RMPR668))
.I RMPR668="" S ^TMP("RMPRIF",$J,"RMPR668")="NOT DEFINED" Q
.S RMPRICD=$P($G(^RMPR(668,RMPR668,8)),U,3)
.S RMPRDIAG=$P($G(^RMPR(668,RMPR668,8)),U,2)
.S RMPROPRO=$P($G(^RMPR(668,RMPR668,"IFC1")),U,3)
.S RMPRDRXW=$P($G(^RMPR(668,RMPR668,0)),U,16)
.S RMPRDFN=$P($G(^RMPR(668,RMPR668,0)),U,2)
.; STATION NEEDS TO BE SAME AS ORIGINAL IFC, NOT WHAT IS IN ORC SEGMENT
.S RMPRISIT=$P($G(^RMPR(668,RMPR668,0)),U,7)
.S RMPRTYPE=10
.S RMPRSTAT="O"
.S RMPRFORM=9
;create new record
;
I +$G(RMPRDFN)'>0 G EXIT ;No patient
;
I $D(^TMP("RMPRIF",$J,"RMPR668")) G EXIT
D NOW^%DTC S X=%
S DIC="^RMPR(668,",DIC(0)="L"
K DD,DO D FILE^DICN
S RMPRA=+Y
;
S DA=+Y,DIE=DIC
S DR="1////^S X=RMPRDFN;3////^S X=RMPRFORM;8////^S X=.5;2////^S X=RMPRSITIEN;9////^S X=RMPRTYPE;14////^S X=RMPRSTAT"
D ^DIE
;
;check for discontinued or new
;
I RMPRST="NW" D
.S DR="27////^S X=RMPROPRO;20////^S X=RMPR123A;1.6////^S X=+RMPRICD;1.5////^S X=$P(RMPRPD9,U,2);22////^S X=RMPRDRXW"
.D ^DIE
;
I RMPRST="DC" D
.S DR="27////^S X=RMPROPRO;20////^S X=RMPR123A;1.6////^S X=+RMPRICD;1.5////^S X=RMPRDIAG;22////^S X=RMPRDRXW"
.D ^DIE
;
;for a new order
;Description of Item/Services
I RMPRST="NW" D
.S ^RMPR(668,RMPRA,2,0)="^^^"_DT_"^"
.S RMPRL=0,RMPRLN=0
.F S RMPRL=$O(^TMP("RMPRIF",$J,"OBX",1,RMPRL)) Q:RMPRL="" D
.. S RMPRLN=RMPRLN+1,^RMPR(668,RMPRA,2,RMPRLN,0)=^TMP("RMPRIF",$J,"OBX",1,RMPRL)
.S $P(^RMPR(668,RMPRA,2,0),"^",3)=RMPRLN
;
I RMPRST="DC" D
.S ^RMPR(668,RMPRA,2,0)="^^^"_DT_"^"
.S ^RMPR(668,RMPRA,2,1,0)="****DISCONTINUED****"
.S $P(^RMPR(668,RMPRA,2,0),"^",3)=1
;
EXIT ;
;Clean up here
K ^TMP("RMPRIF",$J)
K RMPRST,RMPRA,RMPRLN,RMPRL
K RMPR123,RMPR123A,RMPR123I,RMPRISIT
K RMPRFORM,RMPRTYPE,RMPRSTAT,RMPROPRO,RMPRDFN,RMPRMPI,RMPRPD9,RMPRICD9
K RMPRDRXW,RMPRDIAG,RMPR668,RMPRICD
K RMPRDCIN,RMPRDPDC
K RMPRSITIEN,RMPRSTA
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRFC4 3557 printed Oct 16, 2024@18:35:18 Page 2
RMPRFC4 ;HINES CIOFO/HNC - Create 668 Record; Feb 6, 2009
+1 ;;3.0;PROSTHETICS;**83,193,213**;Feb 09, 1996;Build 12
+2 ;
+3 ;;Reference to $$ICDDX^ICDEX supported by DBIA #5747
+4 ;Helen Corkwell-new flow 3/9/05
+5 ;
+6 ; Patch 83 v18 - DC consult w/no 668 record error fixed
+7 ; Patch 83 v19 - DC consult properly display ****Discontinued**** in 668
+8 ; NW no longer errors if there is no ICD9 data
+9 QUIT
EN ;
+1 ;RMPRISIT is station ien to 4
+2 ;RMPR123A is consult ien to 123
+3 ;RMPRFORM is form type other
+4 ;RMPRTYPE is IFC new with patch
+5 ;RMPRSTAT is status, open
+6 ;RMPROPRO is ordering provider free text
+7 ;RMPRMPI is Master Patient Index
+8 ;RMPRDFN is DFN
+9 IF RMPRST="NW"
Begin DoDot:1
+10 SET RMPRMPI=$PIECE($GET(^TMP("RMPRIF",$JOB,"PID")),"|",2)
+11 SET RMPRDFN=$$GETDFN^MPIF001(RMPRMPI)
End DoDot:1
+12 IF $DATA(^TMP("RMPRIF",$JOB,"OBX",1))
Begin DoDot:1
+13 DO TRIMWP^RMPRFC5($NAME(^TMP("RMPRIF",$JOB,"OBX",1)),5)
End DoDot:1
+14 ;return sample
+15 ;^TMP("RMPRIF",570428439,"OBX",1,1) = Test #2
+16 ;
+17 ;ICD9
+18 IF RMPRST="NW"
Begin DoDot:1
+19 SET RMPRPD9=$PIECE($GET(^TMP("RMPRIF",$JOB,"OBX",2,1)),"|",5)
+20 IF RMPRPD9=""
SET RMPRICD9=""
+21 IF RMPRPD9'=""
SET RMPRICD9=$PIECE(RMPRPD9,U,1)
+22 IF RMPRICD9=""
SET RMPRICD=""
+23 ;RMPR213 corrects API
IF RMPRICD9'=""
SET RMPRICD=$$ICDDX^ICDEX(RMPRICD9,DT)
+24 ;date rx written
+25 SET RMPRDRXW=$PIECE($GET(^TMP("RMPRIF",$JOB,"OBR")),"|",6)
+26 IF RMPRDRXW'=""
SET RMPRDRXW=$$FMDATE^HLFNC(RMPRDRXW)
+27 ;
+28 SET RMPRFORM=9
+29 SET RMPRTYPE=9
+30 SET RMPRSTAT="O"
+31 SET RMPROPRO=$PIECE($GET(^TMP("RMPRIF",$JOB,"OBR")),"|",16)
+32 IF RMPROPRO'=""
SET RMPROPRO=$PIECE(RMPROPRO,U,1)_","_$PIECE(RMPROPRO,U,2)_" "_$PIECE(RMPROPRO,U,3)
End DoDot:1
+33 ;discontinued data from 1st 668 record
+34 IF RMPRST="DC"
Begin DoDot:1
+35 SET RMPR668=0
+36 SET RMPR668=$ORDER(^RMPR(668,"D",RMPR123A,RMPR668))
+37 IF RMPR668=""
SET ^TMP("RMPRIF",$JOB,"RMPR668")="NOT DEFINED"
QUIT
+38 SET RMPRICD=$PIECE($GET(^RMPR(668,RMPR668,8)),U,3)
+39 SET RMPRDIAG=$PIECE($GET(^RMPR(668,RMPR668,8)),U,2)
+40 SET RMPROPRO=$PIECE($GET(^RMPR(668,RMPR668,"IFC1")),U,3)
+41 SET RMPRDRXW=$PIECE($GET(^RMPR(668,RMPR668,0)),U,16)
+42 SET RMPRDFN=$PIECE($GET(^RMPR(668,RMPR668,0)),U,2)
+43 ; STATION NEEDS TO BE SAME AS ORIGINAL IFC, NOT WHAT IS IN ORC SEGMENT
+44 SET RMPRISIT=$PIECE($GET(^RMPR(668,RMPR668,0)),U,7)
+45 SET RMPRTYPE=10
+46 SET RMPRSTAT="O"
+47 SET RMPRFORM=9
End DoDot:1
+48 ;create new record
+49 ;
+50 ;No patient
IF +$GET(RMPRDFN)'>0
GOTO EXIT
+51 ;
+52 IF $DATA(^TMP("RMPRIF",$JOB,"RMPR668"))
GOTO EXIT
+53 DO NOW^%DTC
SET X=%
+54 SET DIC="^RMPR(668,"
SET DIC(0)="L"
+55 KILL DD,DO
DO FILE^DICN
+56 SET RMPRA=+Y
+57 ;
+58 SET DA=+Y
SET DIE=DIC
+59 SET DR="1////^S X=RMPRDFN;3////^S X=RMPRFORM;8////^S X=.5;2////^S X=RMPRSITIEN;9////^S X=RMPRTYPE;14////^S X=RMPRSTAT"
+60 DO ^DIE
+61 ;
+62 ;check for discontinued or new
+63 ;
+64 IF RMPRST="NW"
Begin DoDot:1
+65 SET DR="27////^S X=RMPROPRO;20////^S X=RMPR123A;1.6////^S X=+RMPRICD;1.5////^S X=$P(RMPRPD9,U,2);22////^S X=RMPRDRXW"
+66 DO ^DIE
End DoDot:1
+67 ;
+68 IF RMPRST="DC"
Begin DoDot:1
+69 SET DR="27////^S X=RMPROPRO;20////^S X=RMPR123A;1.6////^S X=+RMPRICD;1.5////^S X=RMPRDIAG;22////^S X=RMPRDRXW"
+70 DO ^DIE
End DoDot:1
+71 ;
+72 ;for a new order
+73 ;Description of Item/Services
+74 IF RMPRST="NW"
Begin DoDot:1
+75 SET ^RMPR(668,RMPRA,2,0)="^^^"_DT_"^"
+76 SET RMPRL=0
SET RMPRLN=0
+77 FOR
SET RMPRL=$ORDER(^TMP("RMPRIF",$JOB,"OBX",1,RMPRL))
if RMPRL=""
QUIT
Begin DoDot:2
+78 SET RMPRLN=RMPRLN+1
SET ^RMPR(668,RMPRA,2,RMPRLN,0)=^TMP("RMPRIF",$JOB,"OBX",1,RMPRL)
End DoDot:2
+79 SET $PIECE(^RMPR(668,RMPRA,2,0),"^",3)=RMPRLN
End DoDot:1
+80 ;
+81 IF RMPRST="DC"
Begin DoDot:1
+82 SET ^RMPR(668,RMPRA,2,0)="^^^"_DT_"^"
+83 SET ^RMPR(668,RMPRA,2,1,0)="****DISCONTINUED****"
+84 SET $PIECE(^RMPR(668,RMPRA,2,0),"^",3)=1
End DoDot:1
+85 ;
EXIT ;
+1 ;Clean up here
+2 KILL ^TMP("RMPRIF",$JOB)
+3 KILL RMPRST,RMPRA,RMPRLN,RMPRL
+4 KILL RMPR123,RMPR123A,RMPR123I,RMPRISIT
+5 KILL RMPRFORM,RMPRTYPE,RMPRSTAT,RMPROPRO,RMPRDFN,RMPRMPI,RMPRPD9,RMPRICD9
+6 KILL RMPRDRXW,RMPRDIAG,RMPR668,RMPRICD
+7 KILL RMPRDCIN,RMPRDPDC
+8 KILL RMPRSITIEN,RMPRSTA
+9 QUIT
