- 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 Feb 19, 2025@00:01:08 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