LEX2044P ; ISL/KER - Pre/Post Install LEX*2.0*44 ; 05/31/2006
;;2.0;LEXICON UTILITY;**44**;Sep 23, 1996;Build 2
;
POST ; Main Entry for LEX*2.0*44
D MES^XPDUTL(" ") D C1,C2,C3,C4,MES^XPDUTL(" ")
Q
;
C1 ; Change #1 - Adjust Activation from 03/15/2006 to 01/01/2006
D DL(" Adjust Activation for 82 HCPCS codes to 01/01/2006")
N CODE
F CODE="G8054","G9050","G9051","G9052","G9053","G9054","G9055","G9056","G9057","G9058","G9059" D U1(CODE)
F CODE="G9060","G9061","G9062","G9063","G9064","G9065","G9066","G9067","G9068","G9069","G9070" D U1(CODE)
F CODE="G9071","G9072","G9073","G9074","G9075","G9076","G9077","G9078","G9079","G9080","G9081" D U1(CODE)
F CODE="G9082","G9083","G9084","G9085","G9086","G9087","G9088","G9089","G9090","G9091","G9092" D U1(CODE)
F CODE="G9093","G9094","G9095","G9096","G9097","G9098","G9099","G9100","G9101","G9102","G9103" D U1(CODE)
F CODE="G9104","G9105","G9106","G9107","G9108","G9109","G9110","G9111","G9112","G9113","G9114" D U1(CODE)
F CODE="G9115","G9116","G9117","G9118","G9119","G9120","G9121","G9122","G9123","G9124","G9125" D U1(CODE)
F CODE="G9126","G9127","G9128","G9129","G9130" D U1(CODE)
Q
U1(CODE) ; Update #1 - Adjust Activation from 03/15/2006 to 01/01/2006
N LEXDA,DA,ND,OD,IENS,FDA,SIEN,IENR,MSG
S CODE=$G(CODE) Q:'$L(CODE) S OD=3060315,ND=3060101
K IENS,FDA S (SIEN,LEXDA,DA)=$$CODEN^ICPTCOD(CODE) Q:+DA'>0 S IENS=$$IENS^DILF(.LEXDA)
S FDA(81,IENS,8)=ND K IENR,MSG D UPDATE^DIE("","FDA","IENR","MSG") S (LEXDA(1),DA(1))=DA
K IENS,FDA S (LEXDA,DA)=$O(^ICPT(+DA(1),60,"B",OD,0)) I DA(1)>0,+DA>0 D
. S IENS=$$IENS^DILF(.LEXDA),FDA(81.02,IENS,.01)=ND K IENR,MSG
. D UPDATE^DIE("","FDA","IENR","MSG")
K IENS,FDA S (LEXDA,DA)=$O(^ICPT(+DA(1),61,"B",OD,0)) I DA(1)>0,+DA>0 D
. S IENS=$$IENS^DILF(.LEXDA),FDA(81.061,IENS,.01)=ND K IENR,MSG
. D UPDATE^DIE("","FDA","IENR","MSG")
K IENS,FDA S (LEXDA,DA)=$O(^ICPT(+DA(1),62,"B",OD,0)) I DA(1)>0,+DA>0 D
. S IENS=$$IENS^DILF(.LEXDA),FDA(81.062,IENS,.01)=ND K IENR,MSG
. D UPDATE^DIE("","FDA","IENR","MSG")
D N0D(SIEN) K LEXDA,DA
K IENS,FDA S SIEN=0 F S SIEN=$O(^LEX(757.02,"CODE",(CODE_" "),SIEN)) Q:+SIEN'>0 D
. S (LEXDA(1),DA(1))=SIEN S DA=0 F S DA=$O(^LEX(757.02,DA(1),4,"B",OD,DA)) Q:+DA'>0 D
. . K IENS,FDA S LEXDA=DA,IENS=$$IENS^DILF(.LEXDA),FDA(757.28,IENS,.01)=ND
. . K IENR,MSG D UPDATE^DIE("","FDA","IENR","MSG")
Q
;
C2 ; Change #2 - Inactivate 93 HCPC Codes
D DL(" Inactivate 90 HCPCS Codes as of 04/02/2006")
N CODE
F CODE="C9117","C9118","C9124","C9125","C9204","C9213","C9214","C9215","C9216","C9217","C9219" D U2(CODE)
F CODE="C9226","C9412","C9712","C9714","C9715","C9717","E1019","E1021","K0548","K0549","K0550" D U2(CODE)
F CODE="K0560","K0561","K0562","K0563","K0564","K0565","K0566","K0567","K0568","K0569","K0570" D U2(CODE)
F CODE="K0571","K0572","K0573","K0574","K0575","K0576","K0577","K0578","K0579","K0580","K0610" D U2(CODE)
F CODE="K0611","K0612","K0613","K0614","K0615","K0616","K0617","K0621","K0622","K0623","K0624" D U2(CODE)
F CODE="K0625","K0626","K0627","K0650","K0651","K0652","K0653","K0654","K0655","K0656","K0657" D U2(CODE)
F CODE="K0658","K0659","K0660","K0661","K0662","K0663","K0664","K0665","K0666","K0667","K0668" D U2(CODE)
F CODE="Q3030","Q4052","Q4053","Q4078","S0112","S0163","S0165","S0193","S2131","S2255","S8002" D U2(CODE)
F CODE="S8003","S8470" D U2(CODE)
Q
U2(CODE) ; Update #2 - Inactivate 93 HCPC Codes
N LEXDA,DA,ND,OD,IENS,FDA,SIEN,LIEN,IENR,MSG,LAYGO S LAYGO=""
S CODE=$G(CODE) Q:'$L(CODE) S OD=3060401,ND=3060402
S (LEXDA,DA,SIEN)=$$CODEN^ICPTCOD(CODE) I +DA>0 D
. S (LEXDA(1),DA(1))=DA,(LEXDA,DA)=+($O(^ICPT(+DA(1),60,"B",OD,0)))+1 S:DA=1 (LEXDA,DA)=$O(^ICPT(+DA(1),60," "),-1)+1
. S IENS=$$IENS^DILF(.LEXDA),IENS="+"_IENS
. N FDA S FDA(81.02,IENS,.01)=ND,FDA(81.02,IENS,.02)=0
. K IENR,MSG D UPDATE^DIE("","FDA","IENR","MSG")
D N0D(SIEN) K LEXDA,DA
S SIEN=0 F S SIEN=$O(^LEX(757.02,"CODE",(CODE_" "),SIEN)) Q:+SIEN'>0 D
. S LIEN=$O(^LEX(757.02,SIEN,4," "),-1)
. I $G(^LEX(757.02,SIEN,4,LIEN,0))=(OD_"^1") D
. . S (LEXDA(1),DA(1))=SIEN,(LEXDA,DA)=LIEN+1,IENS=$$IENS^DILF(.LEXDA),IENS="+"_IENS
. . N FDA S FDA(757.28,IENS,.01)=ND,FDA(757.28,IENS,1)=0
. . K IENR,MSG D UPDATE^DIE("","FDA","IENR","MSG")
Q
;
C3 ; Change #3 - Adjust Activation from 04/03/2006 to 01/01/2001
D DL(" Adjust Activation for 3 HCPCS codes to 01/01/2001")
N CODE F CODE="S0190","S0191","S0199" D U3(CODE)
Q
U3(CODE) ; Update #3 - Adjust Activation from 04/03/2006 to 01/01/2001
N LEXDA,DA,ND,OD,IENS,FDA,SIEN,IENR,MSG S CODE=$G(CODE) Q:'$L(CODE) S OD=3060401,ND=3010101
K IENS,FDA S (SIEN,LEXDA,DA)=$$CODEN^ICPTCOD(CODE) Q:+DA'>0 S (LEXDA(1),DA(1))=DA
K IENS,FDA S (LEXDA,DA)=$O(^ICPT(+DA(1),60,"B",OD,0)) I DA(1)>0,+DA>0 D
. S IENS=$$IENS^DILF(.LEXDA),FDA(81.02,IENS,.01)=ND K IENR,MSG S:+IENS>0 IENS="+"_IENS
. D UPDATE^DIE("","FDA","IENR","MSG")
K IENS,FDA S (LEXDA,DA)=$O(^ICPT(+DA(1),61,"B",OD,0)) I DA(1)>0,+DA>0 D
. S IENS=$$IENS^DILF(.LEXDA),FDA(81.061,IENS,.01)=ND K IENR,MSG S:+IENS>0 IENS="+"_IENS
. D UPDATE^DIE("","FDA","IENR","MSG")
K IENS,FDA S (LEXDA,DA)=$O(^ICPT(+DA(1),62,"B",OD,0)) I DA(1)>0,+DA>0 D
. S IENS=$$IENS^DILF(.LEXDA),FDA(81.062,IENS,.01)=ND K IENR,MSG S:+IENS>0 IENS="+"_IENS
. D UPDATE^DIE("","FDA","IENR","MSG")
D N0D(SIEN) K LEXDA,DA
K IENS,FDA S SIEN=0 F S SIEN=$O(^LEX(757.02,"CODE",(CODE_" "),SIEN)) Q:+SIEN'>0 D
. S (LEXDA(1),DA(1))=SIEN S DA=0 F S DA=$O(^LEX(757.02,DA(1),4,"B",OD,DA)) Q:+DA'>0 D
. . K IENS,FDA S LEXDA=DA,IENS=$$IENS^DILF(.LEXDA),FDA(757.28,IENS,.01)=ND K IENR,MSG S:+IENS>0 IENS="+"_IENS
. . D UPDATE^DIE("","FDA","IENR","MSG")
K LEXDA,DA S (LEXDA,DA)=$$CODEN^ICPTCOD(CODE) Q:+DA'>0 S IENS=$$IENS^DILF(.LEXDA) S FDA(81,IENS,8)=ND K IENR,MSG
D UPDATE^DIE("","FDA","IENR","MSG")
Q
;
C4 ; Change #4 - Reactivate 4 codes 01/02/2006
D DL(" Reactivate 4 HCPCS Codes on 01/02/2006")
N CODE F CODE="E1239","G0252","J7317","J7320" D U4(CODE)
Q
U4(CODE) ; Update #4 - Reactivate 4 codes 01/02/2006
N LEXDA,DA,ND,OD,RD,RT,IENS,FDA,SIEN,LIEN,IENR,MSG,LAYGO S LAYGO=""
S CODE=$G(CODE) Q:'$L(CODE) S OD=3050101,ND=3060102
S (LEXDA,DA,SIEN)=$$CODEN^ICPTCOD(CODE) I +DA>0 D
. N RD,OD,SD,ID,ND,NS S (SD,ID)=""
. S RD=" " F S RD=$O(^ICPT(SIEN,60,"B",RD),-1) Q:+RD'>0 D Q:$L(SD)
. . N RI S RI=1 F S RI=$O(^ICPT(SIEN,60,"B",RD,RI)) Q:+RI'>0 D Q:$L(SD)
. . . S ND=$G(^ICPT(SIEN,60,RI,0)),NS=$P(ND,"^",2),ND=$P(ND,"^",1)
. . . S:+NS'>0 SD=ND
. I +SD>0 S RI=0 F S RI=$O(^ICPT(SIEN,60,RI)) Q:+RI'>0 D
. . S ND=$P($G(^ICPT(SIEN,60,RI,0)),"^",1)
. . I ND=SD!(ND>SD) D
. . . N DA,DIK S DA(1)=SIEN,DA=RI,DIK="^ICPT("_DA(1)_",60,"
. . . D ^DIK
. D N0D(SIEN)
S SIEN=0 F S SIEN=$O(^LEX(757.02,"CODE",(CODE_" "),SIEN)) Q:+SIEN'>0 D
. N RD,OD,SD,ID,ND,NS S (SD,ID)=""
. S RD=" " F S RD=$O(^LEX(757.02,+SIEN,4,"B",RD),-1) Q:+RD'>0 D Q:$L(SD)
. . N RI S RI=1 F S RI=$O(^LEX(757.02,+SIEN,4,"B",RD,RI)) Q:+RI'>0 D Q:$L(SD)
. . . S ND=$G(^LEX(757.02,+SIEN,4,RI,0)),NS=$P(ND,"^",2),ND=$P(ND,"^",1)
. . . S:+NS'>0 SD=ND
. I +SD>0 S RI=0 F S RI=$O(^LEX(757.02,+SIEN,4,RI)) Q:+RI'>0 D
. . S ND=$P($G(^LEX(757.02,+SIEN,4,RI,0)),"^",1)
. . I ND=SD!(ND>SD) D
. . . N DA,DIK S DA(1)=SIEN,DA=RI,DIK="^LEX(757.02,"_DA(1)_",4,"
. . . D ^DIK
Q
N0D(X) ; Node 0 Date
N IEN,DA,DIK,EFF,EFI,STA
S IEN=$G(X),EFF=$O(^ICPT(+IEN,60,"B"," "),-1) Q:+EFF'>0 Q:EFF'?7N S EFI=$O(^ICPT(+IEN,60,"B",EFF,0)) Q:+EFI'>0
S STA=$G(^ICPT(+IEN,60,EFI,0)),EFF=$P(STA,"^",1),STA=$P(STA,"^",2) Q:EFF'?7N Q:STA'?1N
S $P(^ICPT(+IEN,0),"^",7)="",$P(^ICPT(+IEN,0),"^",8)=""
S:+STA=0 $P(^ICPT(+IEN,0),"^",7)=EFF S:+STA=1 $P(^ICPT(+IEN,0),"^",8)=EFF
I EFI>1,STA=0 F S EFI=$O(^ICPT(+IEN,60,EFI),-1) Q:+EFI'>0 Q:$P($G(^ICPT(+IEN,60,+EFI,0)),"^",2)=1
I EFI>0 S EFF=$P($G(^ICPT(+IEN,60,EFI,0)),"^",1) S:EFF?7N $P(^ICPT(+IEN,0),"^",8)=EFF
Q
;
DL(X,I) ; Display Line
S X=$G(X),I=+($G(I)) S:+I'>0 I=1 N SP S SP=$J(" ",I) S X=SP_X D MES^XPDUTL(X)
Q
SC(X) ; Show CPT
N IEN,NN,NC S IEN=+($G(X)) Q:IEN'>0 S NN="^ICPT("_IEN_")",NC="^ICPT("_IEN_","
F S NN=$Q(@NN) Q:NN=""!(NN'[NC) W !,NN,"=",@NN
Q
SL(X) ; Show LEX
N IEN,NN,NC S IEN=+($G(X)) Q:IEN'>0 S NN="^LEX(757.02,"_IEN_")",NC="^LEX(757.02,"_IEN_","
F S NN=$Q(@NN) Q:NN=""!(NN'[NC) W !,NN,"=",@NN
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEX2044P 8454 printed Apr 09, 2024@21:09:50 Page 2
LEX2044P ; ISL/KER - Pre/Post Install LEX*2.0*44 ; 05/31/2006
+1 ;;2.0;LEXICON UTILITY;**44**;Sep 23, 1996;Build 2
+2 ;
POST ; Main Entry for LEX*2.0*44
+1 DO MES^XPDUTL(" ")
DO C1
DO C2
DO C3
DO C4
DO MES^XPDUTL(" ")
+2 QUIT
+3 ;
C1 ; Change #1 - Adjust Activation from 03/15/2006 to 01/01/2006
+1 DO DL(" Adjust Activation for 82 HCPCS codes to 01/01/2006")
+2 NEW CODE
+3 FOR CODE="G8054","G9050","G9051","G9052","G9053","G9054","G9055","G9056","G9057","G9058","G9059"
DO U1(CODE)
+4 FOR CODE="G9060","G9061","G9062","G9063","G9064","G9065","G9066","G9067","G9068","G9069","G9070"
DO U1(CODE)
+5 FOR CODE="G9071","G9072","G9073","G9074","G9075","G9076","G9077","G9078","G9079","G9080","G9081"
DO U1(CODE)
+6 FOR CODE="G9082","G9083","G9084","G9085","G9086","G9087","G9088","G9089","G9090","G9091","G9092"
DO U1(CODE)
+7 FOR CODE="G9093","G9094","G9095","G9096","G9097","G9098","G9099","G9100","G9101","G9102","G9103"
DO U1(CODE)
+8 FOR CODE="G9104","G9105","G9106","G9107","G9108","G9109","G9110","G9111","G9112","G9113","G9114"
DO U1(CODE)
+9 FOR CODE="G9115","G9116","G9117","G9118","G9119","G9120","G9121","G9122","G9123","G9124","G9125"
DO U1(CODE)
+10 FOR CODE="G9126","G9127","G9128","G9129","G9130"
DO U1(CODE)
+11 QUIT
U1(CODE) ; Update #1 - Adjust Activation from 03/15/2006 to 01/01/2006
+1 NEW LEXDA,DA,ND,OD,IENS,FDA,SIEN,IENR,MSG
+2 SET CODE=$GET(CODE)
if '$LENGTH(CODE)
QUIT
SET OD=3060315
SET ND=3060101
+3 KILL IENS,FDA
SET (SIEN,LEXDA,DA)=$$CODEN^ICPTCOD(CODE)
if +DA'>0
QUIT
SET IENS=$$IENS^DILF(.LEXDA)
+4 SET FDA(81,IENS,8)=ND
KILL IENR,MSG
DO UPDATE^DIE("","FDA","IENR","MSG")
SET (LEXDA(1),DA(1))=DA
+5 KILL IENS,FDA
SET (LEXDA,DA)=$ORDER(^ICPT(+DA(1),60,"B",OD,0))
IF DA(1)>0
IF +DA>0
Begin DoDot:1
+6 SET IENS=$$IENS^DILF(.LEXDA)
SET FDA(81.02,IENS,.01)=ND
KILL IENR,MSG
+7 DO UPDATE^DIE("","FDA","IENR","MSG")
End DoDot:1
+8 KILL IENS,FDA
SET (LEXDA,DA)=$ORDER(^ICPT(+DA(1),61,"B",OD,0))
IF DA(1)>0
IF +DA>0
Begin DoDot:1
+9 SET IENS=$$IENS^DILF(.LEXDA)
SET FDA(81.061,IENS,.01)=ND
KILL IENR,MSG
+10 DO UPDATE^DIE("","FDA","IENR","MSG")
End DoDot:1
+11 KILL IENS,FDA
SET (LEXDA,DA)=$ORDER(^ICPT(+DA(1),62,"B",OD,0))
IF DA(1)>0
IF +DA>0
Begin DoDot:1
+12 SET IENS=$$IENS^DILF(.LEXDA)
SET FDA(81.062,IENS,.01)=ND
KILL IENR,MSG
+13 DO UPDATE^DIE("","FDA","IENR","MSG")
End DoDot:1
+14 DO N0D(SIEN)
KILL LEXDA,DA
+15 KILL IENS,FDA
SET SIEN=0
FOR
SET SIEN=$ORDER(^LEX(757.02,"CODE",(CODE_" "),SIEN))
if +SIEN'>0
QUIT
Begin DoDot:1
+16 SET (LEXDA(1),DA(1))=SIEN
SET DA=0
FOR
SET DA=$ORDER(^LEX(757.02,DA(1),4,"B",OD,DA))
if +DA'>0
QUIT
Begin DoDot:2
+17 KILL IENS,FDA
SET LEXDA=DA
SET IENS=$$IENS^DILF(.LEXDA)
SET FDA(757.28,IENS,.01)=ND
+18 KILL IENR,MSG
DO UPDATE^DIE("","FDA","IENR","MSG")
End DoDot:2
End DoDot:1
+19 QUIT
+20 ;
C2 ; Change #2 - Inactivate 93 HCPC Codes
+1 DO DL(" Inactivate 90 HCPCS Codes as of 04/02/2006")
+2 NEW CODE
+3 FOR CODE="C9117","C9118","C9124","C9125","C9204","C9213","C9214","C9215","C9216","C9217","C9219"
DO U2(CODE)
+4 FOR CODE="C9226","C9412","C9712","C9714","C9715","C9717","E1019","E1021","K0548","K0549","K0550"
DO U2(CODE)
+5 FOR CODE="K0560","K0561","K0562","K0563","K0564","K0565","K0566","K0567","K0568","K0569","K0570"
DO U2(CODE)
+6 FOR CODE="K0571","K0572","K0573","K0574","K0575","K0576","K0577","K0578","K0579","K0580","K0610"
DO U2(CODE)
+7 FOR CODE="K0611","K0612","K0613","K0614","K0615","K0616","K0617","K0621","K0622","K0623","K0624"
DO U2(CODE)
+8 FOR CODE="K0625","K0626","K0627","K0650","K0651","K0652","K0653","K0654","K0655","K0656","K0657"
DO U2(CODE)
+9 FOR CODE="K0658","K0659","K0660","K0661","K0662","K0663","K0664","K0665","K0666","K0667","K0668"
DO U2(CODE)
+10 FOR CODE="Q3030","Q4052","Q4053","Q4078","S0112","S0163","S0165","S0193","S2131","S2255","S8002"
DO U2(CODE)
+11 FOR CODE="S8003","S8470"
DO U2(CODE)
+12 QUIT
U2(CODE) ; Update #2 - Inactivate 93 HCPC Codes
+1 NEW LEXDA,DA,ND,OD,IENS,FDA,SIEN,LIEN,IENR,MSG,LAYGO
SET LAYGO=""
+2 SET CODE=$GET(CODE)
if '$LENGTH(CODE)
QUIT
SET OD=3060401
SET ND=3060402
+3 SET (LEXDA,DA,SIEN)=$$CODEN^ICPTCOD(CODE)
IF +DA>0
Begin DoDot:1
+4 SET (LEXDA(1),DA(1))=DA
SET (LEXDA,DA)=+($ORDER(^ICPT(+DA(1),60,"B",OD,0)))+1
if DA=1
SET (LEXDA,DA)=$ORDER(^ICPT(+DA(1),60," "),-1)+1
+5 SET IENS=$$IENS^DILF(.LEXDA)
SET IENS="+"_IENS
+6 NEW FDA
SET FDA(81.02,IENS,.01)=ND
SET FDA(81.02,IENS,.02)=0
+7 KILL IENR,MSG
DO UPDATE^DIE("","FDA","IENR","MSG")
End DoDot:1
+8 DO N0D(SIEN)
KILL LEXDA,DA
+9 SET SIEN=0
FOR
SET SIEN=$ORDER(^LEX(757.02,"CODE",(CODE_" "),SIEN))
if +SIEN'>0
QUIT
Begin DoDot:1
+10 SET LIEN=$ORDER(^LEX(757.02,SIEN,4," "),-1)
+11 IF $GET(^LEX(757.02,SIEN,4,LIEN,0))=(OD_"^1")
Begin DoDot:2
+12 SET (LEXDA(1),DA(1))=SIEN
SET (LEXDA,DA)=LIEN+1
SET IENS=$$IENS^DILF(.LEXDA)
SET IENS="+"_IENS
+13 NEW FDA
SET FDA(757.28,IENS,.01)=ND
SET FDA(757.28,IENS,1)=0
+14 KILL IENR,MSG
DO UPDATE^DIE("","FDA","IENR","MSG")
End DoDot:2
End DoDot:1
+15 QUIT
+16 ;
C3 ; Change #3 - Adjust Activation from 04/03/2006 to 01/01/2001
+1 DO DL(" Adjust Activation for 3 HCPCS codes to 01/01/2001")
+2 NEW CODE
FOR CODE="S0190","S0191","S0199"
DO U3(CODE)
+3 QUIT
U3(CODE) ; Update #3 - Adjust Activation from 04/03/2006 to 01/01/2001
+1 NEW LEXDA,DA,ND,OD,IENS,FDA,SIEN,IENR,MSG
SET CODE=$GET(CODE)
if '$LENGTH(CODE)
QUIT
SET OD=3060401
SET ND=3010101
+2 KILL IENS,FDA
SET (SIEN,LEXDA,DA)=$$CODEN^ICPTCOD(CODE)
if +DA'>0
QUIT
SET (LEXDA(1),DA(1))=DA
+3 KILL IENS,FDA
SET (LEXDA,DA)=$ORDER(^ICPT(+DA(1),60,"B",OD,0))
IF DA(1)>0
IF +DA>0
Begin DoDot:1
+4 SET IENS=$$IENS^DILF(.LEXDA)
SET FDA(81.02,IENS,.01)=ND
KILL IENR,MSG
if +IENS>0
SET IENS="+"_IENS
+5 DO UPDATE^DIE("","FDA","IENR","MSG")
End DoDot:1
+6 KILL IENS,FDA
SET (LEXDA,DA)=$ORDER(^ICPT(+DA(1),61,"B",OD,0))
IF DA(1)>0
IF +DA>0
Begin DoDot:1
+7 SET IENS=$$IENS^DILF(.LEXDA)
SET FDA(81.061,IENS,.01)=ND
KILL IENR,MSG
if +IENS>0
SET IENS="+"_IENS
+8 DO UPDATE^DIE("","FDA","IENR","MSG")
End DoDot:1
+9 KILL IENS,FDA
SET (LEXDA,DA)=$ORDER(^ICPT(+DA(1),62,"B",OD,0))
IF DA(1)>0
IF +DA>0
Begin DoDot:1
+10 SET IENS=$$IENS^DILF(.LEXDA)
SET FDA(81.062,IENS,.01)=ND
KILL IENR,MSG
if +IENS>0
SET IENS="+"_IENS
+11 DO UPDATE^DIE("","FDA","IENR","MSG")
End DoDot:1
+12 DO N0D(SIEN)
KILL LEXDA,DA
+13 KILL IENS,FDA
SET SIEN=0
FOR
SET SIEN=$ORDER(^LEX(757.02,"CODE",(CODE_" "),SIEN))
if +SIEN'>0
QUIT
Begin DoDot:1
+14 SET (LEXDA(1),DA(1))=SIEN
SET DA=0
FOR
SET DA=$ORDER(^LEX(757.02,DA(1),4,"B",OD,DA))
if +DA'>0
QUIT
Begin DoDot:2
+15 KILL IENS,FDA
SET LEXDA=DA
SET IENS=$$IENS^DILF(.LEXDA)
SET FDA(757.28,IENS,.01)=ND
KILL IENR,MSG
if +IENS>0
SET IENS="+"_IENS
+16 DO UPDATE^DIE("","FDA","IENR","MSG")
End DoDot:2
End DoDot:1
+17 KILL LEXDA,DA
SET (LEXDA,DA)=$$CODEN^ICPTCOD(CODE)
if +DA'>0
QUIT
SET IENS=$$IENS^DILF(.LEXDA)
SET FDA(81,IENS,8)=ND
KILL IENR,MSG
+18 DO UPDATE^DIE("","FDA","IENR","MSG")
+19 QUIT
+20 ;
C4 ; Change #4 - Reactivate 4 codes 01/02/2006
+1 DO DL(" Reactivate 4 HCPCS Codes on 01/02/2006")
+2 NEW CODE
FOR CODE="E1239","G0252","J7317","J7320"
DO U4(CODE)
+3 QUIT
U4(CODE) ; Update #4 - Reactivate 4 codes 01/02/2006
+1 NEW LEXDA,DA,ND,OD,RD,RT,IENS,FDA,SIEN,LIEN,IENR,MSG,LAYGO
SET LAYGO=""
+2 SET CODE=$GET(CODE)
if '$LENGTH(CODE)
QUIT
SET OD=3050101
SET ND=3060102
+3 SET (LEXDA,DA,SIEN)=$$CODEN^ICPTCOD(CODE)
IF +DA>0
Begin DoDot:1
+4 NEW RD,OD,SD,ID,ND,NS
SET (SD,ID)=""
+5 SET RD=" "
FOR
SET RD=$ORDER(^ICPT(SIEN,60,"B",RD),-1)
if +RD'>0
QUIT
Begin DoDot:2
+6 NEW RI
SET RI=1
FOR
SET RI=$ORDER(^ICPT(SIEN,60,"B",RD,RI))
if +RI'>0
QUIT
Begin DoDot:3
+7 SET ND=$GET(^ICPT(SIEN,60,RI,0))
SET NS=$PIECE(ND,"^",2)
SET ND=$PIECE(ND,"^",1)
+8 if +NS'>0
SET SD=ND
End DoDot:3
if $LENGTH(SD)
QUIT
End DoDot:2
if $LENGTH(SD)
QUIT
+9 IF +SD>0
SET RI=0
FOR
SET RI=$ORDER(^ICPT(SIEN,60,RI))
if +RI'>0
QUIT
Begin DoDot:2
+10 SET ND=$PIECE($GET(^ICPT(SIEN,60,RI,0)),"^",1)
+11 IF ND=SD!(ND>SD)
Begin DoDot:3
+12 NEW DA,DIK
SET DA(1)=SIEN
SET DA=RI
SET DIK="^ICPT("_DA(1)_",60,"
+13 DO ^DIK
End DoDot:3
End DoDot:2
+14 DO N0D(SIEN)
End DoDot:1
+15 SET SIEN=0
FOR
SET SIEN=$ORDER(^LEX(757.02,"CODE",(CODE_" "),SIEN))
if +SIEN'>0
QUIT
Begin DoDot:1
+16 NEW RD,OD,SD,ID,ND,NS
SET (SD,ID)=""
+17 SET RD=" "
FOR
SET RD=$ORDER(^LEX(757.02,+SIEN,4,"B",RD),-1)
if +RD'>0
QUIT
Begin DoDot:2
+18 NEW RI
SET RI=1
FOR
SET RI=$ORDER(^LEX(757.02,+SIEN,4,"B",RD,RI))
if +RI'>0
QUIT
Begin DoDot:3
+19 SET ND=$GET(^LEX(757.02,+SIEN,4,RI,0))
SET NS=$PIECE(ND,"^",2)
SET ND=$PIECE(ND,"^",1)
+20 if +NS'>0
SET SD=ND
End DoDot:3
if $LENGTH(SD)
QUIT
End DoDot:2
if $LENGTH(SD)
QUIT
+21 IF +SD>0
SET RI=0
FOR
SET RI=$ORDER(^LEX(757.02,+SIEN,4,RI))
if +RI'>0
QUIT
Begin DoDot:2
+22 SET ND=$PIECE($GET(^LEX(757.02,+SIEN,4,RI,0)),"^",1)
+23 IF ND=SD!(ND>SD)
Begin DoDot:3
+24 NEW DA,DIK
SET DA(1)=SIEN
SET DA=RI
SET DIK="^LEX(757.02,"_DA(1)_",4,"
+25 DO ^DIK
End DoDot:3
End DoDot:2
End DoDot:1
+26 QUIT
N0D(X) ; Node 0 Date
+1 NEW IEN,DA,DIK,EFF,EFI,STA
+2 SET IEN=$GET(X)
SET EFF=$ORDER(^ICPT(+IEN,60,"B"," "),-1)
if +EFF'>0
QUIT
if EFF'?7N
QUIT
SET EFI=$ORDER(^ICPT(+IEN,60,"B",EFF,0))
if +EFI'>0
QUIT
+3 SET STA=$GET(^ICPT(+IEN,60,EFI,0))
SET EFF=$PIECE(STA,"^",1)
SET STA=$PIECE(STA,"^",2)
if EFF'?7N
QUIT
if STA'?1N
QUIT
+4 SET $PIECE(^ICPT(+IEN,0),"^",7)=""
SET $PIECE(^ICPT(+IEN,0),"^",8)=""
+5 if +STA=0
SET $PIECE(^ICPT(+IEN,0),"^",7)=EFF
if +STA=1
SET $PIECE(^ICPT(+IEN,0),"^",8)=EFF
+6 IF EFI>1
IF STA=0
FOR
SET EFI=$ORDER(^ICPT(+IEN,60,EFI),-1)
if +EFI'>0
QUIT
if $PIECE($GET(^ICPT(+IEN,60,+EFI,0)),"^",2)=1
QUIT
+7 IF EFI>0
SET EFF=$PIECE($GET(^ICPT(+IEN,60,EFI,0)),"^",1)
if EFF?7N
SET $PIECE(^ICPT(+IEN,0),"^",8)=EFF
+8 QUIT
+9 ;
DL(X,I) ; Display Line
+1 SET X=$GET(X)
SET I=+($GET(I))
if +I'>0
SET I=1
NEW SP
SET SP=$JUSTIFY(" ",I)
SET X=SP_X
DO MES^XPDUTL(X)
+2 QUIT
SC(X) ; Show CPT
+1 NEW IEN,NN,NC
SET IEN=+($GET(X))
if IEN'>0
QUIT
SET NN="^ICPT("_IEN_")"
SET NC="^ICPT("_IEN_","
+2 FOR
SET NN=$QUERY(@NN)
if NN=""!(NN'[NC)
QUIT
WRITE !,NN,"=",@NN
+3 QUIT
SL(X) ; Show LEX
+1 NEW IEN,NN,NC
SET IEN=+($GET(X))
if IEN'>0
QUIT
SET NN="^LEX(757.02,"_IEN_")"
SET NC="^LEX(757.02,"_IEN_","
+2 FOR
SET NN=$QUERY(@NN)
if NN=""!(NN'[NC)
QUIT
WRITE !,NN,"=",@NN
+3 QUIT
