- ADECD4 ; IHS/SET/HMW - ADA CODE TABLE UPDATE (CDT4) ;
- ;;6.0;ADE;**12**;MAR 25, 1999
- S U="^"
- D ADA
- D ^ADECD44 ;ADA CODE EDIT GROUPS
- D ^ADECD45 ;DENTAL EDITS
- Q
- ;
- ADA ;
- ;
- S ADEFILE=9999999.31,ADEWPFLD=1101,ADEIENST="?+1,",ADECNT=0,ADEDONE=0,ADEMOD=0
- ;Copy ^AUTTADA to ^ADEOCD4 to backup ADA Codes before the update
- I '$D(^ADEOCD4) S %X="^AUTTADA(",%Y="^ADEOCD4(" D %XY^%RCR K %X,%Y
- S DIK="^AUTTADA(" D IXALL^DIK K DIK
- ;Update ADA codes with CDT4 Update
- F ADERN=1:1:3 D ADA1(ADERN) Q:ADEDONE
- D ADAUPD
- ;Deactivated Codes
- D NOW^%DTC S ADETDT=X
- F ADEADA="0501","2110","2120","2130","2131","2336","2337","2380","2381","2382","2385" D DEACT(ADEADA)
- F ADEADA="2386","2387","2388","4220","6519","6520","6530","6543","6544","7110","7120" D DEACT(ADEADA)
- F ADEADA="7130","7420","7430","7431","7480" D DEACT(ADEADA)
- D KILL
- Q
- ;
- DEACT(ADEADA) ;Deactivate Code
- S DIC=ADEFILE,DIC(0)="X",X=ADEADA
- D ^DIC
- I Y>0 D
- . S DIE=ADEFILE,DA=+Y,DR=".08////"_ADETDT
- . D ^DIE
- . Q
- Q
- ;
- ADA1(ADERN) ;
- S ADERTN="ADECD4"_ADERN
- F ADERLN=4:1 S X=$T(+ADERLN^@ADERTN) Q:X="" D Q:ADEDONE
- .S X=$P(X,";",3,$L(X,";")) Q:X=""
- .S ADEID=$P(X,U) I ADEID="***END***" S ADEDONE=1 Q
- .I ADEID="CODE" D:ADECNT ADAUPD S ADECODE=$P(X,U,2),ADEDESC=$P(X,U,3),ADECNT=ADECNT+1,ADEUSE=0,ADETXT=0,(ADELEV,ADESYN,ADEMNE,ADENOP)=""
- .I ADEID="SVC" D Q
- . . S ADELEV=$P(X,U,2),ADEMIN=$P(X,U,3),ADEICD9=$P(X,U,4)
- . . Q:ADEICD9=""
- . . S ADEICD9=+$O(^ICD9("AB",ADEICD9,0))
- . . S:'+ADEICD9 ADEICD9=""
- . . Q
- .I ADEID="SYN" S ADESYN=$P(X,U,2) Q
- .I ADEID="MNE" S ADEMNE=$P(X,U,2) Q
- .I ADEID="NOP" S ADENOP="n" Q
- .I ADEID="USE" S ADEUSE=1 Q
- .I ADEUSE S ADETXT=ADETXT+1,ADETEXT(ADETXT)=X Q
- I X="",ADERLN=4,$T(+ADERLN^@ADERTN)="" S ADEDONE=1
- Q
- ;
- ADAUPD ;
- S ADEMOD=0,ADEIENST="?+1,"
- I $D(^AUTTADA("B",ADECODE)) S ADEIENST=+$O(^AUTTADA("B",ADECODE,0))_",",ADEMOD=1
- S ADEFDA(ADEFILE,ADEIENST,.01)=ADECODE,ADEFDA(ADEFILE,ADEIENST,.02)=ADEDESC
- S:ADEICD9'="" ADEFDA(ADEFILE,ADEIENST,.03)=ADEICD9
- S:ADEMIN'="" ADEFDA(ADEFILE,ADEIENST,.04)=ADEMIN
- S:ADELEV'="" ADEFDA(ADEFILE,ADEIENST,.05)=ADELEV
- S:ADESYN'="" ADEFDA(ADEFILE,ADEIENST,.06)=ADESYN
- S:ADENOP'="" ADEFDA(ADEFILE,ADEIENST,.09)=ADENOP
- S:ADEMNE'="" ADEFDA(ADEFILE,ADEIENST,8801)=ADEMNE
- S ADEFDA(ADEFILE,ADEIENST,.08)="@" ;Inactivation date
- D UPDATE
- Q
- ;
- UPDATE ;
- I ADEMOD=0 D
- . D UPDATE^DIE(,"ADEFDA","ADEIEN","ADEEMSG")
- . K ADEFDA,ADEEMSG
- I ADEMOD=1 D
- . D FILE^DIE(,"ADEFDA","ADEEMSG")
- . S ADEIEN(1)=+ADEIENST
- . K ADEFDA,ADEEMSG
- I ADETXT,ADETXT>1!(ADETEXT(1)'="") D WP^DIE(ADEFILE,ADEIEN(1)_",",ADEWPFLD,,"ADETEXT","ADEEMSG")
- K ADETEXT,ADEEMSG,ADEIEN
- Q
- KILL ;
- K ADEADA,ADECNT,ADECODE,ADEDESC,ADEDONE,ADEFDA,ADEFILE,ADEICD9,ADEID,ADEIENST,ADELEV,ADEMIN,ADEMNE,ADEMOD,ADERLN,ADERN,ADERTN,ADESYN,ADETDT,ADETEXT,ADETXT,ADEUSE,ADEWPFLD,ADENOP,DA,DIC,DIE,DR,X
- Q
- ADECD4 ; IHS/SET/HMW - ADA CODE TABLE UPDATE (CDT4) ;
- +1 ;;6.0;ADE;**12**;MAR 25, 1999
- +2 SET U="^"
- +3 DO ADA
- +4 ;ADA CODE EDIT GROUPS
- DO ^ADECD44
- +5 ;DENTAL EDITS
- DO ^ADECD45
- +6 QUIT
- +7 ;
- ADA ;
- +1 ;
- +2 SET ADEFILE=9999999.31
- SET ADEWPFLD=1101
- SET ADEIENST="?+1,"
- SET ADECNT=0
- SET ADEDONE=0
- SET ADEMOD=0
- +3 ;Copy ^AUTTADA to ^ADEOCD4 to backup ADA Codes before the update
- +4 IF '$DATA(^ADEOCD4)
- SET %X="^AUTTADA("
- SET %Y="^ADEOCD4("
- DO %XY^%RCR
- KILL %X,%Y
- +5 SET DIK="^AUTTADA("
- DO IXALL^DIK
- KILL DIK
- +6 ;Update ADA codes with CDT4 Update
- +7 FOR ADERN=1:1:3
- DO ADA1(ADERN)
- IF ADEDONE
- QUIT
- +8 DO ADAUPD
- +9 ;Deactivated Codes
- +10 DO NOW^%DTC
- SET ADETDT=X
- +11 FOR ADEADA="0501","2110","2120","2130","2131","2336","2337","2380","2381","2382","2385"
- DO DEACT(ADEADA)
- +12 FOR ADEADA="2386","2387","2388","4220","6519","6520","6530","6543","6544","7110","7120"
- DO DEACT(ADEADA)
- +13 FOR ADEADA="7130","7420","7430","7431","7480"
- DO DEACT(ADEADA)
- +14 DO KILL
- +15 QUIT
- +16 ;
- DEACT(ADEADA) ;Deactivate Code
- +1 SET DIC=ADEFILE
- SET DIC(0)="X"
- SET X=ADEADA
- +2 DO ^DIC
- +3 IF Y>0
- Begin DoDot:1
- +4 SET DIE=ADEFILE
- SET DA=+Y
- SET DR=".08////"_ADETDT
- +5 DO ^DIE
- +6 QUIT
- End DoDot:1
- +7 QUIT
- +8 ;
- ADA1(ADERN) ;
- +1 SET ADERTN="ADECD4"_ADERN
- +2 FOR ADERLN=4:1
- SET X=$TEXT(+ADERLN^@ADERTN)
- IF X=""
- QUIT
- Begin DoDot:1
- +3 SET X=$PIECE(X,";",3,$LENGTH(X,";"))
- IF X=""
- QUIT
- +4 SET ADEID=$PIECE(X,U)
- IF ADEID="***END***"
- SET ADEDONE=1
- QUIT
- +5 IF ADEID="CODE"
- IF ADECNT
- DO ADAUPD
- SET ADECODE=$PIECE(X,U,2)
- SET ADEDESC=$PIECE(X,U,3)
- SET ADECNT=ADECNT+1
- SET ADEUSE=0
- SET ADETXT=0
- SET (ADELEV,ADESYN,ADEMNE,ADENOP)=""
- +6 IF ADEID="SVC"
- Begin DoDot:2
- +7 SET ADELEV=$PIECE(X,U,2)
- SET ADEMIN=$PIECE(X,U,3)
- SET ADEICD9=$PIECE(X,U,4)
- +8 IF ADEICD9=""
- QUIT
- +9 SET ADEICD9=+$ORDER(^ICD9("AB",ADEICD9,0))
- +10 IF '+ADEICD9
- SET ADEICD9=""
- +11 QUIT
- End DoDot:2
- QUIT
- +12 IF ADEID="SYN"
- SET ADESYN=$PIECE(X,U,2)
- QUIT
- +13 IF ADEID="MNE"
- SET ADEMNE=$PIECE(X,U,2)
- QUIT
- +14 IF ADEID="NOP"
- SET ADENOP="n"
- QUIT
- +15 IF ADEID="USE"
- SET ADEUSE=1
- QUIT
- +16 IF ADEUSE
- SET ADETXT=ADETXT+1
- SET ADETEXT(ADETXT)=X
- QUIT
- End DoDot:1
- IF ADEDONE
- QUIT
- +17 IF X=""
- IF ADERLN=4
- IF $TEXT(+ADERLN^@ADERTN)=""
- SET ADEDONE=1
- +18 QUIT
- +19 ;
- ADAUPD ;
- +1 SET ADEMOD=0
- SET ADEIENST="?+1,"
- +2 IF $DATA(^AUTTADA("B",ADECODE))
- SET ADEIENST=+$ORDER(^AUTTADA("B",ADECODE,0))_","
- SET ADEMOD=1
- +3 SET ADEFDA(ADEFILE,ADEIENST,.01)=ADECODE
- SET ADEFDA(ADEFILE,ADEIENST,.02)=ADEDESC
- +4 IF ADEICD9'=""
- SET ADEFDA(ADEFILE,ADEIENST,.03)=ADEICD9
- +5 IF ADEMIN'=""
- SET ADEFDA(ADEFILE,ADEIENST,.04)=ADEMIN
- +6 IF ADELEV'=""
- SET ADEFDA(ADEFILE,ADEIENST,.05)=ADELEV
- +7 IF ADESYN'=""
- SET ADEFDA(ADEFILE,ADEIENST,.06)=ADESYN
- +8 IF ADENOP'=""
- SET ADEFDA(ADEFILE,ADEIENST,.09)=ADENOP
- +9 IF ADEMNE'=""
- SET ADEFDA(ADEFILE,ADEIENST,8801)=ADEMNE
- +10 ;Inactivation date
- SET ADEFDA(ADEFILE,ADEIENST,.08)="@"
- +11 DO UPDATE
- +12 QUIT
- +13 ;
- UPDATE ;
- +1 IF ADEMOD=0
- Begin DoDot:1
- +2 DO UPDATE^DIE(,"ADEFDA","ADEIEN","ADEEMSG")
- +3 KILL ADEFDA,ADEEMSG
- End DoDot:1
- +4 IF ADEMOD=1
- Begin DoDot:1
- +5 DO FILE^DIE(,"ADEFDA","ADEEMSG")
- +6 SET ADEIEN(1)=+ADEIENST
- +7 KILL ADEFDA,ADEEMSG
- End DoDot:1
- +8 IF ADETXT
- IF ADETXT>1!(ADETEXT(1)'="")
- DO WP^DIE(ADEFILE,ADEIEN(1)_",",ADEWPFLD,,"ADETEXT","ADEEMSG")
- +9 KILL ADETEXT,ADEEMSG,ADEIEN
- +10 QUIT
- KILL ;
- +1 KILL ADEADA,ADECNT,ADECODE,ADEDESC,ADEDONE,ADEFDA,ADEFILE,ADEICD9,ADEID,ADEIENST,ADELEV,ADEMIN,ADEMNE,ADEMOD,ADERLN,ADERN,ADERTN,ADESYN,ADETDT,ADETEXT,ADETXT,ADEUSE,ADEWPFLD,ADENOP,DA,DIC,DIE,DR,X
- +2 QUIT
