- RAPROD ;HISC/FPT,GJC AISC/MJK-Detailed Exam View ; 5/9/13 2:02pm
- ;;5.0;Radiology/Nuclear Medicine;**10,35,45,56,99,47,110**;Mar 16, 1998;Build 2
- ;Supported IA #2056 GET1^DIQ
- ;Supported IA #2053 UPDATE^DIE
- ;Supported IA #10040 ^SC(
- ;Supported IA #10060 ^VA(200
- ;
- ;05/09/2013 Patch RA*5*110 Rem Ticket 321499 eliminate subscript err
- ;
- START S RADI=^RADPT(RADFN,"DT",RADTI,0) S:$D(^("P",RACNI,"COMP")) RA("COMP")=^("COMP") S RA("REA")=$S($D(^("R")):^("R"),1:"")
- S RA("TECH")=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"TC",0)) I RA("TECH") S RA("TECH")=$S($D(^VA(200,+^(RA("TECH"),0),0)):$P(^(0),"^"),1:"")
- S X=$P(Y(0),"^",4),RA("CAT")=$S(X="I":"INPATIENT",X="O":"OUTPATIENT",X="S":"SHARING",X="C":"CONTRACT",X="R":"RESEARCH",X="E":"EMPLOYEE",1:"UNKNOWN")
- S RA("RST")=$$RSTAT^RAO7PC1A
- F I=1:1:13 S Y=$T(LIST+I),@$P(Y,";",3)=$S($D(@($P(Y,";",4)_+$P(@$P(Y,";",5),"^",$P(Y,";",6))_",0)")):$P(^(0),"^"),1:"")
- ;
- N RAOPRC ; this will be the Requested Procedure defined only if it
- ; differs from the Registered Procedure
- I +$P(Y(0),U,11),($$DPROC^RAUTL15(RADFN,RADTI,RACNI,+$P(Y(0),U,11))]"") D
- . S RAOPRC=$$GET1^DIQ(75.1,+$P(Y(0),"^",11)_",",2)
- . Q
- VIEW W @IOF S X="",$P(X,"=",80)="" W X K X
- W !?2,"Name : ",RANME," ",RASSN
- W !?2,"Division : ",$E(RA("DIV"),1,20),?40,"Category : ",RA("CAT")
- W !?2,"Location : ",$S($D(^SC(+RA("LOC"),0)):$P(^(0),"^"),1:"Unknown"),?40,"Ward : ",$E(RA("WRD"),1,24)
- W !?2,"Exam Date : ",RADATE,?40,"Service : ",$E(RA("SERV"),1,24)
- N RASSAN,RACNDSP S RASSAN=$$SSANVAL^RAHLRU1(RADFN,RADTI,RACNI)
- S RACNDSP=$S((RASSAN'=""):RASSAN,1:RACN)
- I $$USESSAN^RAHLRU1() W !?2,"Case No. : ",RACNDSP W ?40,"Bedsection : ",$E(RA("BED"),1,24)
- I '$$USESSAN^RAHLRU1() W !?2,"Case No. : ",RACN W ?40,"Bedsection : ",$E(RA("BED"),1,24)
- W !?40,"Clinic : ",$E(RA("CL"),1,24)
- S Y=$E(RA("CAT")) I "CSR"[Y W !?40,$E($S("C"=Y:"Contract : "_RA("CONT"),"S"=Y:"Sharing : "_RA("CONT"),"R"=Y:"Research : "_RA("REA"),1:""),1,38)
- W:$X>1 ! S X="",$P(X,"-",80)="" W X K X
- W !?2,"Registered : ",$E(RAPRC,1,60) D PRCCPT
- W:$G(RAOPRC)]"" !?2,"Requested : ",$E(RAOPRC,1,60)
- W !?2,"Requesting Phy: ",$E(RA("PHY"),1,20),?40,"Exam Status : ",$S($D(^RA(72,RAST,0)):$E($P(^(0),"^"),1,24),1:"")
- W !?2,"Int'g Resident: ",$E(RA("RES"),1,20),?40,"Report Status: ",$E(RA("RST"),1,21)
- S RAPREVER=+$P($G(^RARPT(RARPT,0)),"^",13)
- W !?2,"Pre-Verified : ",$E($S($D(^VA(200,RAPREVER,0)):$P(^(0),"^",1),1:"NO"),1,20),?40,"Cam/Equip/Rm : ",$E(RA("RM"),1,20) K RAPREVER
- W !?2,"Int'g Staff : ",$E(RA("STAFF"),1,20),?40,"Diagnosis : ",$E(RA("DIA"),1,24)
- W !?2,"Technologist : ",$E(RA("TECH"),1,20),?40,"Complication : ",$E(RA("CMP"),1,24)
- I $D(RA("COMP")) W !?2,"Comment : " F I=1:60 Q:$E(RA("COMP"),I,I+59)']"" W ?18,$E(RA("COMP"),I,I+59)
- ;W:$X>1 !
- W !
- I $$PTSEX^RAUTL8(RADFN)="F" D ;get pt sex and display pregnancy status for females, ptch #99
- .N RAOR751 S RAOR751=$P($G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)),U,11)
- .W ?2,"Pregnant at time of order entry: ",$$GET1^DIQ(75.1,$G(RAOR751)_",",13)
- K RAFL W ?47,"Films :" F I=0:0 S I=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"F",I)) Q:I'>0 I $D(^(I,0)) S X=^(0) W ?55,$S($D(^RA(78.4,+$P(X,"^"),0)):$P(^(0),"^"),1:"Unknown")," - ",+$P(X,"^",2),!
- W:$X>1 ! S X="",$P(X,"-",34)="" W X
- W "Modifiers" W $E(X,1,32) K X
- W !?2,"Proc Modifiers:" D MODS^RAUTL2 F I=1:1 Q:$P(Y,", ",I)']"" W ?18,$P(Y,", ",I),!
- N J
- W !?2,"CPT Modifiers : " W:Y(1)="None" Y(1),!
- I Y(1)'="None" F I=1:1 Q:$P(Y(2),", ",I)']"" S J=$P(Y(2),", ",I),J=$$BASICMOD^RACPTMSC(J,DT) W ?18,$P(J,"^",2)," ",$P(J,"^",3),! I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() Q:RAXIT W @IOF W !
- Q:+$G(RAXIT)
- I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() Q:RAXIT W @IOF W !
- Q:+$G(RAXIT)
- ;
- ;check for Contrast Media data, print it if it exists.
- I $O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CM",0)) D
- .W !?2,"Contrast Media: " S RACM=1
- .N DIWF,DIWL,DIWR,DIWT,X,Z
- .S X=$$CM^RADEM1(RADFN,RADTI,RACNI),DIWL=20,DIWF="C50"
- .D ^DIWP S Z=0
- .F S Z=$O(^UTILITY($J,"W",DIWL,Z)) Q:'Z D
- ..W ?18,^UTILITY($J,"W",DIWL,Z,0)
- ..W:+$O(^UTILITY($J,"W",DIWL,Z)) !
- ..Q
- .K ^UTILITY($J,"W")
- .Q
- ;
- I $O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"RX",0)) D PHARM^RAPROD2(RACNI_","_RADTI_","_RADFN_",") W ! ; display pharmaceutical data
- I +$G(RAXIT) K RAXIT Q
- I +$P($G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)),"^",28) D RDIO^RAPROD2(+$P(^(0),"^",28)) W ! ; display radiopharm data
- I +$G(RAXIT) K RAXIT Q
- W:$X>1 ! S X="",$P(X,"=",80)="" W X K X
- G ^RAPROD1
- ;
- PRCCPT ; display Proc's abbrv, proc type, CPT
- Q:$G(RADTI)="" Q:$G(RACNI)=""
- ;
- N RADISPLY
- S RADISPLY=$G(^RAMIS(71,+$P($G(^RADPT(+RADFN,"DT",+RADTI,"P",+RACNI,0)),U,2),0)) ; set $ZR to file 71 before calling prccpt^radd1
- S RADISPLY=$$PRCCPT^RADD1()
- W ?54,RADISPLY
- Q
- SETL ;Set long display preference
- N RA1,RA2,DIR
- S RA1=$O(^RA(79,0)) Q:'RA1
- S RA2=$O(^RA(79,RA1,"LDIS","B",DUZ,0))
- I RA2 D Q
- . W !!,"Your preference for Long Display of Procedures has already been set."
- . S DIR(0)="Y",DIR("A")="Do you want to delete your preference ",DIR("B")="No"
- . S DIR("?",1)="If you answer 'Yes', then all Radiology reports requested by you will"
- . S DIR("?",2)="will default to the condensed display, which means that repeated procedures"
- . S DIR("?")="and associated modifiers will only be listed once."
- . D ^DIR
- . Q:'Y
- . D DEL150
- . Q
- W !
- S DIR(0)="Y",DIR("A",1)="Do you want to set your preference for Long Display of Procedures"
- S DIR("A")="in all Radiology reports ",DIR("B")="No"
- S DIR("?",1)="If you answer 'Yes', then all Radiology reports requested by you will"
- S DIR("?",2)="list all repeated procedures and associated modifiers instead of"
- S DIR("?")="listing repeated procedures only once, which is the condensed (default) format."
- D ^DIR
- Q:'Y
- D STUF150
- Q
- DEL150 ;Delete user ien from 1st record in file 79's field 150
- ; note: DIK utility looks for DA(1) here
- Q:'$D(DUZ)#2
- S DA(1)=$O(^RA(79,0)) Q:'DA(1)
- S DIK="^RA(79,"_DA(1)_",""LDIS"","
- S DA=$O(^RA(79,DA(1),"LDIS","B",DUZ,0))
- Q:'DA
- D ^DIK
- K DIK,DA
- W !!,"Your preference for Long Display of Procedures has been removed.",!
- Q
- STUF150 ;Stuff user ien into 1st record in file 79's field 150
- Q:'$D(DUZ)#2
- S RA1=$O(^RA(79,0)) Q:'RA1
- K RAFDA,RAIEN,RAMSG
- S RAFDA(79.03,"?+2,"_RA1_",",.01)=DUZ
- D UPDATE^DIE("","RAFDA","RAIEN","RAMSG")
- W !!,"Your preference for Long Display of Procedures has been set.",!
- Q
- CDIS ; set up RACDIS array to store 1st non-duplicate proc+pmod+cptmod
- N N1,N2,R1,RA71,Y
- K RACDIS
- D LDIS
- S N1=0
- F S N1=$O(^RADPT(RADFN,"DT",RADTI,"P",N1)) Q:'N1 S R1=$G(^(N1,0)) D:R1]""
- . S RA71=$P(R1,U,2),RACNI=N1
- . ; 05/09/2013 Patch RA*5*110 Rem Ticket 321499
- . ; Added next line to emliminate a subscript error in CPRS
- . Q:RA71=""
- . D MODS^RAUTL2
- . S RACDIS("B",RA71,Y,Y(1),N1)=""
- . S N2=$O(RACDIS("B",RA71,Y,Y(1),0))
- . S RACDIS(N2)=$G(RACDIS(N2))+1 ;increment lowest ien of same proc+pmod+cptmod
- . S:RACDIS(N2)>1 RACDIS("RAFLDUP")=1 ;>1 same proc+pmod+cptmod
- . Q
- Q
- LDIS ; See if user prefers Long Display of Procedures
- N RA1
- S RA1=$O(^RA(79,0)) Q:'RA1
- S:$O(^RA(79,RA1,"LDIS","B",DUZ,0)) RALDIS=1
- Q
- LIST ;
- ;;RA("DIV");^DIC(4,;RADI;3
- ;;RA("LOC");^RA(79.1,;RADI;4
- ;;RA("WRD");^DIC(42,;Y(0);6
- ;;RA("SERV");^DIC(49,;Y(0);7
- ;;RA("CL");^SC(;Y(0);8
- ;;RA("CONT");^DIC(34,;Y(0);9
- ;;RA("RES");^VA(200,;Y(0);12
- ;;RA("DIA");^RA(78.3,;Y(0);13
- ;;RA("PHY");^VA(200,;Y(0);14
- ;;RA("STAFF");^VA(200,;Y(0);15
- ;;RA("CMP");^RA(78.1,;Y(0);16
- ;;RA("RM");^RA(78.6,;Y(0);18
- ;;RA("BED");^DIC(42.4,;Y(0);19
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAPROD 7683 printed Feb 19, 2025@00:05:05 Page 2
- RAPROD ;HISC/FPT,GJC AISC/MJK-Detailed Exam View ; 5/9/13 2:02pm
- +1 ;;5.0;Radiology/Nuclear Medicine;**10,35,45,56,99,47,110**;Mar 16, 1998;Build 2
- +2 ;Supported IA #2056 GET1^DIQ
- +3 ;Supported IA #2053 UPDATE^DIE
- +4 ;Supported IA #10040 ^SC(
- +5 ;Supported IA #10060 ^VA(200
- +6 ;
- +7 ;05/09/2013 Patch RA*5*110 Rem Ticket 321499 eliminate subscript err
- +8 ;
- START SET RADI=^RADPT(RADFN,"DT",RADTI,0)
- if $DATA(^("P",RACNI,"COMP"))
- SET RA("COMP")=^("COMP")
- SET RA("REA")=$SELECT($DATA(^("R")):^("R"),1:"")
- +1 SET RA("TECH")=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"TC",0))
- IF RA("TECH")
- SET RA("TECH")=$SELECT($DATA(^VA(200,+^(RA("TECH"),0),0)):$PIECE(^(0),"^"),1:"")
- +2 SET X=$PIECE(Y(0),"^",4)
- SET RA("CAT")=$SELECT(X="I":"INPATIENT",X="O":"OUTPATIENT",X="S":"SHARING",X="C":"CONTRACT",X="R":"RESEARCH",X="E":"EMPLOYEE",1:"UNKNOWN")
- +3 SET RA("RST")=$$RSTAT^RAO7PC1A
- +4 FOR I=1:1:13
- SET Y=$TEXT(LIST+I)
- SET @$PIECE(Y,";",3)=$SELECT($DATA(@($PIECE(Y,";",4)_+$PIECE(@$PIECE(Y,";",5),"^",$PIECE(Y,";",6))_",0)")):$PIECE(^(0),"^"),1:"")
- +5 ;
- +6 ; this will be the Requested Procedure defined only if it
- NEW RAOPRC
- +7 ; differs from the Registered Procedure
- +8 IF +$PIECE(Y(0),U,11)
- IF ($$DPROC^RAUTL15(RADFN,RADTI,RACNI,+$PIECE(Y(0),U,11))]"")
- Begin DoDot:1
- +9 SET RAOPRC=$$GET1^DIQ(75.1,+$PIECE(Y(0),"^",11)_",",2)
- +10 QUIT
- End DoDot:1
- VIEW WRITE @IOF
- SET X=""
- SET $PIECE(X,"=",80)=""
- WRITE X
- KILL X
- +1 WRITE !?2,"Name : ",RANME," ",RASSN
- +2 WRITE !?2,"Division : ",$EXTRACT(RA("DIV"),1,20),?40,"Category : ",RA("CAT")
- +3 WRITE !?2,"Location : ",$SELECT($DATA(^SC(+RA("LOC"),0)):$PIECE(^(0),"^"),1:"Unknown"),?40,"Ward : ",$EXTRACT(RA("WRD"),1,24)
- +4 WRITE !?2,"Exam Date : ",RADATE,?40,"Service : ",$EXTRACT(RA("SERV"),1,24)
- +5 NEW RASSAN,RACNDSP
- SET RASSAN=$$SSANVAL^RAHLRU1(RADFN,RADTI,RACNI)
- +6 SET RACNDSP=$SELECT((RASSAN'=""):RASSAN,1:RACN)
- +7 IF $$USESSAN^RAHLRU1()
- WRITE !?2,"Case No. : ",RACNDSP
- WRITE ?40,"Bedsection : ",$EXTRACT(RA("BED"),1,24)
- +8 IF '$$USESSAN^RAHLRU1()
- WRITE !?2,"Case No. : ",RACN
- WRITE ?40,"Bedsection : ",$EXTRACT(RA("BED"),1,24)
- +9 WRITE !?40,"Clinic : ",$EXTRACT(RA("CL"),1,24)
- +10 SET Y=$EXTRACT(RA("CAT"))
- IF "CSR"[Y
- WRITE !?40,$EXTRACT($SELECT("C"=Y:"Contract : "_RA("CONT"),"S"=Y:"Sharing : "_RA("CONT"),"R"=Y:"Research : "_RA("REA"),1:""),1,38)
- +11 if $X>1
- WRITE !
- SET X=""
- SET $PIECE(X,"-",80)=""
- WRITE X
- KILL X
- +12 WRITE !?2,"Registered : ",$EXTRACT(RAPRC,1,60)
- DO PRCCPT
- +13 if $GET(RAOPRC)]""
- WRITE !?2,"Requested : ",$EXTRACT(RAOPRC,1,60)
- +14 WRITE !?2,"Requesting Phy: ",$EXTRACT(RA("PHY"),1,20),?40,"Exam Status : ",$SELECT($DATA(^RA(72,RAST,0)):$EXTRACT($PIECE(^(0),"^"),1,24),1:"")
- +15 WRITE !?2,"Int'g Resident: ",$EXTRACT(RA("RES"),1,20),?40,"Report Status: ",$EXTRACT(RA("RST"),1,21)
- +16 SET RAPREVER=+$PIECE($GET(^RARPT(RARPT,0)),"^",13)
- +17 WRITE !?2,"Pre-Verified : ",$EXTRACT($SELECT($DATA(^VA(200,RAPREVER,0)):$PIECE(^(0),"^",1),1:"NO"),1,20),?40,"Cam/Equip/Rm : ",$EXTRACT(RA("RM"),1,20)
- KILL RAPREVER
- +18 WRITE !?2,"Int'g Staff : ",$EXTRACT(RA("STAFF"),1,20),?40,"Diagnosis : ",$EXTRACT(RA("DIA"),1,24)
- +19 WRITE !?2,"Technologist : ",$EXTRACT(RA("TECH"),1,20),?40,"Complication : ",$EXTRACT(RA("CMP"),1,24)
- +20 IF $DATA(RA("COMP"))
- WRITE !?2,"Comment : "
- FOR I=1:60
- if $EXTRACT(RA("COMP"),I,I+59)']""
- QUIT
- WRITE ?18,$EXTRACT(RA("COMP"),I,I+59)
- +21 ;W:$X>1 !
- +22 WRITE !
- +23 ;get pt sex and display pregnancy status for females, ptch #99
- IF $$PTSEX^RAUTL8(RADFN)="F"
- Begin DoDot:1
- +24 NEW RAOR751
- SET RAOR751=$PIECE($GET(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)),U,11)
- +25 WRITE ?2,"Pregnant at time of order entry: ",$$GET1^DIQ(75.1,$GET(RAOR751)_",",13)
- End DoDot:1
- +26 KILL RAFL
- WRITE ?47,"Films :"
- FOR I=0:0
- SET I=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"F",I))
- if I'>0
- QUIT
- IF $DATA(^(I,0))
- SET X=^(0)
- WRITE ?55,$SELECT($DATA(^RA(78.4,+$PIECE(X,"^"),0)):$PIECE(^(0),"^"),1:"Unknown")," - ",+$PIECE(X,"^",2),!
- +27 if $X>1
- WRITE !
- SET X=""
- SET $PIECE(X,"-",34)=""
- WRITE X
- +28 WRITE "Modifiers"
- WRITE $EXTRACT(X,1,32)
- KILL X
- +29 WRITE !?2,"Proc Modifiers:"
- DO MODS^RAUTL2
- FOR I=1:1
- if $PIECE(Y,", ",I)']""
- QUIT
- WRITE ?18,$PIECE(Y,", ",I),!
- +30 NEW J
- +31 WRITE !?2,"CPT Modifiers : "
- if Y(1)="None"
- WRITE Y(1),!
- +32 IF Y(1)'="None"
- FOR I=1:1
- if $PIECE(Y(2),", ",I)']""
- QUIT
- SET J=$PIECE(Y(2),", ",I)
- SET J=$$BASICMOD^RACPTMSC(J,DT)
- WRITE ?18,$PIECE(J,"^",2)," ",$PIECE(J,"^",3),!
- IF $Y>(IOSL-4)
- SET RAXIT=$$EOS^RAUTL5()
- if RAXIT
- QUIT
- WRITE @IOF
- WRITE !
- +33 if +$GET(RAXIT)
- QUIT
- +34 IF $Y>(IOSL-4)
- SET RAXIT=$$EOS^RAUTL5()
- if RAXIT
- QUIT
- WRITE @IOF
- WRITE !
- +35 if +$GET(RAXIT)
- QUIT
- +36 ;
- +37 ;check for Contrast Media data, print it if it exists.
- +38 IF $ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CM",0))
- Begin DoDot:1
- +39 WRITE !?2,"Contrast Media: "
- SET RACM=1
- +40 NEW DIWF,DIWL,DIWR,DIWT,X,Z
- +41 SET X=$$CM^RADEM1(RADFN,RADTI,RACNI)
- SET DIWL=20
- SET DIWF="C50"
- +42 DO ^DIWP
- SET Z=0
- +43 FOR
- SET Z=$ORDER(^UTILITY($JOB,"W",DIWL,Z))
- if 'Z
- QUIT
- Begin DoDot:2
- +44 WRITE ?18,^UTILITY($JOB,"W",DIWL,Z,0)
- +45 if +$ORDER(^UTILITY($JOB,"W",DIWL,Z))
- WRITE !
- +46 QUIT
- End DoDot:2
- +47 KILL ^UTILITY($JOB,"W")
- +48 QUIT
- End DoDot:1
- +49 ;
- +50 ; display pharmaceutical data
- IF $ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"RX",0))
- DO PHARM^RAPROD2(RACNI_","_RADTI_","_RADFN_",")
- WRITE !
- +51 IF +$GET(RAXIT)
- KILL RAXIT
- QUIT
- +52 ; display radiopharm data
- IF +$PIECE($GET(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)),"^",28)
- DO RDIO^RAPROD2(+$PIECE(^(0),"^",28))
- WRITE !
- +53 IF +$GET(RAXIT)
- KILL RAXIT
- QUIT
- +54 if $X>1
- WRITE !
- SET X=""
- SET $PIECE(X,"=",80)=""
- WRITE X
- KILL X
- +55 GOTO ^RAPROD1
- +56 ;
- PRCCPT ; display Proc's abbrv, proc type, CPT
- +1 if $GET(RADTI)=""
- QUIT
- if $GET(RACNI)=""
- QUIT
- +2 ;
- +3 NEW RADISPLY
- +4 ; set $ZR to file 71 before calling prccpt^radd1
- SET RADISPLY=$GET(^RAMIS(71,+$PIECE($GET(^RADPT(+RADFN,"DT",+RADTI,"P",+RACNI,0)),U,2),0))
- +5 SET RADISPLY=$$PRCCPT^RADD1()
- +6 WRITE ?54,RADISPLY
- +7 QUIT
- SETL ;Set long display preference
- +1 NEW RA1,RA2,DIR
- +2 SET RA1=$ORDER(^RA(79,0))
- if 'RA1
- QUIT
- +3 SET RA2=$ORDER(^RA(79,RA1,"LDIS","B",DUZ,0))
- +4 IF RA2
- Begin DoDot:1
- +5 WRITE !!,"Your preference for Long Display of Procedures has already been set."
- +6 SET DIR(0)="Y"
- SET DIR("A")="Do you want to delete your preference "
- SET DIR("B")="No"
- +7 SET DIR("?",1)="If you answer 'Yes', then all Radiology reports requested by you will"
- +8 SET DIR("?",2)="will default to the condensed display, which means that repeated procedures"
- +9 SET DIR("?")="and associated modifiers will only be listed once."
- +10 DO ^DIR
- +11 if 'Y
- QUIT
- +12 DO DEL150
- +13 QUIT
- End DoDot:1
- QUIT
- +14 WRITE !
- +15 SET DIR(0)="Y"
- SET DIR("A",1)="Do you want to set your preference for Long Display of Procedures"
- +16 SET DIR("A")="in all Radiology reports "
- SET DIR("B")="No"
- +17 SET DIR("?",1)="If you answer 'Yes', then all Radiology reports requested by you will"
- +18 SET DIR("?",2)="list all repeated procedures and associated modifiers instead of"
- +19 SET DIR("?")="listing repeated procedures only once, which is the condensed (default) format."
- +20 DO ^DIR
- +21 if 'Y
- QUIT
- +22 DO STUF150
- +23 QUIT
- DEL150 ;Delete user ien from 1st record in file 79's field 150
- +1 ; note: DIK utility looks for DA(1) here
- +2 if '$DATA(DUZ)#2
- QUIT
- +3 SET DA(1)=$ORDER(^RA(79,0))
- if 'DA(1)
- QUIT
- +4 SET DIK="^RA(79,"_DA(1)_",""LDIS"","
- +5 SET DA=$ORDER(^RA(79,DA(1),"LDIS","B",DUZ,0))
- +6 if 'DA
- QUIT
- +7 DO ^DIK
- +8 KILL DIK,DA
- +9 WRITE !!,"Your preference for Long Display of Procedures has been removed.",!
- +10 QUIT
- STUF150 ;Stuff user ien into 1st record in file 79's field 150
- +1 if '$DATA(DUZ)#2
- QUIT
- +2 SET RA1=$ORDER(^RA(79,0))
- if 'RA1
- QUIT
- +3 KILL RAFDA,RAIEN,RAMSG
- +4 SET RAFDA(79.03,"?+2,"_RA1_",",.01)=DUZ
- +5 DO UPDATE^DIE("","RAFDA","RAIEN","RAMSG")
- +6 WRITE !!,"Your preference for Long Display of Procedures has been set.",!
- +7 QUIT
- CDIS ; set up RACDIS array to store 1st non-duplicate proc+pmod+cptmod
- +1 NEW N1,N2,R1,RA71,Y
- +2 KILL RACDIS
- +3 DO LDIS
- +4 SET N1=0
- +5 FOR
- SET N1=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",N1))
- if 'N1
- QUIT
- SET R1=$GET(^(N1,0))
- if R1]""
- Begin DoDot:1
- +6 SET RA71=$PIECE(R1,U,2)
- SET RACNI=N1
- +7 ; 05/09/2013 Patch RA*5*110 Rem Ticket 321499
- +8 ; Added next line to emliminate a subscript error in CPRS
- +9 if RA71=""
- QUIT
- +10 DO MODS^RAUTL2
- +11 SET RACDIS("B",RA71,Y,Y(1),N1)=""
- +12 SET N2=$ORDER(RACDIS("B",RA71,Y,Y(1),0))
- +13 ;increment lowest ien of same proc+pmod+cptmod
- SET RACDIS(N2)=$GET(RACDIS(N2))+1
- +14 ;>1 same proc+pmod+cptmod
- if RACDIS(N2)>1
- SET RACDIS("RAFLDUP")=1
- +15 QUIT
- End DoDot:1
- +16 QUIT
- LDIS ; See if user prefers Long Display of Procedures
- +1 NEW RA1
- +2 SET RA1=$ORDER(^RA(79,0))
- if 'RA1
- QUIT
- +3 if $ORDER(^RA(79,RA1,"LDIS","B",DUZ,0))
- SET RALDIS=1
- +4 QUIT
- LIST ;
- +1 ;;RA("DIV");^DIC(4,;RADI;3
- +2 ;;RA("LOC");^RA(79.1,;RADI;4
- +3 ;;RA("WRD");^DIC(42,;Y(0);6
- +4 ;;RA("SERV");^DIC(49,;Y(0);7
- +5 ;;RA("CL");^SC(;Y(0);8
- +6 ;;RA("CONT");^DIC(34,;Y(0);9
- +7 ;;RA("RES");^VA(200,;Y(0);12
- +8 ;;RA("DIA");^RA(78.3,;Y(0);13
- +9 ;;RA("PHY");^VA(200,;Y(0);14
- +10 ;;RA("STAFF");^VA(200,;Y(0);15
- +11 ;;RA("CMP");^RA(78.1,;Y(0);16
- +12 ;;RA("RM");^RA(78.6,;Y(0);18
- +13 ;;RA("BED");^DIC(42.4,;Y(0);19