RMPRPCEG ;HCIOFO/RVD - Prosthetics/PCE GET 2319/SET ICD9; 06/28/01
;;3.0;PROSTHETICS;**62**;Feb 09, 1996
;
;
;RMDFN - IEN of the patient.
;returns the IEN of patient transaction from file #660.
G60(RMDFN) ;select the 2319 transaction.
D NEWVAR
S RMDOUT=0
S DIC("A")="Enter Patient Transaction for PCE Entry: "
S DIC("?")="Enter a 2319 transaction where this suspense entry is being closed.."
S DIC="^RMPR(660,",DIC(0)="AEQMN"
S DIC("S")="I ($P(^RMPR(660,+Y,0),U,2)=RMDFN),('$D(^RMPR(660,+Y,10)))"
D ^DIC
I $D(DTOUT)!$D(DUOUT)!$D(DIRUT) S RMDOUT=0 G GETX
S RMDOUT=+Y
S:Y<1 RMDOUT=0
GETX ;exit
Q RMDOUT
;
;RMDFN - IEN of the patient.
;returns the IEN of the Patient Suspense entry from file #668.
G68(RMDFN) ;select the suspense transaction.
D NEWVAR
S RMDOUT=0
AS68 W !
S DIC("A")="Enter Patient Suspense Entry: "
S DIC("?")="Enter a Suspense Entry for the Patient 2319 Record..."
S DIC="^RMPR(668,",DIC(0)="AEQMN"
S DIC("S")="I ($P(^RMPR(668,+Y,0),U,2)=RMDFN),(($P(^(0),U,10)=""O"")!($P(^(0),U,10)=""P"")),($D(^(8))),($P(^(8),U,3)),('$D(^(11)))"
S DIC("W")="S R8=$G(^RMPR(668,+Y,0)),RN=$E($P(^DPT(RMDFN,0),U,1),1,10) W ?38,RN,?50,$P(R8,U,10),"" DESC: "",$G(^RMPR(668,+Y,2,1,0))"
D ^DIC
I $D(DTOUT)!$D(DUOUT)!$D(DIRUT) S RMDOUT=X G G68X
S RMDOUT=+Y
G68X ;exit
Q RMDOUT
;
SETICD ;entry for post init #62
W !!,"Setting ICD9 pointer in file #668:"
S DIE="^RMPR(668,"
F I=0:0 S I=$O(^RMPR(668,I)) Q:I'>0 I $D(^RMPR(668,I,8)) D
.S RMPR8=$G(^RMPR(668,I,8))
.S RI=$P(RMPR8,"^",2)
.Q:$P(RMPR8,"^",3)
.K RIC,RB,RE
.F K=1:1:$L(RI) S RX=$E(RI,K,K) S:RX="(" RB=K S:RX=")" RE=K I $G(RB),$G(RE) S RIC=$E(RI,RB+1,RE-1) Q:RIC>1 K RB,RE
.S RMIECD=""
.I $D(RIC),RIC'="" D
..S RMIECD=$O(^ICD9("BA",RIC,0))
..I '$G(RMIECD) S RMIECD=$O(^ICD9("BA",RIC_" ",0))
.I $G(RMIECD) S DA=I,DR="1.6////^S X=RMIECD" D ^DIE
.W "."
W !!,"DONE setting ICD9 pointer to file #668."
K DIE,DR,DA,RMPR8,I,K,J,RB,RE,RIC,RMIECD,RI,RX
I $D(^RMPR(661.1,3025,0)),$P(^RMPR(661.1,3025,0),U,1)="C1116" S $P(^RMPR(661.1,3025,0),U,8)=1
;update HCPCS to a new CPT Code
W !!,"Updating CPT Codes.."
S DIE="^RMPR(661.1,"
F RI=1:1 Q:$P($T(TAB+RI),";",3)="END" S RD=$T(TAB+RI) D
.S RMHCPC=$P(RD,";",3),RMCPT=$P(RD,";",5)
.S DA=$P(RD,";",4)
.I RMHCPC'=$P(^RMPR(661.1,DA,0),U,1) W !!,"** HCPCS ",RMHCPC," has incorrect IEN in file #661.1, please investigate!!!" Q
.S DR="2///^S X=RMCPT"
.D ^DIE
K DA,DIE,DR,RMHCPC,RMCPT,RI
W !!,"Done Updating CPT Codes!!",!
Q
;
TAB ;list of HCPCS need to be updated.
;;K0280;1389;105120
;;E0240;2051;101067
;;A9010;2429;103242
;;A9040;2524;103356
;;A9070;2525;101873
;;SI102;2806;105228
;;SI103;2807;105357
;;SI213;2836;105126
;;SI302;2848;104713
;;SI303;2849;104713
;;SI304;2850;104713
;;SI305;2851;104713
;;SI306;2852;104713
;;SI405;2859;104713
;;SI516;2881;105799
;;SI517;2882;105800
;;SI518;2883;105799
;;SI519;2884;105357
;;SI199;2902;104713
;;SI299;2903;104713
;;SI399;2904;104713
;;SI499;2905;104713
;;SI599;2906;104713
;;END
;
NEWVAR N DA,DIE,DIC,Y,R8
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRPCEG 3123 printed Apr 09, 2024@21:34:57 Page 2
RMPRPCEG ;HCIOFO/RVD - Prosthetics/PCE GET 2319/SET ICD9; 06/28/01
+1 ;;3.0;PROSTHETICS;**62**;Feb 09, 1996
+2 ;
+3 ;
+4 ;RMDFN - IEN of the patient.
+5 ;returns the IEN of patient transaction from file #660.
G60(RMDFN) ;select the 2319 transaction.
+1 DO NEWVAR
+2 SET RMDOUT=0
+3 SET DIC("A")="Enter Patient Transaction for PCE Entry: "
+4 SET DIC("?")="Enter a 2319 transaction where this suspense entry is being closed.."
+5 SET DIC="^RMPR(660,"
SET DIC(0)="AEQMN"
+6 SET DIC("S")="I ($P(^RMPR(660,+Y,0),U,2)=RMDFN),('$D(^RMPR(660,+Y,10)))"
+7 DO ^DIC
+8 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIRUT)
SET RMDOUT=0
GOTO GETX
+9 SET RMDOUT=+Y
+10 if Y<1
SET RMDOUT=0
GETX ;exit
+1 QUIT RMDOUT
+2 ;
+3 ;RMDFN - IEN of the patient.
+4 ;returns the IEN of the Patient Suspense entry from file #668.
G68(RMDFN) ;select the suspense transaction.
+1 DO NEWVAR
+2 SET RMDOUT=0
AS68 WRITE !
+1 SET DIC("A")="Enter Patient Suspense Entry: "
+2 SET DIC("?")="Enter a Suspense Entry for the Patient 2319 Record..."
+3 SET DIC="^RMPR(668,"
SET DIC(0)="AEQMN"
+4 SET DIC("S")="I ($P(^RMPR(668,+Y,0),U,2)=RMDFN),(($P(^(0),U,10)=""O"")!($P(^(0),U,10)=""P"")),($D(^(8))),($P(^(8),U,3)),('$D(^(11)))"
+5 SET DIC("W")="S R8=$G(^RMPR(668,+Y,0)),RN=$E($P(^DPT(RMDFN,0),U,1),1,10) W ?38,RN,?50,$P(R8,U,10),"" DESC: "",$G(^RMPR(668,+Y,2,1,0))"
+6 DO ^DIC
+7 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIRUT)
SET RMDOUT=X
GOTO G68X
+8 SET RMDOUT=+Y
G68X ;exit
+1 QUIT RMDOUT
+2 ;
SETICD ;entry for post init #62
+1 WRITE !!,"Setting ICD9 pointer in file #668:"
+2 SET DIE="^RMPR(668,"
+3 FOR I=0:0
SET I=$ORDER(^RMPR(668,I))
if I'>0
QUIT
IF $DATA(^RMPR(668,I,8))
Begin DoDot:1
+4 SET RMPR8=$GET(^RMPR(668,I,8))
+5 SET RI=$PIECE(RMPR8,"^",2)
+6 if $PIECE(RMPR8,"^",3)
QUIT
+7 KILL RIC,RB,RE
+8 FOR K=1:1:$LENGTH(RI)
SET RX=$EXTRACT(RI,K,K)
if RX="("
SET RB=K
if RX=")"
SET RE=K
IF $GET(RB)
IF $GET(RE)
SET RIC=$EXTRACT(RI,RB+1,RE-1)
if RIC>1
QUIT
KILL RB,RE
+9 SET RMIECD=""
+10 IF $DATA(RIC)
IF RIC'=""
Begin DoDot:2
+11 SET RMIECD=$ORDER(^ICD9("BA",RIC,0))
+12 IF '$GET(RMIECD)
SET RMIECD=$ORDER(^ICD9("BA",RIC_" ",0))
End DoDot:2
+13 IF $GET(RMIECD)
SET DA=I
SET DR="1.6////^S X=RMIECD"
DO ^DIE
+14 WRITE "."
End DoDot:1
+15 WRITE !!,"DONE setting ICD9 pointer to file #668."
+16 KILL DIE,DR,DA,RMPR8,I,K,J,RB,RE,RIC,RMIECD,RI,RX
+17 IF $DATA(^RMPR(661.1,3025,0))
IF $PIECE(^RMPR(661.1,3025,0),U,1)="C1116"
SET $PIECE(^RMPR(661.1,3025,0),U,8)=1
+18 ;update HCPCS to a new CPT Code
+19 WRITE !!,"Updating CPT Codes.."
+20 SET DIE="^RMPR(661.1,"
+21 FOR RI=1:1
if $PIECE($TEXT(TAB+RI),";",3)="END"
QUIT
SET RD=$TEXT(TAB+RI)
Begin DoDot:1
+22 SET RMHCPC=$PIECE(RD,";",3)
SET RMCPT=$PIECE(RD,";",5)
+23 SET DA=$PIECE(RD,";",4)
+24 IF RMHCPC'=$PIECE(^RMPR(661.1,DA,0),U,1)
WRITE !!,"** HCPCS ",RMHCPC," has incorrect IEN in file #661.1, please investigate!!!"
QUIT
+25 SET DR="2///^S X=RMCPT"
+26 DO ^DIE
End DoDot:1
+27 KILL DA,DIE,DR,RMHCPC,RMCPT,RI
+28 WRITE !!,"Done Updating CPT Codes!!",!
+29 QUIT
+30 ;
TAB ;list of HCPCS need to be updated.
+1 ;;K0280;1389;105120
+2 ;;E0240;2051;101067
+3 ;;A9010;2429;103242
+4 ;;A9040;2524;103356
+5 ;;A9070;2525;101873
+6 ;;SI102;2806;105228
+7 ;;SI103;2807;105357
+8 ;;SI213;2836;105126
+9 ;;SI302;2848;104713
+10 ;;SI303;2849;104713
+11 ;;SI304;2850;104713
+12 ;;SI305;2851;104713
+13 ;;SI306;2852;104713
+14 ;;SI405;2859;104713
+15 ;;SI516;2881;105799
+16 ;;SI517;2882;105800
+17 ;;SI518;2883;105799
+18 ;;SI519;2884;105357
+19 ;;SI199;2902;104713
+20 ;;SI299;2903;104713
+21 ;;SI399;2904;104713
+22 ;;SI499;2905;104713
+23 ;;SI599;2906;104713
+24 ;;END
+25 ;
NEWVAR NEW DA,DIE,DIC,Y,R8
+1 QUIT
