Routine: RAREG3

RAREG3 ;HISC/CAH,DAD,FPT,GJC-Register Rad/NM Patient (cont.) ;6/10/97  08:45

 ;;5.0;Radiology/Nuclear Medicine;**8**;Mar 16, 1998

RSBIT ; renumber selections by imaging type

 ; The RAORDS array has the list of orders the user selected to register

 ; in the order the user entered them. This subroutine will reorganize

 ; the array so the orders are arranged by imaging type of their

 ; procedure starting with the imaging type the user is currently signed

 ; on with followed by the ascending internal entry number of the

 ; remaining imaging types.

 Q:'$D(RAORDS)

 K RALOOP,RAORDST

 F RALOOP=1:1 Q:'$D(RAORDS(RALOOP))  D

 .S RAON=+$P(RAORDS(RALOOP),U,1) Q:'RAON

 .S RAPN=+$P(^RAO(75.1,RAON,0),U,2) Q:'RAPN

 .S RAIN=+$P(^RAMIS(71,RAPN,0),U,12) Q:'RAIN

 .S RAORDST(RAIN,RALOOP)=RAON

.Q

 S RAIMGTYN=+$O(^RA(79.2,"B",RAIMGTY,0)) Q:'RAIMGTYN

 K RAORDS S (RALOOP,RAIN)=0

 I $D(RAORDST(RAIMGTYN)) F  S RAIN=$O(RAORDST(RAIMGTYN,RAIN)) Q:'RAIN  S RALOOP=RALOOP+1,RAORDS(RALOOP)=+RAORDST(RAIMGTYN,RAIN) K RAORDST(RAIMGTYN,RAIN)

 I $D(RAORDST) S RAIMGTYN=0 F  S RAIMGTYN=$O(RAORDST(RAIMGTYN)) Q:'RAIMGTYN  S RAIN=0 F  S RAIN=$O(RAORDST(RAIMGTYN,RAIN)) Q:'RAIN  S RALOOP=RALOOP+1,RAORDS(RALOOP)=+RAORDST(RAIMGTYN,RAIN)

 K RAIMGTYN,RAIN,RALOOP,RAON,RAORDST,RAPN

SETDISV ; when registering procedures of different imaging types set imaging

 ; location default value in DIC("B") if only one location associated with

 ; imaging type.

 N RACNT,RAITNHLD,RAITNXT,RALOOP

 S (RACNT,RAITNXT)=0

 F RALOOP=0:0 S RAITNXT=$O(^RA(79.1,"BIMG",RAITN,RAITNXT)) Q:'RAITNXT  S RACNT=RACNT+1,RAITNHLD=RAITNXT

 ;I RACNT=1 S ^DISV(+DUZ,"^RA(79.1,")=RAITNHLD

 I RACNT=1,RAITNHLD,$G(^RA(79.1,RAITNHLD,0))]"" S DIC("B")=$P($G(^SC(+^(0),0)),"^")

SL ; switch locations

 ; Prompt the user to switch locations if the current sign-on imaging

 ; type does not match the procedure's imaging type.

 ; comment out 06/10/97 D EXAMSET^RAREG2 S RAPARENT=0

 S RAITN=$P(^RAMIS(71,+$P(Y,U,2),0),U,12)

 I RAITN'=+$O(^RA(79.2,"B",RAIMGTY,0)) D

 .S RAMLCHLD=RAMLC,RAYHOLD=Y,RAPROLOC=$P(^RA(79.2,RAITN,0),U,1),RAMDIVHD=RAMDIV

 .D LABEL

 .W !!?7,"Current Imaging Type: ",RAIMGTY

 .W !?5,"Procedure Imaging Type: ",RAPROLOC

 .W !!,"You must switch to a location of ",RAPROLOC," imaging type.",!!

 .D SETDISV

 .K RAMLC S RASWLOC=""

 .D SET^RAPSET1

 .K RASWLOC

 .I '$D(RAMLC) S RAQUIT=1,RAMLC=RAMLCHLD Q

 .I RAMDIVHD'=RAMDIV W !!,"You have switched Divisions from: ",$P(^DIC(4,+RAMDIVHD,0),U),!,?30,"to: ",$P(^DIC(4,+RAMDIV,0),U),!

 .D DT Q:RAQUIT

 .S Y=RAYHOLD

.Q

 K RAITN,RAMDIVHD,RAMLCHLD,RAPROLOC,RAYHOLD

DT ; prompt for new imaging date/time when imaging type changes

 Q:'$D(^RADPT(RADFN,"DT",RADTI,0))

 N RAHRS S RAHRS=+$P($G(^RA(79,+RAMDIV,.1)),"^",24) ;How many hrs in adv?

 R !!,"Imaging Exam Date/Time: NOW// ",X:DTIME

 I '$T!(X=" ")!(X="^") S RAQUIT=1 Q

 S:X="" RANOW="",X="NOW"

 I X="NOW" S RADTICHK=9999999.9999-($E($$NOW^XLFDT,1,12)) I $D(^RADPT(RADFN,"DT",RADTICHK,0)) D SUB1MIN K RADTICHK

 S %DT(0)=-$$FMADD^XLFDT($$NOW^XLFDT,0,RAHRS,0,0),%DT="ETXR"

 D ^%DT K %DT G DT:Y<0

DT1 S RADTE=Y,RADTI=9999999.9999-RADTE I $D(^RADPT(RADFN,"DT",RADTI,0)) W !,*7,"Patient already has exams entered for this date/time.",!,"....use 'Add Exams to Last Visit' option." G DT

DT2 K RADTEBAD S RADTEBAD=$O(^RADPT(RADFN,"DT","B",RADTE)) I RADTEBAD[RADTE D SUB1MIN S RADTE=X,RADTI=RADTICHK G DT2

 K RADTEBAD

 I $D(RANOW),$D(RAWARD) S RACAT="INPATIENT"

 I '$D(RANOW) K RAWARD,RABED,RASER D ^RASERV S:$D(RAWARD) RACAT="INPATIENT"

SUB1MIN ; subtract 1 minute from NOW to get an unused date/time

 F RALOOP=1:1 S X=$$FMADD^XLFDT(RADTE,0,0,-RALOOP,0) S RADTICHK=9999999.9999-X Q:'$D(^RADPT(RADFN,"DT",RADTICHK,0))

 K RALOOP

LABEL ; *** Print labels

 I $D(RAPX) D

 . W ! S RAPX=RADFN,RAZIS=1

 . S RASAV2=$G(^RADPT(+$G(RADFN),"DT",+$G(RADTI),0))

 . S RASAV3=$G(^RADPT(+$G(RADFN),"DT",+$G(RADTI),"P",$S($G(RACNI):RACNI,1:+$O(^RADPT(+$G(RADFN),"DT",+$G(RADTI),"P",0))),0))

 . D FLH^RAFLH K RANUMF

 . I $P(RAMDV,U,8) D JAC^RAJAC

 . S RADFN=RAPX K RAZIS

 . I $P($G(^DIC(195.4,1,"UP")),U,2) D ^RTQ5

 . K RAPX

. Q

RAREG3    ;HISC/CAH,DAD,FPT,GJC-Register Rad/NM Patient (cont.) ;6/10/97  08:45

 +1       ;;5.0;Radiology/Nuclear Medicine;**8**;Mar 16, 1998

 +2       ;

RSBIT     ; renumber selections by imaging type

 +1       ; The RAORDS array has the list of orders the user selected to register

 +2       ; in the order the user entered them. This subroutine will reorganize

 +3       ; the array so the orders are arranged by imaging type of their

 +4       ; procedure starting with the imaging type the user is currently signed

 +5       ; on with followed by the ascending internal entry number of the

 +6       ; remaining imaging types.

 +7       ;

 +8        IF '$DATA(RAORDS)

               QUIT

 +9        KILL RALOOP,RAORDST

 +10       FOR RALOOP=1:1

               IF '$DATA(RAORDS(RALOOP))

                   QUIT

               Begin DoDot:1

 +11               SET RAON=+$PIECE(RAORDS(RALOOP),U,1)

                   IF 'RAON

                       QUIT

 +12               SET RAPN=+$PIECE(^RAO(75.1,RAON,0),U,2)

                   IF 'RAPN

                       QUIT

 +13               SET RAIN=+$PIECE(^RAMIS(71,RAPN,0),U,12)

                   IF 'RAIN

                       QUIT

 +14               SET RAORDST(RAIN,RALOOP)=RAON

 +15               QUIT

               End DoDot:1

 +16       SET RAIMGTYN=+$ORDER(^RA(79.2,"B",RAIMGTY,0))

           IF 'RAIMGTYN

               QUIT

 +17       KILL RAORDS

           SET (RALOOP,RAIN)=0

 +18       IF $DATA(RAORDST(RAIMGTYN))

FOR

                   SET RAIN=$ORDER(RAORDST(RAIMGTYN,RAIN))

                   IF 'RAIN

                       QUIT

                   SET RALOOP=RALOOP+1

                   SET RAORDS(RALOOP)=+RAORDST(RAIMGTYN,RAIN)

                   KILL RAORDST(RAIMGTYN,RAIN)

 +19       IF $DATA(RAORDST)

               SET RAIMGTYN=0

FOR

                   SET RAIMGTYN=$ORDER(RAORDST(RAIMGTYN))

                   IF 'RAIMGTYN

                       QUIT

                   SET RAIN=0

FOR

                       SET RAIN=$ORDER(RAORDST(RAIMGTYN,RAIN))

                       IF 'RAIN

                           QUIT

                       SET RALOOP=RALOOP+1

                       SET RAORDS(RALOOP)=+RAORDST(RAIMGTYN,RAIN)

 +20       KILL RAIMGTYN,RAIN,RALOOP,RAON,RAORDST,RAPN

 +21       QUIT

SETDISV   ; when registering procedures of different imaging types set imaging

 +1       ; location default value in DIC("B") if only one location associated with

 +2       ; imaging type.

 +3        NEW RACNT,RAITNHLD,RAITNXT,RALOOP

 +4        SET (RACNT,RAITNXT)=0

 +5        FOR RALOOP=0:0

               SET RAITNXT=$ORDER(^RA(79.1,"BIMG",RAITN,RAITNXT))

               IF 'RAITNXT

                   QUIT

               SET RACNT=RACNT+1

               SET RAITNHLD=RAITNXT

 +6       ;I RACNT=1 S ^DISV(+DUZ,"^RA(79.1,")=RAITNHLD

 +7        IF RACNT=1

               IF RAITNHLD

                   IF $GET(^RA(79.1,RAITNHLD,0))]""

                       SET DIC("B")=$PIECE($GET(^SC(+^(0),0)),"^")

 +8        QUIT

SL        ; switch locations

 +1       ; Prompt the user to switch locations if the current sign-on imaging

 +2       ; type does not match the procedure's imaging type.

 +3       ; comment out 06/10/97 D EXAMSET^RAREG2 S RAPARENT=0

 +4        SET RAITN=$PIECE(^RAMIS(71,+$PIECE(Y,U,2),0),U,12)

 +5        IF RAITN'=+$ORDER(^RA(79.2,"B",RAIMGTY,0))

               Begin DoDot:1

 +6                SET RAMLCHLD=RAMLC

                   SET RAYHOLD=Y

                   SET RAPROLOC=$PIECE(^RA(79.2,RAITN,0),U,1)

                   SET RAMDIVHD=RAMDIV

 +7                DO LABEL

 +8                WRITE !!?7,"Current Imaging Type: ",RAIMGTY

 +9                WRITE !?5,"Procedure Imaging Type: ",RAPROLOC

 +10               WRITE !!,"You must switch to a location of ",RAPROLOC," imaging type.",!!

 +11               DO SETDISV

 +12               KILL RAMLC

                   SET RASWLOC=""

 +13               DO SET^RAPSET1

 +14               KILL RASWLOC

 +15               IF '$DATA(RAMLC)

                       SET RAQUIT=1

                       SET RAMLC=RAMLCHLD

                       QUIT

 +16               IF RAMDIVHD'=RAMDIV

                       WRITE !!,"You have switched Divisions from: ",$PIECE(^DIC(4,+RAMDIVHD,0),U),!,?30,"to: ",$PIECE(^DIC(4,+RAMDIV,0),U),!

 +17               DO DT

                   IF RAQUIT

                       QUIT

 +18               SET Y=RAYHOLD

 +19               QUIT

               End DoDot:1

 +20       KILL RAITN,RAMDIVHD,RAMLCHLD,RAPROLOC,RAYHOLD

 +21       QUIT

DT        ; prompt for new imaging date/time when imaging type changes

 +1        IF '$DATA(^RADPT(RADFN,"DT",RADTI,0))

               QUIT

 +2       ;How many hrs in adv?

           NEW RAHRS

           SET RAHRS=+$PIECE($GET(^RA(79,+RAMDIV,.1)),"^",24)

 +3        READ !!,"Imaging Exam Date/Time: NOW// ",X:DTIME

 +4        IF '$TEST!(X=" ")!(X="^")

               SET RAQUIT=1

               QUIT

 +5        IF X=""

               SET RANOW=""

               SET X="NOW"

 +6        IF X="NOW"

               SET RADTICHK=9999999.9999-($EXTRACT($$NOW^XLFDT,1,12))

               IF $DATA(^RADPT(RADFN,"DT",RADTICHK,0))

                   DO SUB1MIN

                   KILL RADTICHK

 +7        SET %DT(0)=-$$FMADD^XLFDT($$NOW^XLFDT,0,RAHRS,0,0)

           SET %DT="ETXR"

 +8        DO ^%DT

           KILL %DT

           IF Y<0

               GOTO DT

DT1        SET RADTE=Y

           SET RADTI=9999999.9999-RADTE

           IF $DATA(^RADPT(RADFN,"DT",RADTI,0))

               WRITE !,*7,"Patient already has exams entered for this date/time.",!,"....use 'Add Exams to Last Visit' option."

               GOTO DT

DT2        KILL RADTEBAD

           SET RADTEBAD=$ORDER(^RADPT(RADFN,"DT","B",RADTE))

           IF RADTEBAD[RADTE

               DO SUB1MIN

               SET RADTE=X

               SET RADTI=RADTICHK

               GOTO DT2

 +1        KILL RADTEBAD

 +2        IF $DATA(RANOW)

               IF $DATA(RAWARD)

                   SET RACAT="INPATIENT"

 +3        IF '$DATA(RANOW)

               KILL RAWARD,RABED,RASER

               DO ^RASERV

               IF $DATA(RAWARD)

                   SET RACAT="INPATIENT"

 +4        QUIT

SUB1MIN   ; subtract 1 minute from NOW to get an unused date/time

 +1        FOR RALOOP=1:1

               SET X=$$FMADD^XLFDT(RADTE,0,0,-RALOOP,0)

               SET RADTICHK=9999999.9999-X

               IF '$DATA(^RADPT(RADFN,"DT",RADTICHK,0))

                   QUIT

 +2        KILL RALOOP

 +3        QUIT

 +4       ;

LABEL     ; *** Print labels

 +1        IF $DATA(RAPX)

               Begin DoDot:1

 +2                WRITE !

                   SET RAPX=RADFN

                   SET RAZIS=1

 +3                SET RASAV2=$GET(^RADPT(+$GET(RADFN),"DT",+$GET(RADTI),0))

 +4                SET RASAV3=$GET(^RADPT(+$GET(RADFN),"DT",+$GET(RADTI),"P",$SELECT($GET(RACNI):RACNI,1:+$ORDER(^RADPT(+$GET(RADFN),"DT",+$GET(RADTI),"P",0))),0))

 +5                DO FLH^RAFLH

                   KILL RANUMF

 +6                IF $PIECE(RAMDV,U,8)

                       DO JAC^RAJAC

 +7                SET RADFN=RAPX

                   KILL RAZIS

 +8                IF $PIECE($GET(^DIC(195.4,1,"UP")),U,2)

                       DO ^RTQ5

 +9                KILL RAPX

 +10               QUIT

               End DoDot:1

 +11       QUIT

RAREG3.m