- ADECD46 ; IHS/SET/HMW - ADA CODE TABLE UPDATE (CDT4) ;
- ;;6.0;ADE;**14**;MAR 25, 1999
- S U="^"
- ;
- ADA ;
- ;
- N ADEFILE,ADEWPFLD,ADEIENST,ADECNT,ADEDONE,ADEMOD,ADERN,ADEDONE,ADERTN
- N ADERLN,ADEID,ADECODE,ADEDESC,ADEUSE,ADETXT,ADELEV,ADESYN,ADEMNE,ADENOP
- N ADEMIN,ADEICD9,ADEFDA,ADEEMSG
- S ADEFILE=9999999.31,ADEWPFLD=1101,ADEIENST="?+1,",ADECNT=0,ADEDONE=0,ADEMOD=0
- ;Copy ^AUTTADA to ^ADEOCD46 to backup ADA Codes before the update
- I '$D(^ADEOCD46) S %X="^AUTTADA(",%Y="^ADEOCD46(" D %XY^%RCR K %X,%Y
- S DIK="^AUTTADA(" D IXALL^DIK K DIK
- ;Update ADA codes
- F ADERN=1,2 D ADA1(ADERN) Q:ADEDONE
- D ADAUPD
- Q
- ;
- ADA1(ADERN) ;
- S ADERTN="ADECD47"_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,ADEMIN,ADEICD9,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=$P(X,U,2) 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
- ADECD46 ; IHS/SET/HMW - ADA CODE TABLE UPDATE (CDT4) ;
- +1 ;;6.0;ADE;**14**;MAR 25, 1999
- +2 SET U="^"
- +3 ;
- ADA ;
- +1 ;
- +2 NEW ADEFILE,ADEWPFLD,ADEIENST,ADECNT,ADEDONE,ADEMOD,ADERN,ADEDONE,ADERTN
- +3 NEW ADERLN,ADEID,ADECODE,ADEDESC,ADEUSE,ADETXT,ADELEV,ADESYN,ADEMNE,ADENOP
- +4 NEW ADEMIN,ADEICD9,ADEFDA,ADEEMSG
- +5 SET ADEFILE=9999999.31
- SET ADEWPFLD=1101
- SET ADEIENST="?+1,"
- SET ADECNT=0
- SET ADEDONE=0
- SET ADEMOD=0
- +6 ;Copy ^AUTTADA to ^ADEOCD46 to backup ADA Codes before the update
- +7 IF '$DATA(^ADEOCD46)
- SET %X="^AUTTADA("
- SET %Y="^ADEOCD46("
- DO %XY^%RCR
- KILL %X,%Y
- +8 SET DIK="^AUTTADA("
- DO IXALL^DIK
- KILL DIK
- +9 ;Update ADA codes
- +10 FOR ADERN=1,2
- DO ADA1(ADERN)
- IF ADEDONE
- QUIT
- +11 DO ADAUPD
- +12 QUIT
- +13 ;
- ADA1(ADERN) ;
- +1 SET ADERTN="ADECD47"_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,ADEMIN,ADEICD9,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=$PIECE(X,U,2)
- 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
