RAMAIN4 ;BPFO/CLT - RADIOLOGY NEW PROCEDURE UTILITIES ; 28 Sep 2016 12:04 PM
;;5.0;Radiology/Nuclear Medicine;**127,138**;Mar 16, 1998;Build 22
;
Q
EN(RADA) ;PRIMARY ENTRY POINT
N DIR,RATYPE,RAFAC,RAFN,RACODE,RAGOLD,RAMATCH,RANM,RANOT,RAPLUSY,RAPROIEN,RAYY,XMDUN,RANEWPRO
N P1,P2,RA901
I $G(DA)'="",$G(RADA)="" S RADA=DA
S RANM=$P(^RAMIS(71,+RADA,0),U,1),^XTMP("RAMAIN4",$J,"RAEND")=0,RADA=+RADA
GOOD ;ACCEPT ENTRY AND ASSIGN CPT
S RATYPE=$P(^RAMIS(71,RADA,0),U,6) D:RATYPE'="D"
.W !!?3,"The type of this exam has been chosen not to be DETAILED."," An NTRT process",!?3,"will not be initiated. And no MRPF matching will be performed.",!
.Q
Q:RATYPE'="D"
K DIR S DIR(0)="Y",DIR("A")="Are you sure you are entering "_RANM_" as a new procedure"
S RASEED=" " S RASEED=$S($P($G(^RAMRPF(71.98,1,0)),U,10)'="Y":" not ",1:" ")
S DIR("A",1)="This entry will"_RASEED_"be submitted for NTRT processing."
S DIR("B")="YES"
W ! D ^DIR S:Y=0 ^XTMP("RAMAIN4",$J,"RAEND")=1 G:^XTMP("RAMAIN4",$J,"RAEND")=1 END
CPTEN ;Enter the CPT code
I $G(RAX)="QUIT"!(X["^") G END
W !!,"The CPT code is needed to match to an entry within the MASTER",!,"RADIOLOGY PROCEDURE file."
I $G(RACPT)'="" W !!,"The CPT code for this procedure is ",RACPT,"."
I $G(RACPT)="" K DIR S DIR(0)="71,9^^",DIR("A")="Enter the CPT code for this procedure, if the CPT code is known"
I $G(RACPT)="" K DIRUT,DIROUT,DUOUT W ! D ^DIR I $G(DIRUT)=1 G END
S:X>0 $P(^RAMIS(71,RADA,0),U,9)=X,RACPT=X
S DA=RADA,RAGOLD=$$MRPF^RAMAIN5() I $G(DUOUT)=1!($G(Y(0))="") W !!,*7,"No MRPF match made. Use the Edit MRPF Association on One Procedure",!,"option to make a match later.",!! G END
I $G(RAPROIEN)'="",$D(^RAMIS(71,"MRPF",$S($G(RAPROIEN)'="":RAPROIEN,1:0))) S RAMTCH=1 D MTCH^RAUTL23
G:$G(^XTMP("RAMAIN4",$J,"RAEND"))=1 END
; RA*5.0*138 correct set of 900 to IEN
I Y(0)'["NONE LISTED" S DA=RADA,DIE="^RAMIS(71,",DIE(0)="L",DR="900///"_RAPROIEN_";902///"_DT S DA=RADA D ^DIE D
. I $G(RAPROIEN)'="" W !?3,"You have mapped this procedure to "_$P($G(^RAMRPF(71.99,RAPROIEN,0)),U,1) Q
I $G(Y(0))["NONE LISTED" D
. ; PATCH RA*5.0*138 START
. ;S DA=RADA,DIE="^RAMIA(71,",DIE(0)="L"
. S DA=RADA,DIE="^RAMIS(71,",DIE(0)="L"
. ; PATCH RA*5.0*138 END
. S DR="901///" S RA901=$S($P($G(^RAMRPF(71.98,1,0)),U,10)="Y":"Y",1:"")
. S DR=DR_RA901_";902///"_DT D ^DIE
. Q
S $P(^RAMIS(71,RADA,"NTRT"),U,3)=DT,^RAMIS(71,"CREAT",DT,RADA)=""
I $P($G(^RAMRPF(71.98,1,0)),U,10)'="Y" S $P(^RAMIS(71,RADA,"NTRT"),U,3)=""
MSG ;SEND A MESSAGE TO GATEKEEPER
I $P($G(^RAMRPF(71.98,1,0)),U,10)'="Y" Q RADA
N XMSUB,XMY,XMTEXT,RATXT Q:$P($G(^RAMIS(71,RADA,"NTRT")),U,1)'="" RADA
S XMSUB="NEW RADIOLOGY PROCEDURE"
S XMY(DUZ)=""
I $P($G(^RAMRPF(71.98,1,0)),U,2)'="" S XMY($P(^RAMRPF(71.98,1,0),U,2))=""
S RATXT(1)="A new Radiology procedure has been entered."
S RATXT(3)="This procedure will be submitted for NTRT processing."
S RATXT(4)=" "
S RATXT(5)=" "
;S RATXT(7)=" "
S RATXT(7)="Procedure Name: "_RANM
S RATXT(7)="CPT: "_$P($G(^RAMIS(71,RADA,0)),U,9)
S XMTEXT="RATXT(" D ^XMD
;G END
MSG1 ;MESSAGE TO NTRT
I $P($G(^RAMRPF(71.98,1,0)),U,10)'="Y" Q RADA
N XMSUB,XMY,XMTEXT,RATXT Q:$P($G(^RAMIS(71,RADA,"NTRT")),U,1)'="" RADA
S RAFAC=$$KSP^XUPARAM("INST"),RAFAC=$$NS^XUAF4(RAFAC)
S RAFN=$P(RAFAC,U,1),RAFAC=$P(RAFAC,U,2),$P(^RAMIS(71,RADA,"NTRT"),U,2)="Y"
S XMSUB="NEW RADIOLOGY PROCEDURE"
S XMY("G.RADIOLOGY NTRT@DOMAIN.EXT")=""
S XMY("G.RADNTRT")=""
S XMDUZ("G.RADNTRT")=""
I $P($G(^RAMRPF(71.98,1,0)),U,2)'="" S XMY($P(^RAMRPF(71.98,1,0),U,2))=""
;S XMY("G.RADIOLOGY NTRT@DOMAIN.EXT")=""
S RATXT(1)="A new Radiology procedure has been entered at "_RAFN
S RATXT(2)=" "
S RATXT(3)="Facility Name/number: "_RAFN_" / "_RAFAC
S RATXT(4)=" "
S RATXT(5)="Procedure name: "_RANM
S RATXT(6)=" "
S RATXT(7)="CPT code: "_$P($G(^RAMIS(71,RADA,0)),U,9)
S RATXT(8)="Local IEN: "_RADA
S RATXT(9)="For questions or notification respond to: "_"G.RADNTRT@"_$$KSP^XUPARAM("WHERE")
S RATXT(10)="For NTRT results respond to: "_"S.RANEWPRO@"_$$KSP^XUPARAM("WHERE")
I $P($G(^RAMRPF(71.98,1,0)),U,9)="Y" D XML G END
S $P(^RAMIS(71,RADA,"NTRT"),U,4)=DT
S XMTEXT="RATXT(" D ^XMD
S $P(^RAMIS(71,RADA,"NTRT"),U,4)=DT
G END
XML ; NTRT message for ISAAC
; Need P1 ISAAC SCHEMA NAME
; Need P2 ISAAC SCHEMA PATH
; get the schemea name and the schema path
S P1=$$GET1^DIQ(71.98,"1,",11)
S P2=$$GET1^DIQ(71.98,"1,",11.5)
S A=$TR(P1,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
I P1'=""&($E(A,($L(A)-4),$L(A)))'=".XSD" S P1=P1_".XSD"
I P2'="" D ;<
. I $E(P2,1,2)'="//" S P2="//"_P2
. I $E(P2,$L(P2))'="/" S P2=P2_"/"
S A="uri:"_P2_P1
K RATXT
S RATXT(1)=$$XMLHDR^MXMLUTL()
S RATXT(2)="<DATAEXTRACTS xmlns="""_A_""" xmlns:xsi=""$P(^RAMRPF(71.98,1,0),U,8)"""
S RATXT(3)=">"
S RATXT(4)="<RAD_NTRT>"
S RATXT(5)="<Facility_Name/number>"_RAFN_" / "_RAFAC_"</Facility_Name/number>"
S RATXT(6)="<Facility_Group_e-mail>"_"G.RADNTRT@"_$$KSP^XUPARAM("WHERE")_"</Facility_Group_e-mail>"
S RATXT(7)="<Procedure_name>"_RANM_"</Procedure_name>"
S RATXT(8)="<CPT_code>"_$P($G(^RAMIS(71,RADA,0)),U,9)_"</CPT_code>"
S RATXT(9)="<Local_IEN>"_RADA_"</Local_IEN>"
S RATXT(10)="<NTRT_results_response_e-mail>"_"S.RANEWPRO@"_$$KSP^XUPARAM("WHERE")_"</NTRT_results_response_e-mail>"
S RATXT(11)="</RAD_NTRT>"
S RATXT(12)="</DATAEXTRACTS>"
S RAXTMPNM=XMSUB
D XMLSND^RAXMLSND(RAXTMPNM)
Q
;
DEACT ;BLOCK INACTIVATION DATE
Q
I $P($G(^RAMRPF(71.98,1,0)),U,3)'="" D
. S X1=DT,X2=$P(^RAMRPF(71.98,1,0),U,3)
. D C^%DTC
. S ^RAMIS(71,RADA,"I")=X,$P(^RAMIS(71,RADA,"NTRT"),U,2)="Y"
Q
END ;KILL LOCAL VARIABLES AND END
K RATXT,XMZ,XMDUN,XMDUZ,RAIEN,X,Y
Q $G(RANEWPRO)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAMAIN4 5761 printed Apr 09, 2024@21:39:24 Page 2
RAMAIN4 ;BPFO/CLT - RADIOLOGY NEW PROCEDURE UTILITIES ; 28 Sep 2016 12:04 PM
+1 ;;5.0;Radiology/Nuclear Medicine;**127,138**;Mar 16, 1998;Build 22
+2 ;
+3 QUIT
EN(RADA) ;PRIMARY ENTRY POINT
+1 NEW DIR,RATYPE,RAFAC,RAFN,RACODE,RAGOLD,RAMATCH,RANM,RANOT,RAPLUSY,RAPROIEN,RAYY,XMDUN,RANEWPRO
+2 NEW P1,P2,RA901
+3 IF $GET(DA)'=""
IF $GET(RADA)=""
SET RADA=DA
+4 SET RANM=$PIECE(^RAMIS(71,+RADA,0),U,1)
SET ^XTMP("RAMAIN4",$JOB,"RAEND")=0
SET RADA=+RADA
GOOD ;ACCEPT ENTRY AND ASSIGN CPT
+1 SET RATYPE=$PIECE(^RAMIS(71,RADA,0),U,6)
if RATYPE'="D"
Begin DoDot:1
+2 WRITE !!?3,"The type of this exam has been chosen not to be DETAILED."," An NTRT process",!?3,"will not be initiated. And no MRPF matching will be performed.",!
+3 QUIT
End DoDot:1
+4 if RATYPE'="D"
QUIT
+5 KILL DIR
SET DIR(0)="Y"
SET DIR("A")="Are you sure you are entering "_RANM_" as a new procedure"
+6 SET RASEED=" "
SET RASEED=$SELECT($PIECE($GET(^RAMRPF(71.98,1,0)),U,10)'="Y":" not ",1:" ")
+7 SET DIR("A",1)="This entry will"_RASEED_"be submitted for NTRT processing."
+8 SET DIR("B")="YES"
+9 WRITE !
DO ^DIR
if Y=0
SET ^XTMP("RAMAIN4",$JOB,"RAEND")=1
if ^XTMP("RAMAIN4",$JOB,"RAEND")=1
GOTO END
CPTEN ;Enter the CPT code
+1 IF $GET(RAX)="QUIT"!(X["^")
GOTO END
+2 WRITE !!,"The CPT code is needed to match to an entry within the MASTER",!,"RADIOLOGY PROCEDURE file."
+3 IF $GET(RACPT)'=""
WRITE !!,"The CPT code for this procedure is ",RACPT,"."
+4 IF $GET(RACPT)=""
KILL DIR
SET DIR(0)="71,9^^"
SET DIR("A")="Enter the CPT code for this procedure, if the CPT code is known"
+5 IF $GET(RACPT)=""
KILL DIRUT,DIROUT,DUOUT
WRITE !
DO ^DIR
IF $GET(DIRUT)=1
GOTO END
+6 if X>0
SET $PIECE(^RAMIS(71,RADA,0),U,9)=X
SET RACPT=X
+7 SET DA=RADA
SET RAGOLD=$$MRPF^RAMAIN5()
IF $GET(DUOUT)=1!($GET(Y(0))="")
WRITE !!,*7,"No MRPF match made. Use the Edit MRPF Association on One Procedure",!,"option to make a match later.",!!
GOTO END
+8 IF $GET(RAPROIEN)'=""
IF $DATA(^RAMIS(71,"MRPF",$SELECT($GET(RAPROIEN)'="":RAPROIEN,1:0)))
SET RAMTCH=1
DO MTCH^RAUTL23
+9 if $GET(^XTMP("RAMAIN4",$JOB,"RAEND"))=1
GOTO END
+10 ; RA*5.0*138 correct set of 900 to IEN
+11 IF Y(0)'["NONE LISTED"
SET DA=RADA
SET DIE="^RAMIS(71,"
SET DIE(0)="L"
SET DR="900///"_RAPROIEN_";902///"_DT
SET DA=RADA
DO ^DIE
Begin DoDot:1
+12 IF $GET(RAPROIEN)'=""
WRITE !?3,"You have mapped this procedure to "_$PIECE($GET(^RAMRPF(71.99,RAPROIEN,0)),U,1)
QUIT
End DoDot:1
+13 IF $GET(Y(0))["NONE LISTED"
Begin DoDot:1
+14 ; PATCH RA*5.0*138 START
+15 ;S DA=RADA,DIE="^RAMIA(71,",DIE(0)="L"
+16 SET DA=RADA
SET DIE="^RAMIS(71,"
SET DIE(0)="L"
+17 ; PATCH RA*5.0*138 END
+18 SET DR="901///"
SET RA901=$SELECT($PIECE($GET(^RAMRPF(71.98,1,0)),U,10)="Y":"Y",1:"")
+19 SET DR=DR_RA901_";902///"_DT
DO ^DIE
+20 QUIT
End DoDot:1
+21 SET $PIECE(^RAMIS(71,RADA,"NTRT"),U,3)=DT
SET ^RAMIS(71,"CREAT",DT,RADA)=""
+22 IF $PIECE($GET(^RAMRPF(71.98,1,0)),U,10)'="Y"
SET $PIECE(^RAMIS(71,RADA,"NTRT"),U,3)=""
MSG ;SEND A MESSAGE TO GATEKEEPER
+1 IF $PIECE($GET(^RAMRPF(71.98,1,0)),U,10)'="Y"
QUIT RADA
+2 NEW XMSUB,XMY,XMTEXT,RATXT
if $PIECE($GET(^RAMIS(71,RADA,"NTRT")),U,1)'=""
QUIT RADA
+3 SET XMSUB="NEW RADIOLOGY PROCEDURE"
+4 SET XMY(DUZ)=""
+5 IF $PIECE($GET(^RAMRPF(71.98,1,0)),U,2)'=""
SET XMY($PIECE(^RAMRPF(71.98,1,0),U,2))=""
+6 SET RATXT(1)="A new Radiology procedure has been entered."
+7 SET RATXT(3)="This procedure will be submitted for NTRT processing."
+8 SET RATXT(4)=" "
+9 SET RATXT(5)=" "
+10 ;S RATXT(7)=" "
+11 SET RATXT(7)="Procedure Name: "_RANM
+12 SET RATXT(7)="CPT: "_$PIECE($GET(^RAMIS(71,RADA,0)),U,9)
+13 SET XMTEXT="RATXT("
DO ^XMD
+14 ;G END
MSG1 ;MESSAGE TO NTRT
+1 IF $PIECE($GET(^RAMRPF(71.98,1,0)),U,10)'="Y"
QUIT RADA
+2 NEW XMSUB,XMY,XMTEXT,RATXT
if $PIECE($GET(^RAMIS(71,RADA,"NTRT")),U,1)'=""
QUIT RADA
+3 SET RAFAC=$$KSP^XUPARAM("INST")
SET RAFAC=$$NS^XUAF4(RAFAC)
+4 SET RAFN=$PIECE(RAFAC,U,1)
SET RAFAC=$PIECE(RAFAC,U,2)
SET $PIECE(^RAMIS(71,RADA,"NTRT"),U,2)="Y"
+5 SET XMSUB="NEW RADIOLOGY PROCEDURE"
+6 SET XMY("G.RADIOLOGY NTRT@DOMAIN.EXT")=""
+7 SET XMY("G.RADNTRT")=""
+8 SET XMDUZ("G.RADNTRT")=""
+9 IF $PIECE($GET(^RAMRPF(71.98,1,0)),U,2)'=""
SET XMY($PIECE(^RAMRPF(71.98,1,0),U,2))=""
+10 ;S XMY("G.RADIOLOGY NTRT@DOMAIN.EXT")=""
+11 SET RATXT(1)="A new Radiology procedure has been entered at "_RAFN
+12 SET RATXT(2)=" "
+13 SET RATXT(3)="Facility Name/number: "_RAFN_" / "_RAFAC
+14 SET RATXT(4)=" "
+15 SET RATXT(5)="Procedure name: "_RANM
+16 SET RATXT(6)=" "
+17 SET RATXT(7)="CPT code: "_$PIECE($GET(^RAMIS(71,RADA,0)),U,9)
+18 SET RATXT(8)="Local IEN: "_RADA
+19 SET RATXT(9)="For questions or notification respond to: "_"G.RADNTRT@"_$$KSP^XUPARAM("WHERE")
+20 SET RATXT(10)="For NTRT results respond to: "_"S.RANEWPRO@"_$$KSP^XUPARAM("WHERE")
+21 IF $PIECE($GET(^RAMRPF(71.98,1,0)),U,9)="Y"
DO XML
GOTO END
+22 SET $PIECE(^RAMIS(71,RADA,"NTRT"),U,4)=DT
+23 SET XMTEXT="RATXT("
DO ^XMD
+24 SET $PIECE(^RAMIS(71,RADA,"NTRT"),U,4)=DT
+25 GOTO END
XML ; NTRT message for ISAAC
+1 ; Need P1 ISAAC SCHEMA NAME
+2 ; Need P2 ISAAC SCHEMA PATH
+3 ; get the schemea name and the schema path
+4 SET P1=$$GET1^DIQ(71.98,"1,",11)
+5 SET P2=$$GET1^DIQ(71.98,"1,",11.5)
+6 SET A=$TRANSLATE(P1,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+7 IF P1'=""&($EXTRACT(A,($LENGTH(A)-4),$LENGTH(A)))'=".XSD"
SET P1=P1_".XSD"
+8 ;<
IF P2'=""
Begin DoDot:1
+9 IF $EXTRACT(P2,1,2)'="//"
SET P2="//"_P2
+10 IF $EXTRACT(P2,$LENGTH(P2))'="/"
SET P2=P2_"/"
End DoDot:1
+11 SET A="uri:"_P2_P1
+12 KILL RATXT
+13 SET RATXT(1)=$$XMLHDR^MXMLUTL()
+14 SET RATXT(2)="<DATAEXTRACTS xmlns="""_A_""" xmlns:xsi=""$P(^RAMRPF(71.98,1,0),U,8)"""
+15 SET RATXT(3)=">"
+16 SET RATXT(4)="<RAD_NTRT>"
+17 SET RATXT(5)="<Facility_Name/number>"_RAFN_" / "_RAFAC_"</Facility_Name/number>"
+18 SET RATXT(6)="<Facility_Group_e-mail>"_"G.RADNTRT@"_$$KSP^XUPARAM("WHERE")_"</Facility_Group_e-mail>"
+19 SET RATXT(7)="<Procedure_name>"_RANM_"</Procedure_name>"
+20 SET RATXT(8)="<CPT_code>"_$PIECE($GET(^RAMIS(71,RADA,0)),U,9)_"</CPT_code>"
+21 SET RATXT(9)="<Local_IEN>"_RADA_"</Local_IEN>"
+22 SET RATXT(10)="<NTRT_results_response_e-mail>"_"S.RANEWPRO@"_$$KSP^XUPARAM("WHERE")_"</NTRT_results_response_e-mail>"
+23 SET RATXT(11)="</RAD_NTRT>"
+24 SET RATXT(12)="</DATAEXTRACTS>"
+25 SET RAXTMPNM=XMSUB
+26 DO XMLSND^RAXMLSND(RAXTMPNM)
+27 QUIT
+28 ;
DEACT ;BLOCK INACTIVATION DATE
+1 QUIT
+2 IF $PIECE($GET(^RAMRPF(71.98,1,0)),U,3)'=""
Begin DoDot:1
+3 SET X1=DT
SET X2=$PIECE(^RAMRPF(71.98,1,0),U,3)
+4 DO C^%DTC
+5 SET ^RAMIS(71,RADA,"I")=X
SET $PIECE(^RAMIS(71,RADA,"NTRT"),U,2)="Y"
End DoDot:1
+6 QUIT
END ;KILL LOCAL VARIABLES AND END
+1 KILL RATXT,XMZ,XMDUN,XMDUZ,RAIEN,X,Y
+2 QUIT $GET(RANEWPRO)
