Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: RMPRFC4

RMPRFC4.m

Go to the documentation of this file.
  1. RMPRFC4 ;HINES CIOFO/HNC - Create 668 Record; Feb 6, 2009
  1. ;;3.0;PROSTHETICS;**83,193,213**;Feb 09, 1996;Build 12
  1. ;
  1. ;;Reference to $$ICDDX^ICDEX supported by DBIA #5747
  1. ;Helen Corkwell-new flow 3/9/05
  1. ;
  1. ; Patch 83 v18 - DC consult w/no 668 record error fixed
  1. ; Patch 83 v19 - DC consult properly display ****Discontinued**** in 668
  1. ; NW no longer errors if there is no ICD9 data
  1. Q
  1. EN ;
  1. ;RMPRISIT is station ien to 4
  1. ;RMPR123A is consult ien to 123
  1. ;RMPRFORM is form type other
  1. ;RMPRTYPE is IFC new with patch
  1. ;RMPRSTAT is status, open
  1. ;RMPROPRO is ordering provider free text
  1. ;RMPRMPI is Master Patient Index
  1. ;RMPRDFN is DFN
  1. I RMPRST="NW" D
  1. .S RMPRMPI=$P($G(^TMP("RMPRIF",$J,"PID")),"|",2)
  1. .S RMPRDFN=$$GETDFN^MPIF001(RMPRMPI)
  1. I $D(^TMP("RMPRIF",$J,"OBX",1)) D
  1. . D TRIMWP^RMPRFC5($NA(^TMP("RMPRIF",$J,"OBX",1)),5)
  1. ;return sample
  1. ;^TMP("RMPRIF",570428439,"OBX",1,1) = Test #2
  1. ;
  1. ;ICD9
  1. I RMPRST="NW" D
  1. .S RMPRPD9=$P($G(^TMP("RMPRIF",$J,"OBX",2,1)),"|",5)
  1. .I RMPRPD9="" S RMPRICD9=""
  1. .I RMPRPD9'="" S RMPRICD9=$P(RMPRPD9,U,1)
  1. .I RMPRICD9="" S RMPRICD=""
  1. .I RMPRICD9'="" S RMPRICD=$$ICDDX^ICDEX(RMPRICD9,DT) ;RMPR213 corrects API
  1. .;date rx written
  1. .S RMPRDRXW=$P($G(^TMP("RMPRIF",$J,"OBR")),"|",6)
  1. .I RMPRDRXW'="" S RMPRDRXW=$$FMDATE^HLFNC(RMPRDRXW)
  1. .;
  1. .S RMPRFORM=9
  1. .S RMPRTYPE=9
  1. .S RMPRSTAT="O"
  1. .S RMPROPRO=$P($G(^TMP("RMPRIF",$J,"OBR")),"|",16)
  1. .I RMPROPRO'="" S RMPROPRO=$P(RMPROPRO,U,1)_","_$P(RMPROPRO,U,2)_" "_$P(RMPROPRO,U,3)
  1. ;discontinued data from 1st 668 record
  1. I RMPRST="DC" D
  1. .S RMPR668=0
  1. .S RMPR668=$O(^RMPR(668,"D",RMPR123A,RMPR668))
  1. .I RMPR668="" S ^TMP("RMPRIF",$J,"RMPR668")="NOT DEFINED" Q
  1. .S RMPRICD=$P($G(^RMPR(668,RMPR668,8)),U,3)
  1. .S RMPRDIAG=$P($G(^RMPR(668,RMPR668,8)),U,2)
  1. .S RMPROPRO=$P($G(^RMPR(668,RMPR668,"IFC1")),U,3)
  1. .S RMPRDRXW=$P($G(^RMPR(668,RMPR668,0)),U,16)
  1. .S RMPRDFN=$P($G(^RMPR(668,RMPR668,0)),U,2)
  1. .; STATION NEEDS TO BE SAME AS ORIGINAL IFC, NOT WHAT IS IN ORC SEGMENT
  1. .S RMPRISIT=$P($G(^RMPR(668,RMPR668,0)),U,7)
  1. .S RMPRTYPE=10
  1. .S RMPRSTAT="O"
  1. .S RMPRFORM=9
  1. ;create new record
  1. ;
  1. I +$G(RMPRDFN)'>0 G EXIT ;No patient
  1. ;
  1. I $D(^TMP("RMPRIF",$J,"RMPR668")) G EXIT
  1. D NOW^%DTC S X=%
  1. S DIC="^RMPR(668,",DIC(0)="L"
  1. K DD,DO D FILE^DICN
  1. S RMPRA=+Y
  1. ;
  1. S DA=+Y,DIE=DIC
  1. 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"
  1. D ^DIE
  1. ;
  1. ;check for discontinued or new
  1. ;
  1. I RMPRST="NW" D
  1. .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"
  1. .D ^DIE
  1. ;
  1. I RMPRST="DC" D
  1. .S DR="27////^S X=RMPROPRO;20////^S X=RMPR123A;1.6////^S X=+RMPRICD;1.5////^S X=RMPRDIAG;22////^S X=RMPRDRXW"
  1. .D ^DIE
  1. ;
  1. ;for a new order
  1. ;Description of Item/Services
  1. I RMPRST="NW" D
  1. .S ^RMPR(668,RMPRA,2,0)="^^^"_DT_"^"
  1. .S RMPRL=0,RMPRLN=0
  1. .F S RMPRL=$O(^TMP("RMPRIF",$J,"OBX",1,RMPRL)) Q:RMPRL="" D
  1. .. S RMPRLN=RMPRLN+1,^RMPR(668,RMPRA,2,RMPRLN,0)=^TMP("RMPRIF",$J,"OBX",1,RMPRL)
  1. .S $P(^RMPR(668,RMPRA,2,0),"^",3)=RMPRLN
  1. ;
  1. I RMPRST="DC" D
  1. .S ^RMPR(668,RMPRA,2,0)="^^^"_DT_"^"
  1. .S ^RMPR(668,RMPRA,2,1,0)="****DISCONTINUED****"
  1. .S $P(^RMPR(668,RMPRA,2,0),"^",3)=1
  1. ;
  1. EXIT ;
  1. ;Clean up here
  1. K ^TMP("RMPRIF",$J)
  1. K RMPRST,RMPRA,RMPRLN,RMPRL
  1. K RMPR123,RMPR123A,RMPR123I,RMPRISIT
  1. K RMPRFORM,RMPRTYPE,RMPRSTAT,RMPROPRO,RMPRDFN,RMPRMPI,RMPRPD9,RMPRICD9
  1. K RMPRDRXW,RMPRDIAG,RMPR668,RMPRICD
  1. K RMPRDCIN,RMPRDPDC
  1. K RMPRSITIEN,RMPRSTA
  1. Q