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

RART3.m

Go to the documentation of this file.
  1. RART3 ;HISC/GJC,SWM-Reporting Menu (Part 2) ;05/22/09 09:20
  1. ;;5.0;Radiology/Nuclear Medicine;**8,10,18,27,35,45,75,99**;Mar 16, 1998;Build 5
  1. ; continue from RART1
  1. ; last modif by SS for P18
  1. ; p99 changed the Staff Phys title to Staff Imaging Phys
  1. ;Supported IA #10103 reference to ^XLFDT
  1. ;
  1. QRPT ; Queue the report to run
  1. N X K IOP,%ZIS S %ZIS="Q",%ZIS("B")=""
  1. S %ZIS("S")="I $E($P($G(^%ZIS(2,+$P($G(^(""SUBTYPE"")),""^""),0)),""^""),1,2)=""P-"""
  1. W ! D ^%ZIS
  1. I POP D Q6^RART1 Q
  1. I $E(IOST,1,2)="P-",('$D(IO("Q"))) D
  1. . D PRT^RARTR
  1. . Q
  1. I $D(IO("Q")) D
  1. . K RANME,RAPRC,Y S U="^",DT=$S($G(DT)]"":DT,1:$$DT^XLFDT())
  1. . S ZTDESC="Rad/Nuc Med Abnormal Report Alert",ZTRTN="PRT^RARTR"
  1. . S:$D(RARTMES) ZTSAVE("RARTMES")=""
  1. . F I="DT","RARPT","U" S ZTSAVE(I)=""
  1. . D ^%ZTLOAD W:$D(ZTSK) " Task # ",ZTSK
  1. . K IO("Q"),ZTDESC,ZTRTN,ZTSAVE
  1. . Q
  1. W ! D ^%ZISC,HOME^%ZIS
  1. D Q6^RART1,EXIT^RART
  1. Q
  1. PHYS N RA2ND,R1,R2,RASTR
  1. S (R1,R2)=0 F S R2=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"SRR",R2)) Q:'R2 S:+$G(^(R2,0)) R1=R1+1,RA2ND("SRR",R1)=+^(0),RA2ND("SRR",R1)=$E($P($G(^VA(200,RA2ND("SRR",R1),0)),"^"),1,20)
  1. S (R1,R2)=0 F S R2=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"SSR",R2)) Q:'R2 S:+$G(^(R2,0)) R1=R1+1,RA2ND("SSR",R1)=+^(0),RA2ND("SSR",R1)=$E($P($G(^VA(200,RA2ND("SSR",R1),0)),"^"),1,20)
  1. S R1=$E($P($G(^VA(200,+$P(R3,"^",15),0)),"^"),1,15)
  1. S RASTR="Staff Imaging Phys: "_R1 S:R1]"" RASTR=RASTR_" (P)"
  1. PHYS1 I '$O(RA2ND("SSR",0)) W !,RASTR G PHYS2
  1. S R1=0
  1. PHYS11 S R1=$O(RA2ND("SSR",R1)) G:R1="" PHYS19
  1. I $L(RASTR)+$L(RA2ND("SSR",R1))>79 W !,RASTR,";" S RASTR=" "
  1. S:RASTR]" " RASTR=RASTR_"; " S RASTR=RASTR_RA2ND("SSR",R1) G PHYS11
  1. PHYS19 W:RASTR]"" !,RASTR
  1. PHYS2 S R1=$E($P($G(^VA(200,+$P(R3,"^",12),0)),"^"),1,15)
  1. S RASTR="Residents : "_R1 S:R1]"" RASTR=RASTR_" (P)"
  1. I '$O(RA2ND("SRR",0)) W !,RASTR Q
  1. S R1=0
  1. PHYS21 S R1=$O(RA2ND("SRR",R1)) G:R1="" PHYS29
  1. I $L(RASTR)+$L(RA2ND("SRR",R1))>79 W !,RASTR,";" S RASTR=" "
  1. S:RASTR]" " RASTR=RASTR_"; " S RASTR=RASTR_RA2ND("SRR",R1) G PHYS21
  1. PHYS29 W:RASTR]"" !,RASTR
  1. Q
  1. MODSET ; print modifiers of all cases of print set
  1. N RACDIS,RALDIS,RACNISAV,RAMEMARR,R1
  1. D EN2^RAUTL20(.RAMEMARR) Q:'$O(RAMEMARR(0))
  1. S RACNISAV=RACNI,RACNI=0
  1. D CDIS^RAPROD S (RAREZON,RACNI)=0
  1. ;for printsets print the REASON FOR STUDY along with the lead procedure
  1. ;(avoid duplicate printing of the same data)
  1. F S RACNI=$O(RAMEMARR(RACNI)) Q:'RACNI D Q:$L($G(X)) I $G(RAXIT) S X="^" Q
  1. . S R1=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
  1. . D MODS^RAUTL2
  1. . ; If printing page at a time we need to check the length - RA*5*8
  1. . I $Y>(IOSL-6),'$D(RARTVERF) S RAP="" D WAIT^RART1 I X="^"!(X="P")!(X="T") Q
  1. . K X
  1. . D OUT1 S RAREZON=1
  1. . S:+$P(R1,"^",28) X=$$RDIO1^RARTUTL1(+$P(R1,"^",28)) Q:$L($G(X))
  1. . S:+$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"RX",0)) X=$$PHARM1^RARTUTL(RACNI_","_RADTI_","_RADFN_",")
  1. . W:$O(RAMEMARR(RACNI)) !
  1. . Q
  1. S RACNI=RACNISAV
  1. W ! K RAREZON
  1. Q
  1. OUT1 ; print Procedure name, CPT code, Procedure modifier, and CPT Modifiers
  1. ; $O(RAMEMARR(0)) may be defined, if previously called MODSET^RART3
  1. ; RALDIS flags long display wanted, comes from certain output options
  1. ; RACDIS(n) exists if case n is to be displayed
  1. ; RACDIS(n) not set for dupl proc+pmod+cptmod so don't display
  1. ; If printset, skip if not long format or case not marked for cond.displ
  1. I $O(RAMEMARR(0)),'$G(RALDIS),'$D(RACDIS(RACNI)) Q
  1. N I,J,RACRF S RACRF=1
  1. N RA18RET S RA18RET=0 ;P18
  1. S R1=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
  1. S RASTUDY=$P($G(^RAO(75.1,+$P(R1,U,11),.1)),U) ;Convey 'Reason for Study' P75
  1. ; Check if cancelled and not part of this report
  1. I $P(^RA(72,+$P(R1,"^",3),0),"^",3)=0,($P(R1,"^",17)="") Q
  1. I $P(^RA(72,+$P(R1,"^",3),0),"^",3)=0 D
  1. .W !,$S($G(RALDIS):"",'$D(RACDIS):"",$G(RACDIS(RACNI))=1:"",1:RACDIS(RACNI)_"x"),?4,$E($P($G(^RAMIS(71,+$P(R1,"^",2),0)),"^"),1,42)_" (cancelled)"
  1. E W !,$S($G(RALDIS):"",'$D(RACDIS):"",$G(RACDIS(RACNI))=1:"",1:RACDIS(RACNI)_"x"),?4,$P($G(^RAMIS(71,+$P(R1,"^",2),0)),"^")
  1. D PRCCPT^RAPROD ;disp proc. abbr, proc type, & CPT
  1. ;check for contrast media; display if CM data exists (patch 45)
  1. S RACMDATA=$$CMEDIA^RAUTL8(RADFN,RADTI,RACNI)
  1. I $L(RACMDATA) D
  1. .W !?5,"Contrast Media :"
  1. .F RAIZ=1:1 Q:$P(RACMDATA,", ",RAIZ)="" D
  1. ..W ?22,$P(RACMDATA,", ",RAIZ) W:$P(RACMDATA,", ",RAIZ+1)'="" !
  1. ..I '$D(RARTVERF),$Y>(IOSL-5) S RAXIT=$$EOS^RAUTL5() S:RAXIT RA18RET=-1 Q:RAXIT W @IOF W !
  1. ..Q
  1. .K RAIZ
  1. .QUIT
  1. K RACMDATA Q:RA18RET=-1 ;P18
  1. W:Y'="None" !?5,"Proc Modifiers : ",Y
  1. W:Y(1)'="None" !?5,"CPT Modifiers :"
  1. I Y(1)'="None" S RACRF=0 D
  1. .F I=1:1 Q:$P(Y(2),", ",I)']"" S J=$P(Y(2),", ",I),J=$$BASICMOD^RACPTMSC(J,DT) W ?22,$P(J,"^",2)," ",$P(J,"^",3) W:$P(Y(2),", ",I+1)]"" ! I '$D(RARTVERF),$Y>(IOSL-5) S RAXIT=$$EOS^RAUTL5() S:RAXIT RA18RET=-1 Q:RAXIT W @IOF W !
  1. Q:RA18RET=-1
  1. I $L(RASTUDY),$G(RAREZON,0)=0 W:RACRF ! S RACRF=0 D DIWP^RAUTL5(5,68,"Reason for Study: "_RASTUDY) ;P75
  1. K RASTUDY
  1. ;RATECHCO is defined in OPTION FILE's ENTRY/EXIT ACTION
  1. I $D(RATECHCO) W:RACRF ! S RA18RET=$$PUTTCOM^RAUTL11(RADFN,RADTI,RACNI," Tech.Comment : ",22,70,7,0,0,2,0) S:RA18RET=-1 RAXIT=1 Q:RA18RET=-1 ;P18
  1. Q