RAREG4 ;HISC/GJC-Register Patient (cont) ;11/5/97 11:38
;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
PSETPNT ; Select an active parent printset procedure.
I $O(RAORDS(1)) S Y=0 Q ; shldn't have more than 1 proc selected
S RA6=$O(RAORDS(0))
W !!,"Current procedure for this order is ",$P($G(^RAMIS(71,$P(^RAO(75.1,+RAORDS(RA6),0),U,2),0)),U) S RAIMG1=$P(^(0),U,12)
W !!?5,"You may replace this with a Printset Parent Procedure",!?5,"of the same imaging type.",!
S DIC="^RAMIS(71,"
S DIC(0)="AEQMZ"
S DIC("A")="Select Printset Parent Procedure : "
S DIC("S")="I $P(^(0),U,12)=RAIMG1,$P(^(0),U,6)=""P"",$P(^(0),U,18)=""Y"",$S('$D(^(""I"")):1,'^(""I""):1,DT'>^(""I""):1,1:0)" ; screen to accept: same img typ, parent, sngl rpt, active proc
D ^DIC
S:Y>0 RADPARPR=+Y
I Y<1 W !!?5,"The selection is invalid.",!,*7 K RADPARFL ;kill flag
Q
PROCESS ; Process orders, register exams for both parent procedures
; and non-parent procedures.
I RASKIPIT S RASKIPIT=0 G EXAM2
S RAPROC=+$P($G(^RAO(75.1,+RAOIFN,0)),U,2) S:$D(RADPARFL) RAPROC=RADPARPR ; change proc ien if detail-to-parent
I $D(RAVSTFLG)#2,$P($G(^RAMIS(71,RAPROC,0)),U,6)="P" D Q
. W !!?5,"Parent procedures may not be added to this visit.",$C(7)
. Q
I $P($G(^RAMIS(71,RAPROC,0)),U,6)="P",$O(^RAMIS(71,RAPROC,4,0)) D
. W !!?5,"Parent procedure: ",$$PROC^RAREG1(RAPROC)
. S (RADESC,RASKIPIT)=0
. F S RADESC=$O(^RAMIS(71,RAPROC,4,RADESC)) Q:RADESC'>0!RAEXIT!RAQUIT D
.. I RASKIPIT S RASKIPIT=0 G EXAM1
.. D ORDER^RAREG2 Q:RAQUIT
.. S RAPROCI=+$P($G(^RAMIS(71,RAPROC,4,RADESC,0)),U)
.. S RAPRC=$$PROC^RAREG1(RAPROCI)
.. W !!?5,"Descendent procedure: ",RAPRC
.. D EXAMLOOP^RAREG2,MEMSET^RAREG2(RADFN,RADTI,RACNI),EXAMSET^RAREG2
EXAM1 .. I RAEXIT'>0 D
... N RA S RA=+$O(^RAMIS(71,RAPROC,4,RADESC))
... S RA=$$PROC^RAREG1(+$P($G(^RAMIS(71,RAPROC,4,RA,0)),U)) Q:RA=""
... S DIR("A",1)="",DIR("A",2)="Register next descendent exam ("_RA_")"
... S DIR("A")="for "_RANME,DIR("B")="Yes"
... S DIR(0)="Y" W ! D ^DIR K DIR
... S RAEXIT=$S($D(DTOUT)!$D(DUOUT):1,1:0),RASKIPIT='Y
... Q
.. Q
. I 'RAEXIT D XTRADESC^RAREG2
. Q
E D
. S RAPROCI=RAPROC
. W !!?5,"Procedure: ",$$PROC^RAREG1(RAPROCI)
. D ORDER^RAREG2 Q:RAQUIT D EXAMLOOP^RAREG2
. Q
EXAM2 I (RAQUIT+RAEXIT)=0 D
. N RA S RA=+$G(RAORDS(RAOLP+1))
. S RA=$$PROC^RAREG1($P($G(^RAO(75.1,RA,0)),U,2)) Q:RA=""
. S DIR("A",1)="Register the next requested exam ("_RA_")"
. S DIR("A")="for "_RANME_" (Y/N)"
. S DIR(0)="Y" W ! D ^DIR K DIR
. S RAEXIT=$S($D(DTOUT)!$D(DUOUT):1,1:0),RASKIPIT='Y
. Q
Q
Q4 ; Unlock the record at the "DT" level, kill variables
L -^RADPT(RADFN,"DT",RADTI) K DIRUT,PY,RA,RA0,RA2,RABED,RACAT,RACLNC,RACN,RACNI,RACNICNT,RACNT,RADIV,RADT,RADTE,RADTI,RADUZ,RAEXFM,RAEXLBLS,RAFLH,RAFLHCNT,RAFMT
K RALIFN,RALOC,RANME,RANOW,RANUM,RANUMF,RANS,RAOLP,RAORDNUM,RAORDS,RAOSTS,RAOUT,RAQUIT,RAP,RAP0,RAPHY,RAPIFN,RAPRC,RAPRI,RAR,RARDTE,RAREC,RAREGFLG,RARSH,RASER,RASET,RASHA,RASX
K RATYPE,RAVISIT1,RAVLEDTI,RAVLECNI,RAWARD,RAX,RAY,RAZ,YY,VAINDT,VADMVT
K %,%DT,%Y,A,D0,D1,D2,DA,DIC,DIE,DIV,DR,GMRAL,J,NOW,POP,RADFN,RADTE99,RAFLHFL,RAOIFN,RAPOP,RAPTFL,RAPX,RASEL,RASEX,RT,RTDFN,X,Y
; do NOT kill RAVSTFLG here -- logic loops back to ask another Patient
K ZRACCESS,ZRAIMGTY,ZRAMDIV,ZRAMDV,ZRAMLC,ZRADTI
K RADPARPR,RADPARFL,^TMP($J,"PRO-ORD"),^TMP($J,"PRO-REG"),^("RAREG1")
K DIPGM,DISYS,DIFLD,DIK,DK,DL,DM,DQ,HLN,HLRESLT,HLSAN,X0
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAREG4 3460 printed Sep 11, 2024@02:58:59 Page 2
RAREG4 ;HISC/GJC-Register Patient (cont) ;11/5/97 11:38
+1 ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
PSETPNT ; Select an active parent printset procedure.
+1 ; shldn't have more than 1 proc selected
IF $ORDER(RAORDS(1))
SET Y=0
QUIT
+2 SET RA6=$ORDER(RAORDS(0))
+3 WRITE !!,"Current procedure for this order is ",$PIECE($GET(^RAMIS(71,$PIECE(^RAO(75.1,+RAORDS(RA6),0),U,2),0)),U)
SET RAIMG1=$PIECE(^(0),U,12)
+4 WRITE !!?5,"You may replace this with a Printset Parent Procedure",!?5,"of the same imaging type.",!
+5 SET DIC="^RAMIS(71,"
+6 SET DIC(0)="AEQMZ"
+7 SET DIC("A")="Select Printset Parent Procedure : "
+8 ; screen to accept: same img typ, parent, sngl rpt, active proc
SET DIC("S")="I $P(^(0),U,12)=RAIMG1,$P(^(0),U,6)=""P"",$P(^(0),U,18)=""Y"",$S('$D(^(""I"")):1,'^(""I""):1,DT'>^(""I""):1,1:0)"
+9 DO ^DIC
+10 if Y>0
SET RADPARPR=+Y
+11 ;kill flag
IF Y<1
WRITE !!?5,"The selection is invalid.",!,*7
KILL RADPARFL
+12 QUIT
PROCESS ; Process orders, register exams for both parent procedures
+1 ; and non-parent procedures.
+2 IF RASKIPIT
SET RASKIPIT=0
GOTO EXAM2
+3 ; change proc ien if detail-to-parent
SET RAPROC=+$PIECE($GET(^RAO(75.1,+RAOIFN,0)),U,2)
if $DATA(RADPARFL)
SET RAPROC=RADPARPR
+4 IF $DATA(RAVSTFLG)#2
IF $PIECE($GET(^RAMIS(71,RAPROC,0)),U,6)="P"
Begin DoDot:1
+5 WRITE !!?5,"Parent procedures may not be added to this visit.",$CHAR(7)
+6 QUIT
End DoDot:1
QUIT
+7 IF $PIECE($GET(^RAMIS(71,RAPROC,0)),U,6)="P"
IF $ORDER(^RAMIS(71,RAPROC,4,0))
Begin DoDot:1
+8 WRITE !!?5,"Parent procedure: ",$$PROC^RAREG1(RAPROC)
+9 SET (RADESC,RASKIPIT)=0
+10 FOR
SET RADESC=$ORDER(^RAMIS(71,RAPROC,4,RADESC))
if RADESC'>0!RAEXIT!RAQUIT
QUIT
Begin DoDot:2
+11 IF RASKIPIT
SET RASKIPIT=0
GOTO EXAM1
+12 DO ORDER^RAREG2
if RAQUIT
QUIT
+13 SET RAPROCI=+$PIECE($GET(^RAMIS(71,RAPROC,4,RADESC,0)),U)
+14 SET RAPRC=$$PROC^RAREG1(RAPROCI)
+15 WRITE !!?5,"Descendent procedure: ",RAPRC
+16 DO EXAMLOOP^RAREG2
DO MEMSET^RAREG2(RADFN,RADTI,RACNI)
DO EXAMSET^RAREG2
EXAM1 IF RAEXIT'>0
Begin DoDot:3
+1 NEW RA
SET RA=+$ORDER(^RAMIS(71,RAPROC,4,RADESC))
+2 SET RA=$$PROC^RAREG1(+$PIECE($GET(^RAMIS(71,RAPROC,4,RA,0)),U))
if RA=""
QUIT
+3 SET DIR("A",1)=""
SET DIR("A",2)="Register next descendent exam ("_RA_")"
+4 SET DIR("A")="for "_RANME
SET DIR("B")="Yes"
+5 SET DIR(0)="Y"
WRITE !
DO ^DIR
KILL DIR
+6 SET RAEXIT=$SELECT($DATA(DTOUT)!$DATA(DUOUT):1,1:0)
SET RASKIPIT='Y
+7 QUIT
End DoDot:3
+8 QUIT
End DoDot:2
+9 IF 'RAEXIT
DO XTRADESC^RAREG2
+10 QUIT
End DoDot:1
+11 IF '$TEST
Begin DoDot:1
+12 SET RAPROCI=RAPROC
+13 WRITE !!?5,"Procedure: ",$$PROC^RAREG1(RAPROCI)
+14 DO ORDER^RAREG2
if RAQUIT
QUIT
DO EXAMLOOP^RAREG2
+15 QUIT
End DoDot:1
EXAM2 IF (RAQUIT+RAEXIT)=0
Begin DoDot:1
+1 NEW RA
SET RA=+$GET(RAORDS(RAOLP+1))
+2 SET RA=$$PROC^RAREG1($PIECE($GET(^RAO(75.1,RA,0)),U,2))
if RA=""
QUIT
+3 SET DIR("A",1)="Register the next requested exam ("_RA_")"
+4 SET DIR("A")="for "_RANME_" (Y/N)"
+5 SET DIR(0)="Y"
WRITE !
DO ^DIR
KILL DIR
+6 SET RAEXIT=$SELECT($DATA(DTOUT)!$DATA(DUOUT):1,1:0)
SET RASKIPIT='Y
+7 QUIT
End DoDot:1
+8 QUIT
Q4 ; Unlock the record at the "DT" level, kill variables
+1 LOCK -^RADPT(RADFN,"DT",RADTI)
KILL DIRUT,PY,RA,RA0,RA2,RABED,RACAT,RACLNC,RACN,RACNI,RACNICNT,RACNT,RADIV,RADT,RADTE,RADTI,RADUZ,RAEXFM,RAEXLBLS,RAFLH,RAFLHCNT,RAFMT
+2 KILL RALIFN,RALOC,RANME,RANOW,RANUM,RANUMF,RANS,RAOLP,RAORDNUM,RAORDS,RAOSTS,RAOUT,RAQUIT,RAP,RAP0,RAPHY,RAPIFN,RAPRC,RAPRI,RAR,RARDTE,RAREC,RAREGFLG,RARSH,RASER,RASET,RASHA,RASX
+3 KILL RATYPE,RAVISIT1,RAVLEDTI,RAVLECNI,RAWARD,RAX,RAY,RAZ,YY,VAINDT,VADMVT
+4 KILL %,%DT,%Y,A,D0,D1,D2,DA,DIC,DIE,DIV,DR,GMRAL,J,NOW,POP,RADFN,RADTE99,RAFLHFL,RAOIFN,RAPOP,RAPTFL,RAPX,RASEL,RASEX,RT,RTDFN,X,Y
+5 ; do NOT kill RAVSTFLG here -- logic loops back to ask another Patient
+6 KILL ZRACCESS,ZRAIMGTY,ZRAMDIV,ZRAMDV,ZRAMLC,ZRADTI
+7 KILL RADPARPR,RADPARFL,^TMP($JOB,"PRO-ORD"),^TMP($JOB,"PRO-REG"),^("RAREG1")
+8 KILL DIPGM,DISYS,DIFLD,DIK,DK,DL,DM,DQ,HLN,HLRESLT,HLSAN,X0
+9 QUIT
