Routine: RAREG4

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

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

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

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAREG4   3460     printed  Mar 13, 2025@21:43:54                                                                                                                                                                                                      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

RAREG4.m