Routine: RAMAIN4

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

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)

DEACT ;BLOCK INACTIVATION DATE

 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"

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 23, 2025@18:51:35                                                                                                                                                                                                     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)

RAMAIN4.m