- 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 Feb 18, 2025@23:30:12 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