- RANPRO5 ;BPFO/CLT - RADIOLOGY MAPPING TO MRPF ; 27 Oct 2016 4:28 PM
- ;;5.0;Radiology/Nuclear Medicine;**127,138**;Mar 16, 1998;Build 22
- ;
- ; This routine uses the following IA's:
- ; #1995 - CPT calls (supported)
- Q
- EN ;MAIN ENTRY POINT
- N RADA,RAPROIEN,DIE,DIC,DA,DR,X,Y,RACONT,RAMATCH,XC,RANOT,RAX,RACODE,RAFN,RAFAC,DUOUT,DIR
- N DTOUT,DUOUT,DIRUT,DIROUT,RATMP,XC2,RAXTMP,DIWF,DIWL,DIWR,RA99,RAIEN
- S RADA="",RACONT="" K ^XTMP("RANPRO4") S ^XTMP("RAMAIN4",$J,0)=""
- LOOK ;LOOK FOR MAPPABLE PROCEDURES
- S RADA=$P($G(^RAMRPF(71.98,1,0)),U,5) S:$G(RADA)="" RADA=""
- I $P($G(^RAMRPF(71.98,1,0)),U,4)="Y" W !!?3,"Matching has been completed.",!?3,"Do you want to map exceptions?" S DIR(0)="Y",DIR("B")="NO" D ^DIR G:Y=0 END
- F W !! S RACODE="",RATMP="",RADA=$O(^RAMRPF(71.11,"B",RADA)) S:RADA="" $P(^RAMRPF(71.98,1,0),U,4)="Y" Q:RADA="" Q:RACONT["^" D
- . S $P(^RAMRPF(71.98,1,0),U,5)=RADA
- . S RAIEN=$O(^RAMRPF(71.11,"B",RADA,"")) Q:RAIEN="" D Q:$G(DIRUT)=1
- .. I $P(^RAMRPF(71.11,RAIEN,0),U,6)'="D" Q
- .. I $G(^RAMRPF(71.11,RAIEN,"I"))'=""&($G(^RAMRPF(71.11,RAIEN,"I"))<DT) Q
- .. I $P($G(^RAMRPF(71.11,RAIEN,"NTRT")),U,1)'="" Q
- .. ;I $G(^XTMP("RAMAIN4",$J,"RAEND"))=1 Q
- .. K DIR S DIR(0)="71,.01",DIR("A")="LOCAL PROCEDURE NAME",DIR("?")="Enter the procedure name: ",DA=RAIEN D ^DIR
- .. I X="^" S RAX="QUIT",RACONT="^" Q
- .. ;K DIR,DIRUT S DIR(0)="71,9",DIR("?")="Enter the CPT code for this procedure:",DA=RAIEN D ^DIR Q:$G(DIRUT)=1 S RACPT=+Y
- .. I X["^" Q
- .. I $G(RAIEN)="" Q
- .. I $G(Y(0))="NONE LISTED" Q
- .. I $G(RANOT)=X Q
- .. S RACPT=$P($G(^RAMIS(71,RAIEN,0)),"^",9) I RACPT="" Q
- .. S RAMATCH="",DR="900///",RAX=$$MRPF Q:RAX["QUIT"!(RAMATCH="")
- .. S RATMP=$S(RAPROIEN="":"",1:^RAMRPF(71.99,RAPROIEN,0))
- .. S DR=DR_$P(RATMP,U,1)_";903///"_$P(RATMP,U,4) D:$G(^XTMP("RAMAIN4",$J,"RAEND"))=""
- ... S DIE="^RAMRPF(71.11,",DA=RAIEN
- ... Q:$G(X)=""
- ... Q:$G(X)="NONE LISTED"
- ... Q:$G(Y(0))="NONE LISTED"
- ... D ^DIE W !!,"MATCH MADE",! K X,Y Q
- ... ;I $G(X)="NONE LISTED" D MSG
- ... Q
- .. I $G(Y(0))="NONE LISTED" D MSG
- .. K DIR W ! S RACONT="" S DIR(0)="F^1:8",DIR("A")="Hit <RETURN> to continue or '^' to quit.",DIR("B")="Continue" D ^DIR S RACONT=Y
- .. Q
- . Q
- ;G:RACONT="Continue" EN
- G:RACONT["^" END
- G:$D(DUOUT) END
- MRPF ;FIND POSSIBLE MATCHES BY CPT
- MRPF2 ;SECOND ENTRY POINT
- Q:$G(RACPT)="" RAMATCH=""
- N CNT,RAMERR,CNT1,II,A,RACINF
- S RACODE="",RAPROIEN="",(CNT,I,II,CNT1)=0 K XC,XC2,RAMERR
- S:$G(RAPROIEN)="" RAPROIEN=""
- S:$G(RAPROIEN)="" RAPROIEN="" F I=1:1 S RAPROIEN=$O(^RAMRPF(71.99,"C",RACPT,RAPROIEN)) D:'$D(^RAMRPF(71.99,"C",RACPT)) MSG Q:RAPROIEN="" D ACTIVE^RANPROU2 D:$G(RA99)'="INACTIVE"
- . ; RA*5.0*138 change '/' to '~'
- .S:$G(RACODE)="" RACODE="" S RACINF=$$CPT^ICPTCOD(RACPT),RACODE=RACODE_I_":"_$P(^RAMRPF(71.99,RAPROIEN,0),U,1)_"~"_$P(RACINF,"^",3)_";",^XTMP("RAMAIN4",$J,I)=RAPROIEN
- . Q
- K RACINF
- MRPFL ; come here if no entries
- K RAMERR,CNT1,II,A
- ;S RACODE=$G(RACODE)_$S($G(CNT)'="":(CNT+1),1:1)_":NONE LISTED",RANOT=$S($G(CNT)'="":(CNT+1),1:1)
- S RACODE=$G(RACODE)_$S($G(I)'="":I,1:1)_":NONE LISTED",RANOT=$S($G(I)'="":I,1:1)
- Q:$G(RACODE)="" $G(RAMATCH)
- MRPF3 K XC,XC2,CNT ;LOOP POINT
- K DIR,DIE S DIR(0)="S^"_RACODE_"^",DIR("A",1)="Select the number of the Master Procedure that best matches",DIR("A")="or enter a number followed by 'C' for the long name. e.g. 1C"
- S DIR("PRE")="I X["_"""C"""_" S X=+X,XC=1"
- D ^DIR G:$D(DUOUT) MEND G:Y["^"!(X["^") END S RAPLUSY=+Y I $G(XC)=1 D
- . S ^XTMP("RAMAIN4",$J,"C")=$G(RACPT)_U_RACODE_U_$G(RAMATCH)_U_RAPROIEN_U_$G(XC)_U_RANOT_U_RAPLUSY,XC2=1
- . I Y(0)["NONE LISTED" S XC2=XC Q
- . S RAMATCH=$P(RACODE,";",+Y),RAMATCH=$P(RAMATCH,":",2),RAPLUSY=+Y
- . S ^XTMP("RAMAIN4",$J,"C")=$G(RACPT)_U_RACODE_U_RAMATCH_U_RAPROIEN_U_XC_U_RANOT_U_RAPLUSY
- . I $P(^XTMP("RAMAIN4",$J,"C"),U,2)="1:NON LISTED" S XC2=1 Q
- . K ^UTILITY($J,"W") S DIWL=10,DIWR=70,DIWF="WC60"
- . S RAPRO1=^XTMP("RAMAIN4",$J,+Y),RAPLUSY=+Y
- . S X1=0 F S X1=$O(^RAMRPF(71.99,RAPRO1,1,X1)) Q:X1="" D
- .. S X=^RAMRPF(71.99,RAPRO1,1,X1,0) D ^DIWP
- .. Q
- . D ^DIWW
- . W !?3,"Enter <RETURN> to continue:" R X:600 Q
- I $G(XC2)=1 S RAXTMP=^XTMP("RAMAIN4",$J,"C") D
- . S RACPT=$P(RAXTMP,U,1),RACODE=$P(RAXTMP,U,2),RAMATCH=$P(RAXTMP,U,3),RAPROIEN=$P(RAXTMP,U,4),XC=$P(RAXTMP,U,5),RANOT=$P(RAXTMP,U,7),(RAPLUSY,Y)=$P(RAXTMP,U,8) S I=""
- G:$G(XC2)=1 MRPF3 S:$G(Y)'=$G(RANOT) RAMATCH=$P(RACODE,";",RAPLUSY),RAMATCH=$P(RAMATCH,":",2)
- I RACODE'="1:NONE LISTED"&(Y(0)'="NONE LISTED") S:$G(RAPROIEN)="" RAPROIEN=^XTMP("RAMAIN4",$J,+Y)
- I $G(RACODE)["1:NONE LISTED"!($G(Y(0))["NONE LISTED") S RAX="QUIT",RAMATCH="" G MEND
- I $G(RAPROIEN)'="",$D(^RAMIS(71,"MRPF",$S($G(RAPROIEN)'="":RAPROIEN,1:0))) S RAMTCH=2 D:RAMATCH'="" MTCH^RANPROU2 I RAMATCH="QUIT" S RAMV=1 G END
- ; RA*5.0*138 change '/' to '~'
- S:+Y'=RANOT RAMATCH=$P(RAMATCH,"~",1) I $P(RACODE,";",Y)'["NONE LISTED" S RAPROIEN=^XTMP("RAMAIN4",$J,+Y)
- MEND ;GO HERE WHEN AN UPARROW ENTERED ON A DIR
- I $G(RAMATCH)="NONE LISTED" S RAMATCH="" Q
- I $G(RAMATCH)="",$G(Y(0))["NONE LISTED" S RAMATCH="QUIT" Q RAMATCH
- I $G(DUOUT)=1 S RAX="QUIT",RAMATCH="" Q RAMATCH
- S RAMATCH="GO" Q RAMATCH
- END ;END ROUTINE
- K RACPT,RACODE,DIR,D,I,%X,%Y,D0,DI,DQ,DIRUT,DUOUT,XMDUN,XMDUZ,XMZ,^XTMP("RANPRO4"),RALOINC
- K RAPLUSY,RAPRO1,X1,XC,XY,Z,DA,^UTILITY($J,"W")
- K ^XTMP("RAMAIN4",$J),RAMTCH
- Q
- MSG K RACPT,RACODE,DIR,D,I,%X,%Y,D0,DI,DQ,DIRUT,DUOUT
- I $P($G(^RARMPF(71.98,1,0)),U,10)'="Y" G END
- N XMSUB,XMY,XMTEXT,RATXT
- S RAFAC=$$KSP^XUPARAM("INST"),RAFAC=$$NS^XUAF4(RAFAC)
- S RAFN=$P(RAFAC,U,1),RAFAC=$P(RAFAC,U,2),$P(^RAMRPF(71.11,DA,"NTRT"),U,2)="Y"
- S XMSUB="NEW RADIOLOGY PROCEDURE"
- S XMY(DUZ)=""
- S XMY("G.RADIOLOGY NTRT@DOMAIN.EXT")=""
- S XMY("G.NTRT")=""
- 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 RATXT(1)="An existing Radiology procedure at "_RAFN
- S RATXT(2)="does not have a match in the MASTER RADIOLOGY PROCEDURE file"
- S RATXT(3)=" "
- S RATXT(4)="Facility Name/number: "_RAFN_" / "_RAFAC
- S RATXT(5)=" "
- S RATXT(6)="Procedure name: "_RADA
- S RATXT(7)=" "
- S RATXT(8)="CPT code: "_$P($G(^RAMRPF(71.11,DA,0)),U,9)
- S RATXT(9)="Local IEN: "_DA
- S RATXT(10)="For questions or notification respond to: "_"G.RADNTRT@"_$$KSP^XUPARAM("WHERE")
- S RATXT(11)="For NTRT results respond to: "_"S.RADNEWPRO@"_$$KSP^XUPARAM("WHERE")
- S $P(^RAMRPF(71.11,DA,"NTRT"),U,3)=DT
- S XMTEXT="RATXT(" D ^XMD
- S $P(^RAMRPF(71.11,DA,"NTRT"),U,3)=DT
- G END
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRANPRO5 6507 printed Feb 19, 2025@00:03:52 Page 2
- RANPRO5 ;BPFO/CLT - RADIOLOGY MAPPING TO MRPF ; 27 Oct 2016 4:28 PM
- +1 ;;5.0;Radiology/Nuclear Medicine;**127,138**;Mar 16, 1998;Build 22
- +2 ;
- +3 ; This routine uses the following IA's:
- +4 ; #1995 - CPT calls (supported)
- +5 QUIT
- EN ;MAIN ENTRY POINT
- +1 NEW RADA,RAPROIEN,DIE,DIC,DA,DR,X,Y,RACONT,RAMATCH,XC,RANOT,RAX,RACODE,RAFN,RAFAC,DUOUT,DIR
- +2 NEW DTOUT,DUOUT,DIRUT,DIROUT,RATMP,XC2,RAXTMP,DIWF,DIWL,DIWR,RA99,RAIEN
- +3 SET RADA=""
- SET RACONT=""
- KILL ^XTMP("RANPRO4")
- SET ^XTMP("RAMAIN4",$JOB,0)=""
- LOOK ;LOOK FOR MAPPABLE PROCEDURES
- +1 SET RADA=$PIECE($GET(^RAMRPF(71.98,1,0)),U,5)
- if $GET(RADA)=""
- SET RADA=""
- +2 IF $PIECE($GET(^RAMRPF(71.98,1,0)),U,4)="Y"
- WRITE !!?3,"Matching has been completed.",!?3,"Do you want to map exceptions?"
- SET DIR(0)="Y"
- SET DIR("B")="NO"
- DO ^DIR
- if Y=0
- GOTO END
- +3 FOR
- WRITE !!
- SET RACODE=""
- SET RATMP=""
- SET RADA=$ORDER(^RAMRPF(71.11,"B",RADA))
- if RADA=""
- SET $PIECE(^RAMRPF(71.98,1,0),U,4)="Y"
- if RADA=""
- QUIT
- if RACONT["^"
- QUIT
- Begin DoDot:1
- +4 SET $PIECE(^RAMRPF(71.98,1,0),U,5)=RADA
- +5 SET RAIEN=$ORDER(^RAMRPF(71.11,"B",RADA,""))
- if RAIEN=""
- QUIT
- Begin DoDot:2
- +6 IF $PIECE(^RAMRPF(71.11,RAIEN,0),U,6)'="D"
- QUIT
- +7 IF $GET(^RAMRPF(71.11,RAIEN,"I"))'=""&($GET(^RAMRPF(71.11,RAIEN,"I"))<DT)
- QUIT
- +8 IF $PIECE($GET(^RAMRPF(71.11,RAIEN,"NTRT")),U,1)'=""
- QUIT
- +9 ;I $G(^XTMP("RAMAIN4",$J,"RAEND"))=1 Q
- +10 KILL DIR
- SET DIR(0)="71,.01"
- SET DIR("A")="LOCAL PROCEDURE NAME"
- SET DIR("?")="Enter the procedure name: "
- SET DA=RAIEN
- DO ^DIR
- +11 IF X="^"
- SET RAX="QUIT"
- SET RACONT="^"
- QUIT
- +12 ;K DIR,DIRUT S DIR(0)="71,9",DIR("?")="Enter the CPT code for this procedure:",DA=RAIEN D ^DIR Q:$G(DIRUT)=1 S RACPT=+Y
- +13 IF X["^"
- QUIT
- +14 IF $GET(RAIEN)=""
- QUIT
- +15 IF $GET(Y(0))="NONE LISTED"
- QUIT
- +16 IF $GET(RANOT)=X
- QUIT
- +17 SET RACPT=$PIECE($GET(^RAMIS(71,RAIEN,0)),"^",9)
- IF RACPT=""
- QUIT
- +18 SET RAMATCH=""
- SET DR="900///"
- SET RAX=$$MRPF
- if RAX["QUIT"!(RAMATCH="")
- QUIT
- +19 SET RATMP=$SELECT(RAPROIEN="":"",1:^RAMRPF(71.99,RAPROIEN,0))
- +20 SET DR=DR_$PIECE(RATMP,U,1)_";903///"_$PIECE(RATMP,U,4)
- if $GET(^XTMP("RAMAIN4",$JOB,"RAEND"))=""
- Begin DoDot:3
- +21 SET DIE="^RAMRPF(71.11,"
- SET DA=RAIEN
- +22 if $GET(X)=""
- QUIT
- +23 if $GET(X)="NONE LISTED"
- QUIT
- +24 if $GET(Y(0))="NONE LISTED"
- QUIT
- +25 DO ^DIE
- WRITE !!,"MATCH MADE",!
- KILL X,Y
- QUIT
- +26 ;I $G(X)="NONE LISTED" D MSG
- +27 QUIT
- End DoDot:3
- +28 IF $GET(Y(0))="NONE LISTED"
- DO MSG
- +29 KILL DIR
- WRITE !
- SET RACONT=""
- SET DIR(0)="F^1:8"
- SET DIR("A")="Hit <RETURN> to continue or '^' to quit."
- SET DIR("B")="Continue"
- DO ^DIR
- SET RACONT=Y
- +30 QUIT
- End DoDot:2
- if $GET(DIRUT)=1
- QUIT
- +31 QUIT
- End DoDot:1
- +32 ;G:RACONT="Continue" EN
- +33 if RACONT["^"
- GOTO END
- +34 if $DATA(DUOUT)
- GOTO END
- MRPF ;FIND POSSIBLE MATCHES BY CPT
- MRPF2 ;SECOND ENTRY POINT
- +1 if $GET(RACPT)=""
- QUIT RAMATCH=""
- +2 NEW CNT,RAMERR,CNT1,II,A,RACINF
- +3 SET RACODE=""
- SET RAPROIEN=""
- SET (CNT,I,II,CNT1)=0
- KILL XC,XC2,RAMERR
- +4 if $GET(RAPROIEN)=""
- SET RAPROIEN=""
- +5 if $GET(RAPROIEN)=""
- SET RAPROIEN=""
- FOR I=1:1
- SET RAPROIEN=$ORDER(^RAMRPF(71.99,"C",RACPT,RAPROIEN))
- if '$DATA(^RAMRPF(71.99,"C",RACPT))
- DO MSG
- if RAPROIEN=""
- QUIT
- DO ACTIVE^RANPROU2
- if $GET(RA99)'="INACTIVE"
- Begin DoDot:1
- +6 ; RA*5.0*138 change '/' to '~'
- +7 if $GET(RACODE)=""
- SET RACODE=""
- SET RACINF=$$CPT^ICPTCOD(RACPT)
- SET RACODE=RACODE_I_":"_$PIECE(^RAMRPF(71.99,RAPROIEN,0),U,1)_"~"_$PIECE(RACINF,"^",3)_";"
- SET ^XTMP("RAMAIN4",$JOB,I)=RAPROIEN
- +8 QUIT
- End DoDot:1
- +9 KILL RACINF
- MRPFL ; come here if no entries
- +1 KILL RAMERR,CNT1,II,A
- +2 ;S RACODE=$G(RACODE)_$S($G(CNT)'="":(CNT+1),1:1)_":NONE LISTED",RANOT=$S($G(CNT)'="":(CNT+1),1:1)
- +3 SET RACODE=$GET(RACODE)_$SELECT($GET(I)'="":I,1:1)_":NONE LISTED"
- SET RANOT=$SELECT($GET(I)'="":I,1:1)
- +4 if $GET(RACODE)=""
- QUIT $GET(RAMATCH)
- MRPF3 ;LOOP POINT
- KILL XC,XC2,CNT
- +1 KILL DIR,DIE
- SET DIR(0)="S^"_RACODE_"^"
- SET DIR("A",1)="Select the number of the Master Procedure that best matches"
- SET DIR("A")="or enter a number followed by 'C' for the long name. e.g. 1C"
- +2 SET DIR("PRE")="I X["_"""C"""_" S X=+X,XC=1"
- +3 DO ^DIR
- if $DATA(DUOUT)
- GOTO MEND
- if Y["^"!(X["^")
- GOTO END
- SET RAPLUSY=+Y
- IF $GET(XC)=1
- Begin DoDot:1
- +4 SET ^XTMP("RAMAIN4",$JOB,"C")=$GET(RACPT)_U_RACODE_U_$GET(RAMATCH)_U_RAPROIEN_U_$GET(XC)_U_RANOT_U_RAPLUSY
- SET XC2=1
- +5 IF Y(0)["NONE LISTED"
- SET XC2=XC
- QUIT
- +6 SET RAMATCH=$PIECE(RACODE,";",+Y)
- SET RAMATCH=$PIECE(RAMATCH,":",2)
- SET RAPLUSY=+Y
- +7 SET ^XTMP("RAMAIN4",$JOB,"C")=$GET(RACPT)_U_RACODE_U_RAMATCH_U_RAPROIEN_U_XC_U_RANOT_U_RAPLUSY
- +8 IF $PIECE(^XTMP("RAMAIN4",$JOB,"C"),U,2)="1:NON LISTED"
- SET XC2=1
- QUIT
- +9 KILL ^UTILITY($JOB,"W")
- SET DIWL=10
- SET DIWR=70
- SET DIWF="WC60"
- +10 SET RAPRO1=^XTMP("RAMAIN4",$JOB,+Y)
- SET RAPLUSY=+Y
- +11 SET X1=0
- FOR
- SET X1=$ORDER(^RAMRPF(71.99,RAPRO1,1,X1))
- if X1=""
- QUIT
- Begin DoDot:2
- +12 SET X=^RAMRPF(71.99,RAPRO1,1,X1,0)
- DO ^DIWP
- +13 QUIT
- End DoDot:2
- +14 DO ^DIWW
- +15 WRITE !?3,"Enter <RETURN> to continue:"
- READ X:600
- QUIT
- End DoDot:1
- +16 IF $GET(XC2)=1
- SET RAXTMP=^XTMP("RAMAIN4",$JOB,"C")
- Begin DoDot:1
- +17 SET RACPT=$PIECE(RAXTMP,U,1)
- SET RACODE=$PIECE(RAXTMP,U,2)
- SET RAMATCH=$PIECE(RAXTMP,U,3)
- SET RAPROIEN=$PIECE(RAXTMP,U,4)
- SET XC=$PIECE(RAXTMP,U,5)
- SET RANOT=$PIECE(RAXTMP,U,7)
- SET (RAPLUSY,Y)=$PIECE(RAXTMP,U,8)
- SET I=""
- End DoDot:1
- +18 if $GET(XC2)=1
- GOTO MRPF3
- if $GET(Y)'=$GET(RANOT)
- SET RAMATCH=$PIECE(RACODE,";",RAPLUSY)
- SET RAMATCH=$PIECE(RAMATCH,":",2)
- +19 IF RACODE'="1:NONE LISTED"&(Y(0)'="NONE LISTED")
- if $GET(RAPROIEN)=""
- SET RAPROIEN=^XTMP("RAMAIN4",$JOB,+Y)
- +20 IF $GET(RACODE)["1:NONE LISTED"!($GET(Y(0))["NONE LISTED")
- SET RAX="QUIT"
- SET RAMATCH=""
- GOTO MEND
- +21 IF $GET(RAPROIEN)'=""
- IF $DATA(^RAMIS(71,"MRPF",$SELECT($GET(RAPROIEN)'="":RAPROIEN,1:0)))
- SET RAMTCH=2
- if RAMATCH'=""
- DO MTCH^RANPROU2
- IF RAMATCH="QUIT"
- SET RAMV=1
- GOTO END
- +22 ; RA*5.0*138 change '/' to '~'
- +23 if +Y'=RANOT
- SET RAMATCH=$PIECE(RAMATCH,"~",1)
- IF $PIECE(RACODE,";",Y)'["NONE LISTED"
- SET RAPROIEN=^XTMP("RAMAIN4",$JOB,+Y)
- MEND ;GO HERE WHEN AN UPARROW ENTERED ON A DIR
- +1 IF $GET(RAMATCH)="NONE LISTED"
- SET RAMATCH=""
- QUIT
- +2 IF $GET(RAMATCH)=""
- IF $GET(Y(0))["NONE LISTED"
- SET RAMATCH="QUIT"
- QUIT RAMATCH
- +3 IF $GET(DUOUT)=1
- SET RAX="QUIT"
- SET RAMATCH=""
- QUIT RAMATCH
- +4 SET RAMATCH="GO"
- QUIT RAMATCH
- END ;END ROUTINE
- +1 KILL RACPT,RACODE,DIR,D,I,%X,%Y,D0,DI,DQ,DIRUT,DUOUT,XMDUN,XMDUZ,XMZ,^XTMP("RANPRO4"),RALOINC
- +2 KILL RAPLUSY,RAPRO1,X1,XC,XY,Z,DA,^UTILITY($JOB,"W")
- +3 KILL ^XTMP("RAMAIN4",$JOB),RAMTCH
- +4 QUIT
- MSG KILL RACPT,RACODE,DIR,D,I,%X,%Y,D0,DI,DQ,DIRUT,DUOUT
- +1 IF $PIECE($GET(^RARMPF(71.98,1,0)),U,10)'="Y"
- GOTO END
- +2 NEW XMSUB,XMY,XMTEXT,RATXT
- +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(^RAMRPF(71.11,DA,"NTRT"),U,2)="Y"
- +5 SET XMSUB="NEW RADIOLOGY PROCEDURE"
- +6 SET XMY(DUZ)=""
- +7 SET XMY("G.RADIOLOGY NTRT@DOMAIN.EXT")=""
- +8 SET XMY("G.NTRT")=""
- +9 SET XMDUZ("G.RADNTRT")=""
- +10 IF $PIECE($GET(^RAMRPF(71.98,1,0)),U,2)'=""
- SET XMY($PIECE(^RAMRPF(71.98,1,0),U,2))=""
- +11 SET RATXT(1)="An existing Radiology procedure at "_RAFN
- +12 SET RATXT(2)="does not have a match in the MASTER RADIOLOGY PROCEDURE file"
- +13 SET RATXT(3)=" "
- +14 SET RATXT(4)="Facility Name/number: "_RAFN_" / "_RAFAC
- +15 SET RATXT(5)=" "
- +16 SET RATXT(6)="Procedure name: "_RADA
- +17 SET RATXT(7)=" "
- +18 SET RATXT(8)="CPT code: "_$PIECE($GET(^RAMRPF(71.11,DA,0)),U,9)
- +19 SET RATXT(9)="Local IEN: "_DA
- +20 SET RATXT(10)="For questions or notification respond to: "_"G.RADNTRT@"_$$KSP^XUPARAM("WHERE")
- +21 SET RATXT(11)="For NTRT results respond to: "_"S.RADNEWPRO@"_$$KSP^XUPARAM("WHERE")
- +22 SET $PIECE(^RAMRPF(71.11,DA,"NTRT"),U,3)=DT
- +23 SET XMTEXT="RATXT("
- DO ^XMD
- +24 SET $PIECE(^RAMRPF(71.11,DA,"NTRT"),U,3)=DT
- +25 GOTO END
