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

RAMAIN5.m

Go to the documentation of this file.
RAMAIN5 ;BPFO/CLT - RADIOLOGY MAPPING TO MRPF ; 28 Oct 2016  3:08 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
 ; RA*5.0*138 added RAMAIN5I usage
 N RADA,RAIEN,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,RAWALK,RAMAIN5I
 S RADA="",RACONT="" K ^XTMP("RAMAIN4") 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="" S:$G(RAWALK)="" RAWALK=""
 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(^RAMIS(71,"B",RADA)) S:RADA="" $P(^RAMRPF(71.98,1,0),U,4)="Y" Q:RADA=""!(RACONT["^")!($G(RAX)="QUIT"&($G(RAWALK)=1))  D
 . S $P(^RAMRPF(71.98,1,0),U,5)=RADA
 . S RAIEN=$O(^RAMIS(71,"B",RADA,"")) Q:RAIEN=""  D  Q:$G(DIRUT)=1
 .. I $P(^RAMIS(71,RAIEN,0),U,6)'="D" Q
 .. I $G(^RAMIS(71,RAIEN,"I"))'=""&($G(^RAMIS(71,RAIEN,"I"))<DT) Q
 .. I $P($G(^RAMIS(71,RAIEN,"NTRT")),U,1)'="" Q
 .. ;I $G(^XTMP("RAMAIN4",$J,"RAEND"))=1 Q
 .. W !!,"PROCEDURE NAME: ",$P(^RAMIS(71,RAIEN,0),U,1)
 .. W !,"CPT CODE: ",$P(^RAMIS(71,RAIEN,0),U,9) S RACPT=$P(^RAMIS(71,RAIEN,0),U,9)
 .. ; RA*5.0*138 added RAMAIN51
 .. S RAMATCH="",DR="900///",RAWALK=1,RAMAIN5I=1
 .. S 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="^RAMIS(71,",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
 ... Q
 .. ; RA*5.0*138 added RAMAIN5I check
 .. I $G(Y(0))="NONE LISTED" D:$G(RAMAIN5I)'=1 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
 I RACONT["^" K RAWALK G END
 I $D(DUOUT) K RAWALK G END
MRPF() ;FIND POSSIBLE MATCHES BY CPT
MRPF2 ;SECOND ENTRY POINT
 N RACINF
 Q:$G(RACPT)="" RAMATCH=""
 S RACODE="",RAPROIEN="",I=0 K XC,XC2
 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^RAUTL23 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
 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  ;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="",RAWALK=0 G MEND
 I $G(RAPROIEN)'="",$D(^RAMIS(71,"MRPF",$S($G(RAPROIEN)'="":RAPROIEN,1:0))) S RAMTCH=2 D:RAMATCH'="GO" MTCH^RAUTL23
 ; 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
 ;W !!,X," ",$G(DUOUT,999)," ",$G(RAMATCH,9999)
 I $D(DUOUT) S RAX="QUIT",RAMATCH="" Q RAX
 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("RAMAIN4"),RALOINC
 K RAPLUSY,RAPRO1,X1,XC,XY,Z,DA,^UTILITY($J,"W"),RAMAIN5I
 K ^XTMP("RAMAIN4",$J),RAMATCH,RAMTCH
 Q
MSG K RACPT,RACODE,DIR,D,I,%X,%Y,D0,DI,DQ,DIRUT,DUOUT
 ; RA*5.0*138 added RAMAIN5I check
 I $G(RAMAIN5I)=1 G END
 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(^RAMIS(71,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(^RAMIS(71,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(^RAMIS(71,DA,"NTRT"),U,3)=DT
 S XMTEXT="RATXT(" D ^XMD
 S $P(^RAMIS(71,DA,"NTRT"),U,3)=DT
 G END