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

RAREG2.m

Go to the documentation of this file. 
  1. RAREG2 ;HISC/CAH,FPT,DAD,SS AISC/MJK,RMO-Register Patient ; 06 Oct 2013  11:04 AM
  1.  ;;5.0;Radiology/Nuclear Medicine;**13,18,93,99,1003,1005**;Nov 01, 2010;Build 13
  1.  ;last modif. JULY 5,00 by SS 
  1.  ; 07/15/2008 BAY/KAM rem call 249750 RA*5*93 Correct DIK Calls
  1.  ; 06/04/09 rvd - display pregnancy screen and pregnancy screen comment only in Add Exams to Last visit option.
  1.  ; Supported IA #2053 reference to ^DIE
  1.  ; Supported IA #10013 reference to ^DIK
  1. ORDER ; Get data from ordered procedure for registration
  1.  K RACLNC,RALIFN,RALOC,RAPIFN,RAPRC,RARDTE,RARSH,RASHA
  1.  S Y=^RAO(75.1,+RAOIFN,0),RAPRC=$S($D(^RAMIS(71,+$P(Y,"^",2),0)):$P(^(0),"^"),1:"") S:$D(RADPARFL) RAPRC=RADPARPR ;may not need to redefine raprc ?
  1.  S RACAT=$S('$D(RAWARD):$P($P(^DD(75.1,4,0),$P(Y,"^",4)_":",2),";"),1:RACAT)
  1.  D SL^RAREG3 Q:RAQUIT
  1.  S:"CS"[$E(RACAT)&($D(^DIC(34,+$P(Y,"^",9),0))) RASHA=$P(^(0),"^") S:"R"[$E(RACAT)&($D(^RAO(75.1,+RAOIFN,"R"))) RARSH=^("R")
  1.  S:$D(^VA(200,+$P(Y,"^",14),0)) RAPIFN=+$P(Y,"^",14) S:$P(Y,"^",21) RARDTE=$P(Y,"^",21) S:$D(^SC(+$P(Y,"^",22),0)) RALIFN=+$P(Y,"^",22)
  1.  I '$D(RAWARD),$D(RALIFN),$P(^SC(RALIFN,0),"^",3)="C" S RALOC=$P(^(0),"^") S RACLNC=$S('$D(^("SL")):RALOC,$D(^SC(+$P(^("SL"),"^",5),0)):$P(^(0),"^"),1:RALOC)
  1.  ;check nodes ahead 6/18/96
  1.  N RAAHEAD
  1.  S RAAHEAD=$O(^RADPT(RADFN,"DT","B",RADTE))
  1.  I RAAHEAD[RADTE W $C(7),!!?5,"Someone else has already started editing a record for this",!?5,"patient at this time, please try a few minutes later." S RAQUIT=1 R !!,"Press RETURN to continue :",RAAHEAD:DTIME
  1.  Q
  1. EXAMLOOP ; register the exam
  1.  N REM ;this is used by the edit template
  1.  ;P99; keep previous pregnancy screen data before adding new exam
  1.  ;
  1.  ;IHS/BJI/DAY - Patch 1005 - Gender Fix
  1.  ;I $D(RAOPT("ADDEXAM")),$$PTSEX^RAUTL8(RADFN)="F" S RA703DAT=$$PRCEXA^RAUTL8(RADFN)  ;ra703dat holds the previous entry
  1.  I $D(RAOPT("ADDEXAM")),$$PTSEX^RAUTL8(RADFN)'="M" S RA703DAT=$$PRCEXA^RAUTL8(RADFN)  ;ra703dat holds the previous entry
  1.  ;
  1.  S DA=RADFN,RACN="N",DIE("NO^")="OUTOK",DR="[RA REGISTER]",DIE="^RADPT(" D ^DIE K DIE("NO^"),DE,DQ
  1.  ;
  1.  ;IHS/BJI/DAY - Patch 1005 - Default Pregnancy Status to Unknown
  1.  ;Controlled by site parameter
  1.  I +$G(RAMDIV),$P($G(^RA(79,+RAMDIV,9999999)),"^",2)=1 D
  1.  .I $G(RADFN)="" Q
  1.  .I $G(RADTI)="" Q
  1.  .I $G(RACNI)="" Q
  1.  .I $$PTSEX^RAUTL8(RADFN)="M" Q
  1.  .I $$PTAGE^RAUTL8(RADFN,"")>55 Q
  1.  .I $$PTAGE^RAUTL8(RADFN,"")<12 Q
  1.  .I '$D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) Q
  1.  .I $P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),U,32)]"" Q
  1.  .S $P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),U,32)="u"
  1.  ;End Patch
  1.  ;
  1.  K RAPOP,RAFM,RAFM1,RAI,RAMOD,RASTI,RACMTHOD,RANMFLG,RAIEN702 ;moved from edit template
  1.  S RACNICNT=RACNICNT+1
  1.  S ^TMP($J,"RAREG1",RACNICNT)=RADFN_U_RADTI_U_RACNI_U_RAOIFN
  1.  I '$D(RAFIN) D  Q
  1.  . W !?3,$C(7),"Exam entry not complete. Must delete..."
  1.  . S DA(2)=RADFN,DA(1)=RADTI,DA=RACNI
  1.  . ; Modified the next line for rem call 249750
  1.  . S DIK="^RADPT("_DA(2)_",""DT"","_DA(1)_",""P""," D ^DIK
  1.  . K ^TMP($J,"RAREG1",RACNICNT)
  1.  . K RAPX  ; added in RA*5*13 to stop labels & flash cards in RAREG1
  1.  . Q
  1.  ;start of p99, display and SET pregnancy screen and pregnancy screen comment
  1.  ;value defaulted from previous case exam (regardless of case exam status)
  1.  ;
  1.  ;IHS/BJI/DAY - Patch 1005 - Gender Fix
  1.  ;I $D(RAOPT("ADDEXAM")),$$PTSEX^RAUTL8(RADFN)="F" D
  1.  I $D(RAOPT("ADDEXAM")),$$PTSEX^RAUTL8(RADFN)'="M" D
  1.  .;
  1.  .Q:'$D(RA703DAT)
  1.  .N RA3,RADTIEN,RACNIEN,RAPCOMM
  1.  .S RADTIEN=$P(RA703DAT,U),RACNIEN=$P(RA703DAT,U,2)
  1.  .S RA3=$G(^RADPT(RADFN,"DT",RADTIEN,"P",RACNIEN,0))
  1.  .S RAPCOMM=$G(^RADPT(RADFN,"DT",RADTIEN,"P",RACNIEN,"PCOMM"))
  1.  .W:$P(RA3,U,32)'="" !,"    PREGNANCY SCREEN: ",$S($P(RA3,U,32)="y":"Patient answered yes",$P(RA3,U,32)="n":"Patient answered no",$P(RA3,U,32)="u":"Patient is unable to answer or is unsure",1:"")
  1.  .W:$P(RA3,U,32)'="n"&$L(RAPCOMM) !,"    PREGNANCY SCREEN COMMENT: ",RAPCOMM
  1.  .N RAPTAGE S RAPTAGE=$$PTAGE^RAUTL8(RADFN,"")
  1.  .Q:RAPTAGE<12!(RAPTAGE>55)
  1.  .I $P(RA3,U,32)'="" D
  1.  ..N RAFDA
  1.  ..S RAFDA(70.03,RACNI_","_RADTI_","_RADFN_",",32)=$P(RA3,U,32)
  1.  ..D FILE^DIE("","RAFDA")
  1.  .I $D(^RADPT(RADFN,"DT",RADTIEN,"P",RACNIEN,"PCOMM")) D
  1.  ..N RAFDA
  1.  ..S RAFDA(70.03,RACNI_","_RADTI_","_RADFN_",",80)=^RADPT(RADFN,"DT",RADTIEN,"P",RACNIEN,"PCOMM")
  1.  ..D FILE^DIE("","RAFDA")
  1.  ;end of p99
  1.  S RAPARENT=$S($G(RAPARENT):RAPARENT,$P($G(^RAMIS(71,RAPROC,0)),U,6)="P":1,1:+$G(RAPARENT))
  1.  I $D(^RAO(75.1,+RAOIFN,"H")) S:$D(^("H",0)) ^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",0)=^(0) F I=1:1 Q:'$D(^RAO(75.1,+RAOIFN,"H",I,0))  S ^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",I,0)=^(0)
  1.  ;IHS/BJI/DAY - Patch 1003 - Continue Chris Saddler 2005 Patch
  1.  ;Add set of Exam Date for PCC
  1.  S ^RADPT(RADFN,"DT",RADTI,"P",RACNI,"PCC")=$P(RADTE,".")
  1.  ;End Patch
  1.  S ^DISV($S($D(DUZ)#2:DUZ,1:0),"RA","CASE #")=RADFN_"^"_RADTI_"^"_RACNI,RAREC=""
  1.  S:$D(RADPARFL) ^TMP($J,"PRO-REG",RAPROCI,RAOIFN)=""
  1.  K RAFIN,DR,RA703DAT
  1.  K RACLNC,RALIFN,RALOC,RAOSTS,RAPHY,RAPRC,RARDTE,RARSH,RASHA
  1.  Q
  1. EXAMDEL ; Delete examset if incomplete
  1.  W !!?3,$C(7),"Exam entry not complete. Must delete all descendent exams..."
  1.  S RATMP=0
  1.  F  S RATMP=$O(^TMP($J,"RAREG1",RATMP)) Q:RATMP'>0  D
  1.  . S RA=^TMP($J,"RAREG1",RATMP)
  1.  . S RAOIFN=$P(RA,U,4),(RADFN,DA(2))=$P(RA,U)
  1.  . S (RADTI,DA(1))=$P(RA,U,2),(RACNI,DA)=$P(RA,U,3)
  1.  . ; Modified the next line for rem call 249750
  1.  . S DIK="^RADPT("_DA(2)_",""DT"","_DA(1)_",""P""," D ^DIK
  1.  . K ^TMP($J,"RAREG1",RATMP),RAPX(RATMP)
  1.  . K DIE,DR S DIE="^RAO(75.1,",DA=RAOIFN,DR="5///5" D ^DIE K DIE,DR
  1.  . Q
  1.  W !?3,"Deletion complete!",!
  1.  Q
  1. XTRADESC ; Ask extra descendent procedures for a parent
  1.  N RASKIPIT S RASKIPIT=0
  1.  F  D  Q:RASKIPIT!RAEXIT!RAQUIT
  1.  . N DIR S DIR(0)="Y"
  1.  . S DIR("A")="Register another descendent exam for "_RANME_" (Y/N)"
  1.  . W ! D ^DIR
  1.  . S RAEXIT=$S($D(DTOUT)!$D(DUOUT):1,1:0),RASKIPIT='Y
  1.  . I RASKIPIT!RAEXIT Q
  1.  . D ORDER K RAPRC Q:RAQUIT
  1.  . D EXAMLOOP,MEMSET(RADFN,RADTI,RACNI)
  1.  . Q
  1.  Q
  1. EXAMSET ; Set the EXAM SET field if a parent is registered
  1.  N DA,DIE,DR,Y
  1.  S DIE="^RADPT("_RADFN_",""DT"","
  1.  S DA(1)=RADFN,DA=RADTI
  1.  S DR="5///^S X=$S($G(RAPARENT):''RAPARENT,1:""@"")"
  1.  D ^DIE
  1.  Q
  1. MEMSET(RAX,RAY,RAZ) ; Set 'MEMBER OF SET' field on the exam node
  1.  ; if the procedure is a descendant procedure.
  1.  ; Var List:   RAX <-> RADFN : RAY <-> RADTI : RAZ <-> RACNI
  1.  Q:$G(^RADPT(RAX,"DT",RAY,"P",RAZ,0))']""
  1.  N D,D0,DA,DI,DIC,DIE,DQ,DR,X,Y
  1.  S DIE="^RADPT("_RAX_",""DT"","_RAY_",""P"","
  1.  S DA(2)=RAX,DA(1)=RAY,DA=RAZ,DR="25///"_$S($P($G(^RAMIS(71,+RAPROC,0)),"^",18)="Y":2,1:1) D ^DIE ;2=combined report, 1=separate reports
  1.  Q
  1. SET17(RAX,RAY,RAZ) ; Set piece 17 on exam node
  1.  Q:$G(^RADPT(RAX,"DT",RAY,"P",RAZ,0))']""
  1.  N D,D0,DA,DI,DIC,DIE,DQ,DR,X,Y
  1.  S DIE="^RADPT("_RAX_",""DT"","_RAY_",""P"","
  1.  S DA(2)=RAX,DA(1)=RAY,DA=RAZ,DR="17///"_RA17 D ^DIE
  1.  Q
  1. UOSM ; called from RAREG1
  1.  ; update order status and send OE v3.0 message
  1.  ; This code will $O through the ^TMP($J,"RAREG1" global and make
  1.  ; just one call per order/request number to ^RAORDU to update the
  1.  ; status in File 75.1. One call to ^RAORDU per order/request number
  1.  ; means only one HL7 type message per order/request will be sent to 
  1.  ; OE v3.0.
  1.  ;
  1.  Q:'$D(^TMP($J,"RAREG1"))
  1.  N RACNT,RAORDNUM,RATMPNDE
  1.  S RACNT=0
  1.  F  S RACNT=$O(^TMP($J,"RAREG1",RACNT)) Q:RACNT'>0  D
  1.  .S RATMPNDE=$G(^TMP($J,"RAREG1",RACNT))
  1.  .S RAOIFN=$P(RATMPNDE,U,4) I RAOIFN D
  1.  ..Q:$D(RAORDNUM(RAOIFN))
  1.  ..S RAPROC=$P(^RAO(75.1,+RAOIFN,0),U,2)
  1.  ..N RA18PCHG S RA18PCHG=$$EN1^RAO7XX(RAOIFN) ;P18 - if the proc changed, sends XX mess, sets RA18PCHG=1 for RAORDU
  1.  ..S RAOSTS=6 D ^RAORDU
  1.  ..S RAORDNUM(RAOIFN)=""
  1.  ..Q
  1.  .Q
  1.  Q
  1. CKDUPORD ; ck for dupl procedures in outstanding orders
  1.  S RA6="",RA8=0
  1. CKD1 S RA6=$O(^TMP($J,"PRO-REG",RA6)) Q:'RA6
  1.  S RA7=$O(^TMP($J,"PRO-REG",RA6,0)) G:'RA7 CKD1
  1.  K ^TMP($J,"PRO-ORD",RA6,RA7) ; kill hook for order of regist'd proc
  1.  G:'$O(^TMP($J,"PRO-ORD",RA6,0)) CKD1
  1.  W:'RA8 !!?5,"Of the procedures you just registered,",!?5,"the following procedure(s) are still in outstanding order(s) :",$C(7),!
  1.  S RA8=1
  1.  S RA7=""
  1.  F  S RA7=$O(^TMP($J,"PRO-ORD",RA6,RA7)) Q:'RA7  W !?5,$P(^RAMIS(71,RA6,0),U) W:^TMP($J,"PRO-ORD",RA6,RA7)="DESC" ?35,"(parent=",$P(^RAMIS(71,$P($G(^RAO(75.1,RA7,0)),U,2),0),U),")"
  1.  G CKD1
  1. COPYFROM(RAZ) ;called by RAREG1 if add exam shd copy dx/staff/resident
  1.  ;RAZ is "P"-node's ien of newly added case of set
  1.  Q:'$D(RAFIRST)#2  ;RAFIRST is "P"-node's ien of first case of set
  1.  Q:$G(^RADPT(RADFN,"DT",RADTI,"P",RAZ,0))']""
  1.  Q:$G(^RADPT(RADFN,"DT",RADTI,"P",RAFIRST,0))']""
  1.  N RA,RA2,RA3,RA5 S RA5=0
  1.  ; RA is a dummy var
  1.  ; RA2 is used by data server call in RARTE2
  1.  ; RA3 is used by COPYn^RARTE2 as a dummy var
  1.  ; RA5=1 if any data got copied over to the new case
  1.  N RA1PR,RA1PS ; prim res/staff
  1.  N RA1SR,RA1SS ; sec res/staff arrays
  1.  N RA1PD,RA1SD ; prim diag, then sec diags arrays
  1.  N RAFDA,RAIEN,RAMSG,RAXIT
  1.  S RAXIT=0
  1.  S RA2=RAZ_","_RADTI_","_RADFN
  1.  ; get data from first case of set
  1.  S RA1PR=$P(^RADPT(RADFN,"DT",RADTI,"P",RAFIRST,0),U,12),RA1PS=$P(^(0),U,15),RA1PD=$P(^(0),U,13)
  1.  I $D(^RADPT(RADFN,"DT",RADTI,"P",RAFIRST,"SRR",0)) S RA=0 F  S RA=$O(^RADPT(RADFN,"DT",RADTI,"P",RAFIRST,"SRR",RA)) Q:+RA'=RA  S RA1SR(RA)=+(^(RA,0))
  1.  I $D(^RADPT(RADFN,"DT",RADTI,"P",RAFIRST,"SSR",0)) S RA=0 F  S RA=$O(^RADPT(RADFN,"DT",RADTI,"P",RAFIRST,"SSR",RA)) Q:+RA'=RA  S RA1SS(RA)=+(^(RA,0))
  1.  I $D(^RADPT(RADFN,"DT",RADTI,"P",RAFIRST,"DX",0)) S RA=0 F  S RA=$O(^RADPT(RADFN,"DT",RADTI,"P",RAFIRST,"DX",RA)) Q:+RA'=RA  S RA1SD(RA)=+(^(RA,0))
  1.  ; copy data from first case of set to new case
  1.  S:RA1PR $P(^RADPT(RADFN,"DT",RADTI,"P",RAZ,0),U,12)=RA1PR,RA5=1
  1.  S:RA1PS $P(^RADPT(RADFN,"DT",RADTI,"P",RAZ,0),U,15)=RA1PS,RA5=1
  1.  S:RA1PD $P(^RADPT(RADFN,"DT",RADTI,"P",RAZ,0),U,13)=RA1PD,RA5=1
  1.  I $O(RA1SR("")) S RA3="" D COPY3^RARTE2 S RA5=1
  1.  I $O(RA1SS("")) S RA3="" D COPY4^RARTE2 S RA5=1
  1.  I $O(RA1SD("")) S RA3="" D COPY5^RARTE2 S RA5=1
  1.  Q:'RA5
  1.  ; set xref for this new case only
  1.  S DIK="^RADPT("_RADFN_",""DT"","_RADTI_",""P"","
  1.  S DA(2)=RADFN,DA(1)=RADTI,DA=RAZ
  1.  D IX1^DIK
  1.  Q