source: FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAREG4.m@ 1757

Last change on this file since 1757 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 3.3 KB
Line 
1RAREG4 ;HISC/GJC-Register Patient (cont) ;11/5/97 11:38
2 ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
3PSETPNT ; Select an active parent printset procedure.
4 I $O(RAORDS(1)) S Y=0 Q ; shldn't have more than 1 proc selected
5 S RA6=$O(RAORDS(0))
6 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)
7 W !!?5,"You may replace this with a Printset Parent Procedure",!?5,"of the same imaging type.",!
8 S DIC="^RAMIS(71,"
9 S DIC(0)="AEQMZ"
10 S DIC("A")="Select Printset Parent Procedure : "
11 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
12 D ^DIC
13 S:Y>0 RADPARPR=+Y
14 I Y<1 W !!?5,"The selection is invalid.",!,*7 K RADPARFL ;kill flag
15 Q
16PROCESS ; Process orders, register exams for both parent procedures
17 ; and non-parent procedures.
18 I RASKIPIT S RASKIPIT=0 G EXAM2
19 S RAPROC=+$P($G(^RAO(75.1,+RAOIFN,0)),U,2) S:$D(RADPARFL) RAPROC=RADPARPR ; change proc ien if detail-to-parent
20 I $D(RAVSTFLG)#2,$P($G(^RAMIS(71,RAPROC,0)),U,6)="P" D Q
21 . W !!?5,"Parent procedures may not be added to this visit.",$C(7)
22 . Q
23 I $P($G(^RAMIS(71,RAPROC,0)),U,6)="P",$O(^RAMIS(71,RAPROC,4,0)) D
24 . W !!?5,"Parent procedure: ",$$PROC^RAREG1(RAPROC)
25 . S (RADESC,RASKIPIT)=0
26 . F S RADESC=$O(^RAMIS(71,RAPROC,4,RADESC)) Q:RADESC'>0!RAEXIT!RAQUIT D
27 .. I RASKIPIT S RASKIPIT=0 G EXAM1
28 .. D ORDER^RAREG2 Q:RAQUIT
29 .. S RAPROCI=+$P($G(^RAMIS(71,RAPROC,4,RADESC,0)),U)
30 .. S RAPRC=$$PROC^RAREG1(RAPROCI)
31 .. W !!?5,"Descendent procedure: ",RAPRC
32 .. D EXAMLOOP^RAREG2,MEMSET^RAREG2(RADFN,RADTI,RACNI),EXAMSET^RAREG2
33EXAM1 .. I RAEXIT'>0 D
34 ... N RA S RA=+$O(^RAMIS(71,RAPROC,4,RADESC))
35 ... S RA=$$PROC^RAREG1(+$P($G(^RAMIS(71,RAPROC,4,RA,0)),U)) Q:RA=""
36 ... S DIR("A",1)="",DIR("A",2)="Register next descendent exam ("_RA_")"
37 ... S DIR("A")="for "_RANME,DIR("B")="Yes"
38 ... S DIR(0)="Y" W ! D ^DIR K DIR
39 ... S RAEXIT=$S($D(DTOUT)!$D(DUOUT):1,1:0),RASKIPIT='Y
40 ... Q
41 .. Q
42 . I 'RAEXIT D XTRADESC^RAREG2
43 . Q
44 E D
45 . S RAPROCI=RAPROC
46 . W !!?5,"Procedure: ",$$PROC^RAREG1(RAPROCI)
47 . D ORDER^RAREG2 Q:RAQUIT D EXAMLOOP^RAREG2
48 . Q
49EXAM2 I (RAQUIT+RAEXIT)=0 D
50 . N RA S RA=+$G(RAORDS(RAOLP+1))
51 . S RA=$$PROC^RAREG1($P($G(^RAO(75.1,RA,0)),U,2)) Q:RA=""
52 . S DIR("A",1)="Register the next requested exam ("_RA_")"
53 . S DIR("A")="for "_RANME_" (Y/N)"
54 . S DIR(0)="Y" W ! D ^DIR K DIR
55 . S RAEXIT=$S($D(DTOUT)!$D(DUOUT):1,1:0),RASKIPIT='Y
56 . Q
57 Q
58Q4 ; Unlock the record at the "DT" level, kill variables
59 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
60 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
61 K RATYPE,RAVISIT1,RAVLEDTI,RAVLECNI,RAWARD,RAX,RAY,RAZ,YY,VAINDT,VADMVT
62 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
63 ; do NOT kill RAVSTFLG here -- logic loops back to ask another Patient
64 K ZRACCESS,ZRAIMGTY,ZRAMDIV,ZRAMDV,ZRAMLC,ZRADTI
65 K RADPARPR,RADPARFL,^TMP($J,"PRO-ORD"),^TMP($J,"PRO-REG"),^("RAREG1")
66 K DIPGM,DISYS,DIFLD,DIK,DK,DL,DM,DQ,HLN,HLRESLT,HLSAN,X0
67 Q
Note: See TracBrowser for help on using the repository browser.