AUMUPD4 ;IHS/OIT/NKD - SCB UPDATE 05/23/2012 ;
;;12.0;TABLE MAINTENANCE;**3**;SEP 27,2011;Build 1
;
ADDOK ;----- "ADDED" MESSAGE
D RSLT($J("",5)_"ADDED : "_L)
Q
;
ADDFAIL ;----- "FAILED" MESSAGE
D RSLT($J("",5)_$$M(0)_"ADD FAILED => "_L)
Q
;
DASH ;----- PRT DASH LINE
D RSLT("")
D RSLT($$REPEAT^XLFSTR("-",$S($G(IOM):IOM-10,1:70)))
D RSLT("")
Q
;
DIE ;----- DIE EDIT
N @($P($T(SVARS),";",3))
L +(@(DIE_DA_")")):10
E D RSLT($J("",5)_$$M(0)_"Entry '"_DIE_DA_"' IS LOCKED. NOTIFY PROGRAMMER.") S Y=1 Q
D ^DIE
L -(@(DIE_DA_")"))
Q
;
DIK ;--- KILL ENTRY
N @($P($T(SVARS),";",3)),DIK
D ^DIK
Q
;
FILE ;--- FILE NEW ENTRY
N @($P($T(SVARS),";",3))
K DD,DO
S DIC(0)="L"
D FILE^DICN
K DIC,DLAYGO
Q
;
M(%) ;--- ERROR MESSAGE
Q $S(%=0:"ERROR : ",%=1:"NOT ADDED : ",1:"")
;
MODOK ;--- IF MOD OK
D RSLT($J("",5)_"CHANGED : "_L)
Q
;
INAOK ;--- IF INACTIVATE OK
D RSLT($J("",5)_"INACTIVATED : "_L)
Q
;
DINAOK ;--- IF DUPLICATE INACTIVATE OK
D RSLT($J("",2)_"LOCAL DUPLICATE INACTIVATED : "_L)
Q
;
RSLT(%) ;--- ISSUE MESSAGES DURING INSTALL
N @($P($T(SVARS),";",3))
D MES^XPDUTL(%)
Q
;
IXDIC(DIC,DIC0,D,X,DLAYGO) ;
;--- CALL TO FILEMAN IX^DIC
N @($P($T(SVARS),";",3))
S DIC(0)=DIC0
K DIC0
I '$G(DLAYGO) K DLAYGO
D IX^DIC
Q Y
;
PCLASALL ;EP --- PROVIDER TABLE UPDATE
N C,CI,A,S,I,II,L,N,NI,AUMI,AUMII
S C=$O(^DIC(7,"D","")),A="" ;TRAVERSE THE D INDEX (CODE)
F Q:$L(C)<1 D
.S I=$O(^DIC(7,"D",C,"")) ;STORE THE IEN
.;ITERATE THROUGH MASTER RETRIEVING CODES
.F Q:$L(I)<1 D
..N S
..;IF THE LOCAL CODE MATCHES, UPDATE THE LOCAL ENTRY AND REMOVE FROM THE MASTER
..F AUMII=1:1:$P(AUMPRV(0),"^",4) I $D(AUMPRV(AUMII,0)) S CI=$P(AUMPRV(AUMII,0),"^",1) Q:$D(S) D
...I CI=C D RSLT("SERVICES RENDERED BY (PROVIDER) CODE CHANGES"),PCLASDIE S S="" K AUMPRV(AUMII,0)
..I '$D(S) S A=A_I_"^" ;IF NOT FOUND IN THE MASTER, STORE IEN IN LOCAL VARIABLE
..S I=$O(^DIC(7,"D",C,I)) ;ITERATE TO THE NEXT IEN WITH THIS CODE
.S C=$O(^DIC(7,"D",C)) ;TRAVERSE TO THE NEXT CODE
;ITERATE THROUGH THE STORED IENs
F AUMI=1:1 S I=$P(A,"^",AUMI) Q:$L(I)<1 D
.N S
.S N=$P(^DIC(7,I,0),"^",1) ;STORE THE NAME
.;ITERATE THROUGH MASTER RETRIEVING NAMES
.F AUMII=1:1:$P(AUMPRV(0),"^",4) I $D(AUMPRV(AUMII,0)) S NI=$P(AUMPRV(AUMII,0),"^",2) Q:$D(S) D
..;IF THE LOCAL NAME MATCHES, UPDATE THE LOCAL ENTRY AND REMOVE FROM THE MASTER
..I NI=N D RSLT("SERVICES RENDERED BY (PROVIDER) NAME CHANGES"),PCLASDIE S S="" K AUMPRV(AUMII,0)
.;IF NOT FOUND, INACTIVATE LOCAL ENTRY
.I '$D(S) D
..D RSLT("SERVICES RENDERED BY (PROVIDER) INACTIVATE")
..S L=$P(^DIC(7,I,9999999),"^",1)_" "_N_" "_$P(^DIC(7,I,9999999),"^",2)
..S DIE="^DIC(7,",DA=I,DR="9999999.06///"_DT D ^DIE
..I $D(Y) D RSLT($J("",5)_$$M(0)_"INACTIVATE PROVIDER CODE FAILED => "_L) Q
..D RSLT($J("",5)_"INACTIVATED : "_L)
;ITERATE THROUGH REMAINING MASTER ENTRIES AND ADD
F AUMI=1:1:$P(AUMPRV(0),"^",4) I $D(AUMPRV(AUMI,0)) D
.D RSLT("SERVICES RENDERED BY (PROVIDER) ADD")
.S C=$P(AUMPRV(AUMI,0),"^",1),N=$P(AUMPRV(AUMI,0),"^",2),A=$P(AUMPRV(AUMI,0),"^",3),P=$P(AUMPRV(AUMI,0),"^",4),R=$P(AUMPRV(AUMI,0),"^",5)
.S L=C_" "_N_$J("",(32-$L(N)))_A
.I $D(^DIC(7,"D",C)) D RSLT($J("",5)_$$M(1)_"PROVIDER CODE EXISTS => "_C),RSLT("") Q
.S DLAYGO=7,DIC="^DIC(7,",X=N,DIC("DR")="1///"_A_";9999999.01///"_C_";9999999.03///"_P_";9999999.05///"_R
.D FILE
.D @$S(Y>0:"ADDOK",1:"ADDFAIL")
.K AUMPRV(AUMI,0)
Q
PCLASDIE ;
N C,N,A,P,R,L,DIE,DA,DR
S C=$P(AUMPRV(AUMII,0),"^",1),N=$P(AUMPRV(AUMII,0),"^",2),A=$P(AUMPRV(AUMII,0),"^",3),P=$P(AUMPRV(AUMII,0),"^",4),R=$P(AUMPRV(AUMII,0),"^",5)
S L=C_" "_N_" "_A
S DIE="^DIC(7,",DA=I,DR=".01///"_N_";1///"_A_";9999999.01///"_C_";9999999.03///"_P_";9999999.05///"_R
I $L($P(AUMPRV(AUMII,0),"^",6))>0 S DR=DR_";9999999.06///"_$P(AUMPRV(AUMII,0),"^",6)
D ^DIE
I $D(Y) D RSLT($J("",5)_$$M(0)_"EDIT PROVIDER CODE FAILED => "_L) Q
D MODOK
Q
EDTMOD ;EP - update education topics
N AUMACT,AUMNAM,AUMMNE,AUMMJT,AUMOUTC,AUMSTD,AUMRES,FDA,NEWIEN,ERR,I,AUMCHG,AUMD0,AUMCNT,AUMIEN
I '$D(EDTC) D RSLT("PATIENT EDUCATION TOPICS") S EDTC=""
S AUMCHG=0,U="^",AUMIEN="",AUMACT=$P(L,U,1)
S AUMNAM=$$CLEAN($P(L,U,2)),AUMMNE=$$CLEAN($P(L,U,3)),AUMMJT=$$CLEAN($P(L,U,4)),AUMOUTC=$P(L,U,5),AUMSTD=$P(L,U,6)
S L=AUMMNE_$J("",13-$L(AUMMNE))_AUMNAM_$J("",51-$L(AUMNAM))_AUMMJT
K AUMRES
D FIND^DIC(9999999.09,"","@;.01;1;.06","PX",AUMNAM,,"B",,,"AUMRES")
S AUMCNT=$P($G(AUMRES("DILIST",0)),"^",1)
I AUMCNT=0 S AUMIEN="" ; No matches found, create new
I AUMCNT=1 S AUMIEN=$P($G(AUMRES("DILIST",1,0)),"^",1) ; One match found, store IEN
I AUMCNT>1 S AUMIEN=$P($G(AUMRES("DILIST",$P($G(AUMRES("DILIST",0)),"^",1),0)),"^",1)
I 'AUMIEN D
. K AUMRES
. D FIND^DIC(9999999.09,"","@;.01;1;.06","PX",AUMMNE,,"C","I ($P(^(0),U,3)'=1),($P(^(0),U)=$$UP^XLFSTR($P(^(0),U)))",,"AUMRES") ;
. S AUMCNT=$P($G(AUMRES("DILIST",0)),"^",1)
. I AUMCNT=0 S AUMIEN="" ; No matches found, create new
. I AUMCNT=1 S AUMIEN=$P($G(AUMRES("DILIST",1,0)),"^",1) ; One match found, store IEN
. I AUMCNT>1 S AUMIEN=$P($G(AUMRES("DILIST",$P($G(AUMRES("DILIST",0)),"^",1),0)),"^",1)
;
I 'AUMIEN,$L(AUMACT)>0 D Q
. D RSLT($J("",5)_"INACTIVATE TOPIC FAILED : TOPIC DOES NOT EXIST => "_L)
I 'AUMIEN D
. K FDA,NEWIEN,ERR
. S FDA(9999999.09,"+1,",.01)=AUMNAM ; Name (.01)
. S FDA(9999999.09,"+1,",1)=AUMMNE ; Mnemonic (1)
. D UPDATE^DIE(,"FDA","NEWIEN","ERR")
. I $D(ERR) D ADDFAIL Q
. S AUMIEN=NEWIEN(1),AUMCHG=1
Q:'AUMIEN
S AUMD0=$G(^AUTTEDT(AUMIEN,0))
;
K FDA
S FDA(9999999.09,AUMIEN_",",.01)=AUMNAM ; Name (.01)
S FDA(9999999.09,AUMIEN_",",1)=AUMMNE ; Mnemonic (1)
S FDA(9999999.09,AUMIEN_",",.06)=AUMMJT ; Major Topic (.06)
S FDA(9999999.09,AUMIEN_",",.03)=$S($L(AUMACT)>0:1,1:"@") ; Inactive Flag (.03)
D UPDATE^DIE(,"FDA",)
I AUMD0'=$G(^AUTTEDT(AUMIEN,0)) S AUMCHG=1
;
; Outcome (1101) WP
D TEXT(.AUMOUTC) ; convert string to WP array
D WP^DIE(9999999.09,AUMIEN_",",1101,,"AUMOUTC")
;
; Standards (1102) WP
D TEXT(.AUMSTD) ; convert string to WP array
D WP^DIE(9999999.09,AUMIEN_",",1102,,"AUMSTD")
;
I AUMCHG D @$S($D(NEWIEN):"ADDOK",$L(AUMACT)>0:"INAOK",1:"MODOK")
;
K AUMRES,FDA
D FIND^DIC(9999999.09,"","@;.01;1;.06","PX",AUMNAM,,"B","I ($P(^(0),U,3)'=1),(Y'=AUMIEN)",,"AUMRES")
S AUMCNT=$P($G(AUMRES("DILIST",0)),"^",1)
I AUMCNT>0 D RSLT("DUPLICATE NAMES FOUND FOR : "_AUMMNE_$J("",13-$L(AUMMNE))_AUMNAM)
F I=1:1:AUMCNT D
. N L
. S L=$P(AUMRES("DILIST",I,0),"^",3)_$J("",13-$L($P(AUMRES("DILIST",I,0),"^",3)))_$P(AUMRES("DILIST",I,0),"^",2)
. S FDA(9999999.09,$P(AUMRES("DILIST",I,0),"^",1)_",",.03)="1" ; Inactive Flag (.03)
. D DINAOK
I AUMCNT D UPDATE^DIE(,"FDA",)
;
K AUMRES,FDA
D FIND^DIC(9999999.09,"","@;.01;1;.06","PX",AUMMNE,,"C","I ($P(^(0),U,3)'=1),(Y'=AUMIEN)",,"AUMRES")
S AUMCNT=$P($G(AUMRES("DILIST",0)),"^",1)
I AUMCNT>0 D RSLT("DUPLICATE MNEMONICS FOUND FOR : "_AUMMNE_$J("",13-$L(AUMMNE))_AUMNAM)
F I=1:1:AUMCNT D
. N L
. S L=$P(AUMRES("DILIST",I,0),"^",3)_$J("",13-$L($P(AUMRES("DILIST",I,0),"^",3)))_$P(AUMRES("DILIST",I,0),"^",2)
. S FDA(9999999.09,$P(AUMRES("DILIST",I,0),"^",1)_",",.03)="1" ; Inactive Flag (.03)
. D DINAOK
I AUMCNT D UPDATE^DIE(,"FDA",)
;
Q
MJTMOD ;EP - update major education topics
N AUMNAM,AUMMNE,AUMRES,FDA,NEWIEN,ERR,AUMCHG,AUMD0,AUMCNT,AUMIEN
I '$D(MJTC) D RSLT("PATIENT EDUCATION MAJOR TOPICS") S MJTC=""
S AUMCHG=0,U="^",AUMIEN=""
S AUMNAM=$$CLEAN($P(L,U,1)),AUMMNE=$$CLEAN($E($P(L,U,2),1,4))
S L=AUMMNE_$J("",7-$L(AUMMNE))_AUMNAM
K AUMRES
D FIND^DIC(99999.91,"","@;.01;.02","PX",AUMMNE,,"B",,,"AUMRES")
S AUMCNT=$P($G(AUMRES("DILIST",0)),"^",1)
I AUMCNT=0 S AUMIEN="" ; No matches found, create new
I AUMCNT=1 S AUMIEN=$P($G(AUMRES("DILIST",1,0)),"^",1) ; One match found, store IEN
I AUMCNT>1 S AUMIEN=$P($G(AUMRES("DILIST",$P($G(AUMRES("DILIST",0)),"^",1),0)),"^",1)
I 'AUMIEN D
. K FDA,NEWIEN,ERR
. S FDA(99999.91,"+1,",.01)=AUMNAM ; Name (.01)
. S FDA(99999.91,"+1,",.02)=AUMMNE ; Abbreviation (.02)
. D UPDATE^DIE(,"FDA","NEWIEN","ERR")
. I $D(ERR) D ADDFAIL Q
. S AUMIEN=NEWIEN(1),AUMCHG=1
Q:'AUMIEN
S AUMD0=$G(^AUTTEDMT(AUMIEN,0))
;
K FDA
S FDA(99999.91,AUMIEN_",",.01)=AUMNAM ; Name (.01)
S FDA(99999.91,AUMIEN_",",.02)=AUMMNE ; Abbreviation (.02)
D UPDATE^DIE(,"FDA",)
I AUMD0'=$G(^AUTTEDMT(AUMIEN,0)) S AUMCHG=1
;
I AUMCHG D @$S($D(NEWIEN):"ADDOK",1:"MODOK")
Q
CLEAN(X) ;
N CNT,AUMSTR
S AUMSTR=X
S CNT=0 F S CNT=$F(X," -") Q:'CNT S $E(X,CNT-2,CNT-1)="-"
S CNT=0 F S CNT=$F(X,"- ") Q:'CNT S $E(X,CNT-2,CNT-1)="-"
S CNT=0 F S CNT=$F(X," ") Q:'CNT S $E(X,CNT-2,CNT-1)=" "
I $E(X,1)=" " S X=$E(X,2,$L(X))
I $E(X,$L(X))=" " S X=$E(X,1,$L(X)-1)
Q X
TEXT(X) ;
N AUMSTR,I,J
S AUMSTR=X,I=1,J=1
K X
F I=1:1:$L(AUMSTR,"|") D
. Q:$L($P(AUMSTR,"|",I))=0
. S X(J)=$P(AUMSTR,"|",I),J=J+1
Q
SVARS ;;A,C,E,F,L,M,N,O,P,R,S,T,V;Single-character work variables
Q
PKLST ;EP - Check to see what EHR pick lists might be affected
D RSLT("DISPLAYING EHR PICKLISTS CONTAINING INACTIVE EDUCATION TOPICS")
N PKNAM,PK1,PK2,PK3,PXEDT,AUMDSP
S PKNAM="",PK1=0
F S PK1=$O(^BGOEDTPR(PK1)) Q:PK1'?1N.N D
.S AUMDSP=1
.S PK2="" F S PK2=$O(^BGOEDTPR(PK1,PK2)) Q:PK2'?1N.N D
..S:PK2=0 PKNAM=$P(^BGOEDTPR(PK1,PK2),U,1)
..S PK3=0 F S PK3=$O(^BGOEDTPR(PK1,PK2,PK3)) Q:PK3'?1N.N D
...S PXEDT=$P($G(^BGOEDTPR(PK1,PK2,PK3,0)),U,1)
...Q:PXEDT=""
...Q:$P($G(^AUTTEDT(PXEDT,0)),U,3)'=1
...N AUMMNE,AUMNAM,AUMINA
...S AUMMNE=$P(^AUTTEDT(PXEDT,0),"^",2),AUMNAM=$P(^AUTTEDT(PXEDT,0),"^",1),AUMINA=$$FMTE^XLFDT($P(^AUTTEDT(PXEDT,0),"^",5))
...I AUMDSP D RSLT(""),RSLT("INACTIVE TOPIC(S) FOUND IN EHR PICKLIST: "_$P(^BGOEDTPR(PK1,0),"^",1)) S AUMDSP=0
...D RSLT($J("",4)_AUMMNE_$J("",13-$L(AUMMNE))_"'"_AUMNAM_"'"_$J("",51-$L(AUMNAM))_AUMINA)
...Q
..Q
.Q
Q
AUMUPD4 ;IHS/OIT/NKD - SCB UPDATE 05/23/2012 ;
+1 ;;12.0;TABLE MAINTENANCE;**3**;SEP 27,2011;Build 1
+2 ;
ADDOK ;----- "ADDED" MESSAGE
+1 DO RSLT($JUSTIFY("",5)_"ADDED : "_L)
+2 QUIT
+3 ;
ADDFAIL ;----- "FAILED" MESSAGE
+1 DO RSLT($JUSTIFY("",5)_$$M(0)_"ADD FAILED => "_L)
+2 QUIT
+3 ;
DASH ;----- PRT DASH LINE
+1 DO RSLT("")
+2 DO RSLT($$REPEAT^XLFSTR("-",$SELECT($GET(IOM):IOM-10,1:70)))
+3 DO RSLT("")
+4 QUIT
+5 ;
DIE ;----- DIE EDIT
+1 NEW @($PIECE($TEXT(SVARS),";",3))
+2 LOCK +(@(DIE_DA_")")):10
+3 IF '$TEST
DO RSLT($JUSTIFY("",5)_$$M(0)_"Entry '"_DIE_DA_"' IS LOCKED. NOTIFY PROGRAMMER.")
SET Y=1
QUIT
+4 DO ^DIE
+5 LOCK -(@(DIE_DA_")"))
+6 QUIT
+7 ;
DIK ;--- KILL ENTRY
+1 NEW @($PIECE($TEXT(SVARS),";",3)),DIK
+2 DO ^DIK
+3 QUIT
+4 ;
FILE ;--- FILE NEW ENTRY
+1 NEW @($PIECE($TEXT(SVARS),";",3))
+2 KILL DD,DO
+3 SET DIC(0)="L"
+4 DO FILE^DICN
+5 KILL DIC,DLAYGO
+6 QUIT
+7 ;
M(%) ;--- ERROR MESSAGE
+1 QUIT $SELECT(%=0:"ERROR : ",%=1:"NOT ADDED : ",1:"")
+2 ;
MODOK ;--- IF MOD OK
+1 DO RSLT($JUSTIFY("",5)_"CHANGED : "_L)
+2 QUIT
+3 ;
INAOK ;--- IF INACTIVATE OK
+1 DO RSLT($JUSTIFY("",5)_"INACTIVATED : "_L)
+2 QUIT
+3 ;
DINAOK ;--- IF DUPLICATE INACTIVATE OK
+1 DO RSLT($JUSTIFY("",2)_"LOCAL DUPLICATE INACTIVATED : "_L)
+2 QUIT
+3 ;
RSLT(%) ;--- ISSUE MESSAGES DURING INSTALL
+1 NEW @($PIECE($TEXT(SVARS),";",3))
+2 DO MES^XPDUTL(%)
+3 QUIT
+4 ;
IXDIC(DIC,DIC0,D,X,DLAYGO) ;
+1 ;--- CALL TO FILEMAN IX^DIC
+2 NEW @($PIECE($TEXT(SVARS),";",3))
+3 SET DIC(0)=DIC0
+4 KILL DIC0
+5 IF '$GET(DLAYGO)
KILL DLAYGO
+6 DO IX^DIC
+7 QUIT Y
+8 ;
PCLASALL ;EP --- PROVIDER TABLE UPDATE
+1 NEW C,CI,A,S,I,II,L,N,NI,AUMI,AUMII
+2 ;TRAVERSE THE D INDEX (CODE)
SET C=$ORDER(^DIC(7,"D",""))
SET A=""
+3 FOR
IF $LENGTH(C)<1
QUIT
Begin DoDot:1
+4 ;STORE THE IEN
SET I=$ORDER(^DIC(7,"D",C,""))
+5 ;ITERATE THROUGH MASTER RETRIEVING CODES
+6 FOR
IF $LENGTH(I)<1
QUIT
Begin DoDot:2
+7 NEW S
+8 ;IF THE LOCAL CODE MATCHES, UPDATE THE LOCAL ENTRY AND REMOVE FROM THE MASTER
+9 FOR AUMII=1:1:$PIECE(AUMPRV(0),"^",4)
IF $DATA(AUMPRV(AUMII,0))
SET CI=$PIECE(AUMPRV(AUMII,0),"^",1)
IF $DATA(S)
QUIT
Begin DoDot:3
+10 IF CI=C
DO RSLT("SERVICES RENDERED BY (PROVIDER) CODE CHANGES")
DO PCLASDIE
SET S=""
KILL AUMPRV(AUMII,0)
End DoDot:3
+11 ;IF NOT FOUND IN THE MASTER, STORE IEN IN LOCAL VARIABLE
IF '$DATA(S)
SET A=A_I_"^"
+12 ;ITERATE TO THE NEXT IEN WITH THIS CODE
SET I=$ORDER(^DIC(7,"D",C,I))
End DoDot:2
+13 ;TRAVERSE TO THE NEXT CODE
SET C=$ORDER(^DIC(7,"D",C))
End DoDot:1
+14 ;ITERATE THROUGH THE STORED IENs
+15 FOR AUMI=1:1
SET I=$PIECE(A,"^",AUMI)
IF $LENGTH(I)<1
QUIT
Begin DoDot:1
+16 NEW S
+17 ;STORE THE NAME
SET N=$PIECE(^DIC(7,I,0),"^",1)
+18 ;ITERATE THROUGH MASTER RETRIEVING NAMES
+19 FOR AUMII=1:1:$PIECE(AUMPRV(0),"^",4)
IF $DATA(AUMPRV(AUMII,0))
SET NI=$PIECE(AUMPRV(AUMII,0),"^",2)
IF $DATA(S)
QUIT
Begin DoDot:2
+20 ;IF THE LOCAL NAME MATCHES, UPDATE THE LOCAL ENTRY AND REMOVE FROM THE MASTER
+21 IF NI=N
DO RSLT("SERVICES RENDERED BY (PROVIDER) NAME CHANGES")
DO PCLASDIE
SET S=""
KILL AUMPRV(AUMII,0)
End DoDot:2
+22 ;IF NOT FOUND, INACTIVATE LOCAL ENTRY
+23 IF '$DATA(S)
Begin DoDot:2
+24 DO RSLT("SERVICES RENDERED BY (PROVIDER) INACTIVATE")
+25 SET L=$PIECE(^DIC(7,I,9999999),"^",1)_" "_N_" "_$PIECE(^DIC(7,I,9999999),"^",2)
+26 SET DIE="^DIC(7,"
SET DA=I
SET DR="9999999.06///"_DT
DO ^DIE
+27 IF $DATA(Y)
DO RSLT($JUSTIFY("",5)_$$M(0)_"INACTIVATE PROVIDER CODE FAILED => "_L)
QUIT
+28 DO RSLT($JUSTIFY("",5)_"INACTIVATED : "_L)
End DoDot:2
End DoDot:1
+29 ;ITERATE THROUGH REMAINING MASTER ENTRIES AND ADD
+30 FOR AUMI=1:1:$PIECE(AUMPRV(0),"^",4)
IF $DATA(AUMPRV(AUMI,0))
Begin DoDot:1
+31 DO RSLT("SERVICES RENDERED BY (PROVIDER) ADD")
+32 SET C=$PIECE(AUMPRV(AUMI,0),"^",1)
SET N=$PIECE(AUMPRV(AUMI,0),"^",2)
SET A=$PIECE(AUMPRV(AUMI,0),"^",3)
SET P=$PIECE(AUMPRV(AUMI,0),"^",4)
SET R=$PIECE(AUMPRV(AUMI,0),"^",5)
+33 SET L=C_" "_N_$JUSTIFY("",(32-$LENGTH(N)))_A
+34 IF $DATA(^DIC(7,"D",C))
DO RSLT($JUSTIFY("",5)_$$M(1)_"PROVIDER CODE EXISTS => "_C)
DO RSLT("")
QUIT
+35 SET DLAYGO=7
SET DIC="^DIC(7,"
SET X=N
SET DIC("DR")="1///"_A_";9999999.01///"_C_";9999999.03///"_P_";9999999.05///"_R
+36 DO FILE
+37 DO @$SELECT(Y>0:"ADDOK",1:"ADDFAIL")
+38 KILL AUMPRV(AUMI,0)
End DoDot:1
+39 QUIT
PCLASDIE ;
+1 NEW C,N,A,P,R,L,DIE,DA,DR
+2 SET C=$PIECE(AUMPRV(AUMII,0),"^",1)
SET N=$PIECE(AUMPRV(AUMII,0),"^",2)
SET A=$PIECE(AUMPRV(AUMII,0),"^",3)
SET P=$PIECE(AUMPRV(AUMII,0),"^",4)
SET R=$PIECE(AUMPRV(AUMII,0),"^",5)
+3 SET L=C_" "_N_" "_A
+4 SET DIE="^DIC(7,"
SET DA=I
SET DR=".01///"_N_";1///"_A_";9999999.01///"_C_";9999999.03///"_P_";9999999.05///"_R
+5 IF $LENGTH($PIECE(AUMPRV(AUMII,0),"^",6))>0
SET DR=DR_";9999999.06///"_$PIECE(AUMPRV(AUMII,0),"^",6)
+6 DO ^DIE
+7 IF $DATA(Y)
DO RSLT($JUSTIFY("",5)_$$M(0)_"EDIT PROVIDER CODE FAILED => "_L)
QUIT
+8 DO MODOK
+9 QUIT
EDTMOD ;EP - update education topics
+1 NEW AUMACT,AUMNAM,AUMMNE,AUMMJT,AUMOUTC,AUMSTD,AUMRES,FDA,NEWIEN,ERR,I,AUMCHG,AUMD0,AUMCNT,AUMIEN
+2 IF '$DATA(EDTC)
DO RSLT("PATIENT EDUCATION TOPICS")
SET EDTC=""
+3 SET AUMCHG=0
SET U="^"
SET AUMIEN=""
SET AUMACT=$PIECE(L,U,1)
+4 SET AUMNAM=$$CLEAN($PIECE(L,U,2))
SET AUMMNE=$$CLEAN($PIECE(L,U,3))
SET AUMMJT=$$CLEAN($PIECE(L,U,4))
SET AUMOUTC=$PIECE(L,U,5)
SET AUMSTD=$PIECE(L,U,6)
+5 SET L=AUMMNE_$JUSTIFY("",13-$LENGTH(AUMMNE))_AUMNAM_$JUSTIFY("",51-$LENGTH(AUMNAM))_AUMMJT
+6 KILL AUMRES
+7 DO FIND^DIC(9999999.09,"","@;.01;1;.06","PX",AUMNAM,,"B",,,"AUMRES")
+8 SET AUMCNT=$PIECE($GET(AUMRES("DILIST",0)),"^",1)
+9 ; No matches found, create new
IF AUMCNT=0
SET AUMIEN=""
+10 ; One match found, store IEN
IF AUMCNT=1
SET AUMIEN=$PIECE($GET(AUMRES("DILIST",1,0)),"^",1)
+11 IF AUMCNT>1
SET AUMIEN=$PIECE($GET(AUMRES("DILIST",$PIECE($GET(AUMRES("DILIST",0)),"^",1),0)),"^",1)
+12 IF 'AUMIEN
Begin DoDot:1
+13 KILL AUMRES
+14 ;
DO FIND^DIC(9999999.09,"","@;.01;1;.06","PX",AUMMNE,,"C","I ($P(^(0),U,3)'=1),($P(^(0),U)=$$UP^XLFSTR($P(^(0),U)))",,"AUMRES")
+15 SET AUMCNT=$PIECE($GET(AUMRES("DILIST",0)),"^",1)
+16 ; No matches found, create new
IF AUMCNT=0
SET AUMIEN=""
+17 ; One match found, store IEN
IF AUMCNT=1
SET AUMIEN=$PIECE($GET(AUMRES("DILIST",1,0)),"^",1)
+18 IF AUMCNT>1
SET AUMIEN=$PIECE($GET(AUMRES("DILIST",$PIECE($GET(AUMRES("DILIST",0)),"^",1),0)),"^",1)
End DoDot:1
+19 ;
+20 IF 'AUMIEN
IF $LENGTH(AUMACT)>0
Begin DoDot:1
+21 DO RSLT($JUSTIFY("",5)_"INACTIVATE TOPIC FAILED : TOPIC DOES NOT EXIST => "_L)
End DoDot:1
QUIT
+22 IF 'AUMIEN
Begin DoDot:1
+23 KILL FDA,NEWIEN,ERR
+24 ; Name (.01)
SET FDA(9999999.09,"+1,",.01)=AUMNAM
+25 ; Mnemonic (1)
SET FDA(9999999.09,"+1,",1)=AUMMNE
+26 DO UPDATE^DIE(,"FDA","NEWIEN","ERR")
+27 IF $DATA(ERR)
DO ADDFAIL
QUIT
+28 SET AUMIEN=NEWIEN(1)
SET AUMCHG=1
End DoDot:1
+29 IF 'AUMIEN
QUIT
+30 SET AUMD0=$GET(^AUTTEDT(AUMIEN,0))
+31 ;
+32 KILL FDA
+33 ; Name (.01)
SET FDA(9999999.09,AUMIEN_",",.01)=AUMNAM
+34 ; Mnemonic (1)
SET FDA(9999999.09,AUMIEN_",",1)=AUMMNE
+35 ; Major Topic (.06)
SET FDA(9999999.09,AUMIEN_",",.06)=AUMMJT
+36 ; Inactive Flag (.03)
SET FDA(9999999.09,AUMIEN_",",.03)=$SELECT($LENGTH(AUMACT)>0:1,1:"@")
+37 DO UPDATE^DIE(,"FDA",)
+38 IF AUMD0'=$GET(^AUTTEDT(AUMIEN,0))
SET AUMCHG=1
+39 ;
+40 ; Outcome (1101) WP
+41 ; convert string to WP array
DO TEXT(.AUMOUTC)
+42 DO WP^DIE(9999999.09,AUMIEN_",",1101,,"AUMOUTC")
+43 ;
+44 ; Standards (1102) WP
+45 ; convert string to WP array
DO TEXT(.AUMSTD)
+46 DO WP^DIE(9999999.09,AUMIEN_",",1102,,"AUMSTD")
+47 ;
+48 IF AUMCHG
DO @$SELECT($DATA(NEWIEN):"ADDOK",$LENGTH(AUMACT)>0:"INAOK",1:"MODOK")
+49 ;
+50 KILL AUMRES,FDA
+51 DO FIND^DIC(9999999.09,"","@;.01;1;.06","PX",AUMNAM,,"B","I ($P(^(0),U,3)'=1),(Y'=AUMIEN)",,"AUMRES")
+52 SET AUMCNT=$PIECE($GET(AUMRES("DILIST",0)),"^",1)
+53 IF AUMCNT>0
DO RSLT("DUPLICATE NAMES FOUND FOR : "_AUMMNE_$JUSTIFY("",13-$LENGTH(AUMMNE))_AUMNAM)
+54 FOR I=1:1:AUMCNT
Begin DoDot:1
+55 NEW L
+56 SET L=$PIECE(AUMRES("DILIST",I,0),"^",3)_$JUSTIFY("",13-$LENGTH($PIECE(AUMRES("DILIST",I,0),"^",3)))_$PIECE(AUMRES("DILIST",I,0),"^",2)
+57 ; Inactive Flag (.03)
SET FDA(9999999.09,$PIECE(AUMRES("DILIST",I,0),"^",1)_",",.03)="1"
+58 DO DINAOK
End DoDot:1
+59 IF AUMCNT
DO UPDATE^DIE(,"FDA",)
+60 ;
+61 KILL AUMRES,FDA
+62 DO FIND^DIC(9999999.09,"","@;.01;1;.06","PX",AUMMNE,,"C","I ($P(^(0),U,3)'=1),(Y'=AUMIEN)",,"AUMRES")
+63 SET AUMCNT=$PIECE($GET(AUMRES("DILIST",0)),"^",1)
+64 IF AUMCNT>0
DO RSLT("DUPLICATE MNEMONICS FOUND FOR : "_AUMMNE_$JUSTIFY("",13-$LENGTH(AUMMNE))_AUMNAM)
+65 FOR I=1:1:AUMCNT
Begin DoDot:1
+66 NEW L
+67 SET L=$PIECE(AUMRES("DILIST",I,0),"^",3)_$JUSTIFY("",13-$LENGTH($PIECE(AUMRES("DILIST",I,0),"^",3)))_$PIECE(AUMRES("DILIST",I,0),"^",2)
+68 ; Inactive Flag (.03)
SET FDA(9999999.09,$PIECE(AUMRES("DILIST",I,0),"^",1)_",",.03)="1"
+69 DO DINAOK
End DoDot:1
+70 IF AUMCNT
DO UPDATE^DIE(,"FDA",)
+71 ;
+72 QUIT
MJTMOD ;EP - update major education topics
+1 NEW AUMNAM,AUMMNE,AUMRES,FDA,NEWIEN,ERR,AUMCHG,AUMD0,AUMCNT,AUMIEN
+2 IF '$DATA(MJTC)
DO RSLT("PATIENT EDUCATION MAJOR TOPICS")
SET MJTC=""
+3 SET AUMCHG=0
SET U="^"
SET AUMIEN=""
+4 SET AUMNAM=$$CLEAN($PIECE(L,U,1))
SET AUMMNE=$$CLEAN($EXTRACT($PIECE(L,U,2),1,4))
+5 SET L=AUMMNE_$JUSTIFY("",7-$LENGTH(AUMMNE))_AUMNAM
+6 KILL AUMRES
+7 DO FIND^DIC(99999.91,"","@;.01;.02","PX",AUMMNE,,"B",,,"AUMRES")
+8 SET AUMCNT=$PIECE($GET(AUMRES("DILIST",0)),"^",1)
+9 ; No matches found, create new
IF AUMCNT=0
SET AUMIEN=""
+10 ; One match found, store IEN
IF AUMCNT=1
SET AUMIEN=$PIECE($GET(AUMRES("DILIST",1,0)),"^",1)
+11 IF AUMCNT>1
SET AUMIEN=$PIECE($GET(AUMRES("DILIST",$PIECE($GET(AUMRES("DILIST",0)),"^",1),0)),"^",1)
+12 IF 'AUMIEN
Begin DoDot:1
+13 KILL FDA,NEWIEN,ERR
+14 ; Name (.01)
SET FDA(99999.91,"+1,",.01)=AUMNAM
+15 ; Abbreviation (.02)
SET FDA(99999.91,"+1,",.02)=AUMMNE
+16 DO UPDATE^DIE(,"FDA","NEWIEN","ERR")
+17 IF $DATA(ERR)
DO ADDFAIL
QUIT
+18 SET AUMIEN=NEWIEN(1)
SET AUMCHG=1
End DoDot:1
+19 IF 'AUMIEN
QUIT
+20 SET AUMD0=$GET(^AUTTEDMT(AUMIEN,0))
+21 ;
+22 KILL FDA
+23 ; Name (.01)
SET FDA(99999.91,AUMIEN_",",.01)=AUMNAM
+24 ; Abbreviation (.02)
SET FDA(99999.91,AUMIEN_",",.02)=AUMMNE
+25 DO UPDATE^DIE(,"FDA",)
+26 IF AUMD0'=$GET(^AUTTEDMT(AUMIEN,0))
SET AUMCHG=1
+27 ;
+28 IF AUMCHG
DO @$SELECT($DATA(NEWIEN):"ADDOK",1:"MODOK")
+29 QUIT
CLEAN(X) ;
+1 NEW CNT,AUMSTR
+2 SET AUMSTR=X
+3 SET CNT=0
FOR
SET CNT=$FIND(X," -")
IF 'CNT
QUIT
SET $EXTRACT(X,CNT-2,CNT-1)="-"
+4 SET CNT=0
FOR
SET CNT=$FIND(X,"- ")
IF 'CNT
QUIT
SET $EXTRACT(X,CNT-2,CNT-1)="-"
+5 SET CNT=0
FOR
SET CNT=$FIND(X," ")
IF 'CNT
QUIT
SET $EXTRACT(X,CNT-2,CNT-1)=" "
+6 IF $EXTRACT(X,1)=" "
SET X=$EXTRACT(X,2,$LENGTH(X))
+7 IF $EXTRACT(X,$LENGTH(X))=" "
SET X=$EXTRACT(X,1,$LENGTH(X)-1)
+8 QUIT X
TEXT(X) ;
+1 NEW AUMSTR,I,J
+2 SET AUMSTR=X
SET I=1
SET J=1
+3 KILL X
+4 FOR I=1:1:$LENGTH(AUMSTR,"|")
Begin DoDot:1
+5 IF $LENGTH($PIECE(AUMSTR,"|",I))=0
QUIT
+6 SET X(J)=$PIECE(AUMSTR,"|",I)
SET J=J+1
End DoDot:1
+7 QUIT
SVARS ;;A,C,E,F,L,M,N,O,P,R,S,T,V;Single-character work variables
+1 QUIT
PKLST ;EP - Check to see what EHR pick lists might be affected
+1 DO RSLT("DISPLAYING EHR PICKLISTS CONTAINING INACTIVE EDUCATION TOPICS")
+2 NEW PKNAM,PK1,PK2,PK3,PXEDT,AUMDSP
+3 SET PKNAM=""
SET PK1=0
+4 FOR
SET PK1=$ORDER(^BGOEDTPR(PK1))
IF PK1'?1N.N
QUIT
Begin DoDot:1
+5 SET AUMDSP=1
+6 SET PK2=""
FOR
SET PK2=$ORDER(^BGOEDTPR(PK1,PK2))
IF PK2'?1N.N
QUIT
Begin DoDot:2
+7 IF PK2=0
SET PKNAM=$PIECE(^BGOEDTPR(PK1,PK2),U,1)
+8 SET PK3=0
FOR
SET PK3=$ORDER(^BGOEDTPR(PK1,PK2,PK3))
IF PK3'?1N.N
QUIT
Begin DoDot:3
+9 SET PXEDT=$PIECE($GET(^BGOEDTPR(PK1,PK2,PK3,0)),U,1)
+10 IF PXEDT=""
QUIT
+11 IF $PIECE($GET(^AUTTEDT(PXEDT,0)),U,3)'=1
QUIT
+12 NEW AUMMNE,AUMNAM,AUMINA
+13 SET AUMMNE=$PIECE(^AUTTEDT(PXEDT,0),"^",2)
SET AUMNAM=$PIECE(^AUTTEDT(PXEDT,0),"^",1)
SET AUMINA=$$FMTE^XLFDT($PIECE(^AUTTEDT(PXEDT,0),"^",5))
+14 IF AUMDSP
DO RSLT("")
DO RSLT("INACTIVE TOPIC(S) FOUND IN EHR PICKLIST: "_$PIECE(^BGOEDTPR(PK1,0),"^",1))
SET AUMDSP=0
+15 DO RSLT($JUSTIFY("",4)_AUMMNE_$JUSTIFY("",13-$LENGTH(AUMMNE))_"'"_AUMNAM_"'"_$JUSTIFY("",51-$LENGTH(AUMNAM))_AUMINA)
+16 QUIT
End DoDot:3
+17 QUIT
End DoDot:2
+18 QUIT
End DoDot:1
+19 QUIT
