AUMUP102 ;IHS/OIT/ABK - AUM 11 patch 1 AUTTEDT LOAD [ 10/09/2010 4:11 PM ]
;;11.0;TABLE MAINTENANCE;**5**;Oct 15,2010
;
QUIT ; This routine should not be called at the top. It is only to be called
; at START and POST by KIDS as the pre and post inits for AUM*10.2.
;
START ;IHS/OIT/ABK
D UPD
Q
UPD ;read ^AUMPCLN and update ^AUTTEDT
; Development Notes - 2/17/2010 - abk
; 1. Had a lot of trouble setting the sub fields until I called ^XBFMK after every
; fileman call. Once I did that and reset all the fileman variables before fileman
; call, it worked flawlessly.
; 2. We are updating existing Patient Education topics. We are setting all
; existing topics to inactive before we load the next set updating where we find a
; match.
; 3. When updating and deleting the Outcome and Standard sub fields, I had
; to kill off those entries explicitly because the data contains punctuation
; at these levels and I get a subscript error from ^DIK trying to parse the data for
; punctuation because it thinks this is a file specification and not data...
;
N AUMX,AUMICD,XICD,XNAM,AUMXS,AUMCNAM,AUMMNE,AUMMJT,AUMOUTC,AUMPCLN,AUMSTD,AUMDINUM,AUMDA,AUMDA1,XABK,DINUM,TOTCNT,TOTUPD,TOTNEW,AUMSKIP,SKIPIT
K DO,DIC,DIE
D ^XBFMK
S ADT=$$DT^XLFDT
;
S ^XTMP("AUM11P1",0)="3120101^3101101^AUM*11.0*2"
S:$G(APART)=1 ^XTMP("AUM11P1",ADT)="PARTIAL"
S:$G(APART)'=1 ^XTMP("AUM11P1",ADT)="FULL"
S AUMPCLN="",TOTUPD=0,TOTNEW=0,TOTCNT=0,AUMSKIP=0,AUMERR=0,TOTINACT=0
F S AUMPCLN=$O(^AUMPCLN(AUMPCLN)) Q:AUMPCLN="" S AUMXS=^(AUMPCLN) D
.S TOTCNT=TOTCNT+1
.S AUMACT=$P(AUMXS,U,1)
.I AUMACT="I" D INACT^AUMP1012 Q
.S AUMCNAM=$P(AUMXS,U,2),AUMMNE=$P(AUMXS,U,3),AUMMJT=$P($P(AUMXS,U,4),"-",1),AUMOUTC=$P(AUMXS,U,5),AUMSTD=$P(AUMXS,U,6)
.;
.; Do error checking
.I AUMCNAM="" D BMES^XPDUTL("Name field is null "_AUMCNAM_" not inserted - error"),BMES^XPDUTL("Record: "_AUMXS) S AUMERR=AUMERR+1 Q
.I AUMMNE="" D BMES^XPDUTL("Mnemonic field is null "_AUMMNE_" not inserted - error"),BMES^XPDUTL("Record: "_AUMXS) S AUMERR=AUMERR+1 Q
.;
.; Ok - past that
.S AUMFND=0
.S AUMDA1=0,AUMDA1=$O(^AUTTEDT("B",AUMCNAM,AUMDA1)) I AUMDA1'="" S AUMFND=1
.I 'AUMFND S AUMDA1=-1,AUMDA1=$O(^AUTTEDT("C",AUMMNE,AUMDA1)) I AUMDA1'="" S AUMFND=1
.I 'AUMFND D
..S X=AUMCNAM,DIC="^AUTTEDT("
..S DIC("DR")="1////"_AUMMNE_";.06////"_AUMMJT
..D ^DIC
..I $P(Y,U,1)'=-1 D
...S (AUMDA,AUMDA1,DA)=$P(Y,U,1),AUMFND=1
...Q
..Q
.I 'AUMFND D
..S X=AUMCNAM,DIC="^AUTTEDT("
..S DIC("DR")="1////"_AUMMNE_";.06////"_AUMMJT,DIC(0)="L"
..D ^DIC
..I $P(Y,U,3)=1 D
...S TOTNEW=TOTNEW+1
...S ^XTMP("AUM11P1",ADT,"NEW",TOTNEW)=AUMCNAM_"^"_AUMMNE
...S (AUMDA,AUMDA1,DA)=$P(Y,U,1)
...D BMES^XPDUTL("New - Name = "_AUMCNAM_" Mnemonic = "_AUMMNE)
...Q
..E D
...I $P(Y,U,1)=-1 D
....S AUMERR=AUMERR+1
....K AUMDA
....S ^XTMP("AUM11P1",ADT,"ERROR","INSERT FAILED",AUMERR)=AUMCNAM_"^"_AUMMNE
....D BMES^XPDUTL("Record: "_AUMPCLN_" not inserted - error"),BMES^XPDUTL("AUMCNAM= "_AUMCNAM),BMES^XPDUTL("AUMMNE= "_AUMMNE),BMES^XPDUTL("Record: "_AUMXS),BMES^XPDUTL("Y: "_Y)
....Q
...E D
....S (AUMDA,AUMDA1,DA)=$P(Y,U,1),AUMFND=1
....Q
..Q
.D ^XBFMK
.;Done with new; so,we are updating
.I AUMFND D
..S SKIPIT=0
..S AUMX=$G(^AUTTEDT(AUMDA1,0)),AUMICD=$P(AUMX,U,4),XICD=$P(AUMX,U,6),XNAM=$P(AUMX,U,1)
..;if this is a local topic, quit
..I AUMICD?1N.N S SKIPIT=1
..I XICD?1A.N1P.N S SKIPIT=1
..I XICD?.N1P.N S SKIPIT=1
..I XICD?1P.N S SKIPIT=1
..; OK CHECK TO SEE IF WE'RE SKIIPING, QUIT IF SO
..I SKIPIT=1 D
...D BMES^XPDUTL("Local Topic "_XNAM_" not changed - Skipped"),BMES^XPDUTL("Record: "_AUMX)
...S AUMSKIP=AUMSKIP+1
...S ^XTMP("AUM11P1",ADT,"SKIPPED",AUMDA1)=AUMCNAM_"^"_AUMMNE
...Q
..Q:SKIPIT=1
..; OK, we're ok to update
..S TOTUPD=TOTUPD+1
..S DIE="^AUTTEDT(",DA=AUMDA1 ;,DIC(0)="L"
..S DR=".01////"_AUMCNAM_";1////"_AUMMNE_";.06////"_AUMMJT_";.03////@"
..S ^XTMP("AUM11P1",ADT,"UPDATE",AUMDA1)=AUMCNAM_"^"_AUMMNE
..D ^DIE D BMES^XPDUTL("Updated - Name = "_AUMCNAM_" Mnemonic = "_AUMMNE) D ^XBFMK
..; abk - hit subscript error due to data on next 2 lines trying to
..; delete outcome and standard data
..;S DA(1)=AUMDA1,DIK="^AUTTEDT("_DA(1)_",",DA=2 D ^DIK D ^XBFMK
..;S DA(1)=AUMDA1,DIK="^AUTTEDT("_DA(1)_",",DA=1 D ^DIK D ^XBFMK
..; so, I am killing them outright - they are not cross-referenced
..K ^AUTTEDT(AUMDA1,1),^AUTTEDT(AUMDA1,2)
..S AUMDA=AUMDA1
..Q
.I $D(AUMDA),AUMOUTC'="" D
..S DIC("P")=$P(^DD(9999999.09,1101,0),U,2),DA=AUMDA,DIC="^AUTTEDT("_AUMDA_",1,",DINUM=0,X="",DIC(0)="L" D FILE^DICN S DIC("P")="" D ^XBFMK
..I AUMOUTC["|" F AUMDINUM=1:1 S XABK=$P(AUMOUTC,"|",AUMDINUM) S:XABK="" AUMDINUM=AUMDINUM+1,XABK=$P(AUMOUTC,"|",AUMDINUM) S DIC="^AUTTEDT("_AUMDA_",1,",DIC(0)="L" Q:XABK="" S DA=AUMDA,DINUM=AUMDINUM,X=XABK D FILE^DICN D ^XBFMK
..I AUMOUTC'["|" S XABK=AUMOUTC,DIC="^AUTTEDT("_AUMDA_",1," I XABK'="" S DA=AUMDA,DINUM=1,X=XABK,DIC(0)="L" D FILE^DICN D ^XBFMK
..Q
..;
.I $D(AUMDA),AUMSTD'="" D
..S DIC("P")=$P(^DD(9999999.09,1102,0),U,2),DA=AUMDA,DIC="^AUTTEDT("_AUMDA_",2,",X="",DINUM=0,DIC(0)="L" D FILE^DICN S DIC("P")="" D ^XBFMK
..I AUMSTD["|" F AUMDINUM=1:1 S XABK=$P(AUMSTD,"|",AUMDINUM) S:XABK="" AUMDINUM=AUMDINUM+1,XABK=$P(AUMSTD,"|",AUMDINUM) S DIC="^AUTTEDT("_AUMDA_",2,",DIC(0)="L" Q:XABK="" S DA=AUMDA,DINUM=AUMDINUM,X=XABK D FILE^DICN D ^XBFMK
..I AUMSTD'["|" S XABK=AUMSTD,DIC="^AUTTEDT("_AUMDA_",2," I XABK'="" S DA=AUMDA,DINUM=1,X=XABK,DIC(0)="L" D FILE^DICN D ^XBFMK
..Q
.Q
;now check ^AUTTEDT for inactive records
D:$G(APART)'=1 INACT
;and, check EHR for potential picklist changes, quit if not there
D:$D(^BGOEDTPR) PKLST
D FBADNAM
D FBADMN
;
S AUMX=^XTMP("AUM11P1",ADT)_"^Total Records:^"_TOTCNT_"^Errors:^"_AUMERR_"^New:^"_TOTNEW_"^Updated:^"_TOTUPD_"^Inactive:^"_TOTINACT_"^Not Updated:^"_TMNMISS_"^Skipped:^"_AUMSKIP
S ^XTMP("AUM11P1",ADT)=AUMX
D BMES^XPDUTL("Total records processed: "_TOTCNT)
D BMES^XPDUTL("Total records updated: "_TOTUPD)
D BMES^XPDUTL("Total records inactivated: "_TOTINACT)
D BMES^XPDUTL("Total records inserted: "_TOTNEW)
D BMES^XPDUTL("Total records in error: "_AUMERR)
D BMES^XPDUTL("Local records skipped: "_AUMSKIP)
Q
KILL ;kill "B" and "C" cross-references
K ^AUTTEDT("B")
K ^AUTTEDT("C")
Q
;
POST ;call to ENALL^DIK for .01 and 1
W !,"Rebuilding Indexes",!
S DIK="^AUTTEDT("
S DIK(1)=".01^B"
D ENALL^DIK
S DIK(1)="1^C"
D ENALL^DIK
Q
INACT ;Check for new inactive records
N A,AUMX,AUMDT
S A=0,TOTINACT=0,AUMDT=$$DT^XLFDT
F S A=$O(^AUTTEDT(A)) Q:A'?1N.N S AUMX=$G(^AUTTEDT(A,0)) D
.Q:$P(AUMX,U,5)'=AUMDT
.Q:'$D(TMP("AUM11P1",ADT,"UPDATE",A))
.S ^XTMP("AUM11P1",ADT,"INACTIVE",A)=$P(^AUTTEDT(A,0),U,1,2)
.S TOTINACT=TOTINACT+1
.Q
Q
PKLST ;Check to see what EHR pick lists might be affected
S PKNAM="",PK1=0
F S PK1=$O(^BGOEDTPR(PK1)) Q:PK1'?1N.N D
.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)
...S:PXEDT'="" ^XTMP("AUM11P1",ADT,"PKLST",PKNAM,PXEDT)=""
...Q
..Q
.Q
Q
RPT ;Actually print the report
;
N A,ADT,L,X,DATAX
S AUMHDR=""
D EN^AUMDODEV
S A=0 F J=1:1 S A=$O(^XTMP("AUM11P1",A)) Q:A="" S DATAX(J)=A
S JNDX=J-1
OPT ;Select which install to report on
I JNDX>1 D
.S DIR(0)="SO^"
.S DIR("L",1)="Which Date Do You Want To Report On:"
.S DIR("L",2)=""
.S A="" F K=1:1 S A=$O(DATAX(A)) Q:A="" S DIR("L",K+2)=K_" "_DATAX(A),DIR(0)=DIR(0)_K_":"_DATAX(A)_";"
.S L=$L(DIR(0)),L=L-1
.S DIR(0)=$E(DIR(0),1,L)
.D ^DIR Q:X="^"
.S ADT=DATAX(X)
.Q
E S ADT=DATAX(1)
Q:'$D(ADT)
U IO
S AUMBM=IOSL-10
I '$D(IO("S")),'$D(ZTQUEUED),IO=IO(0) S AUMBM=IOSL-4
S AUMPG=1,DIWL=5,DIWR=75,DIWF="W"
W !!,"**** Patient Education Topic Report for "_ADT_" ****",!!!
W !,"Records that were not loaded due to errors:",!
I $D(^XTMP("AUM11P1",ADT,"ERROR")) D RERR
E W ?15,"No Errors to Report",!
W !!
W !,"Records that were set as Inactive:",!
I $D(^XTMP("AUM11P1",ADT,"INACTIVE")) D RINA
E W ?15,"No Records were made Inactive",!
W !!
W !,"Records that are New:",!
I $D(^XTMP("AUM11P1",ADT,"NEW")) D RNEW
E W ?15,"No New Records were Added",!
W !!
W !,"Local (ICD9) Records that were Skipped:",!
I $D(^XTMP("AUM11P1",ADT,"SKIPPED")) D RSKP
E W ?15,"No Local Records were Skipped",!
W !!
W !,"Records that were Updated:",!
I $D(^XTMP("AUM11P1",ADT,"UPDATE")) D RUPD
E W ?15,"No Records were Updated",!
W !!
I $D(^XTMP("AUM11P1",ADT,"PKLST")) D RPKL
E W ?15,"EHR Not installed or no Pick Lists were Added",!
W !!
;I $D(^XTMP("AUM11P1",ADT,"MISSING NM")) D RNAM W !!
I $D(^XTMP("AUM11P1",ADT,"MISSING MNE")) D RMNE W !!
;
S AUMX=^XTMP("AUM11P1",ADT) F J=2:2:15 W ?15,$P(AUMX,U,J),?30,$P(AUMX,U,J+1),!
W !,"**** End of Patient Education Topic Report for "_ADT_" ****",!
D END
Q
RUPD ;Report on records that were Updated
S AUMHDR=" EIN Name Mnemonic"
W !,?2,"EIN",?12,"Name",?65,"Mnemonic",!
S A="" F S A=$O(^XTMP("AUM11P1",ADT,"UPDATE",A)) Q:A'?1N.N D
.W ?2,A,?12,$E($P(^XTMP("AUM11P1",ADT,"UPDATE",A),U,1),1,50),?65,$E($P(^XTMP("AUM11P1",ADT,"UPDATE",A),U,2),1,14)
.D ^DIWW,PG:$Y>AUMBM
.Q
Q
RNEW ;Report on New Records
S AUMHDR=" Name Mnemonic"
W !,?5,"Name",?65,"Mnemonic",!
S A="" F S A=$O(^XTMP("AUM11P1",ADT,"NEW",A)) Q:A="" D
.W ?5,$E($P(^XTMP("AUM11P1",ADT,"NEW",A),U,1),1,55),?65,$E($P(^XTMP("AUM11P1",ADT,"NEW",A),U,2),1,14)
.D ^DIWW,PG:$Y>AUMBM
.Q
Q
RSKP ;Report on Skipped Records
S AUMHDR=" Name Mnemonic"
W !,?5,"Name",?65,"Mnemonic",!
S A="" F S A=$O(^XTMP("AUM11P1",ADT,"SKIPPED",A)) Q:A="" D
.W ?5,$E($P(^XTMP("AUM11P1",ADT,"SKIPPED",A),U,1),1,55),?65,$E($P(^XTMP("AUM11P1",ADT,"SKIPPED",A),U,2),1,14)
.D ^DIWW,PG:$Y>AUMBM
.Q
Q
RINA ;Report Inactive records
S AUMHDR=" Name Mnemonic"
W !,?5,"Name",?65,"Mnemonic",!
S A="" F S A=$O(^XTMP("AUM11P1",ADT,"INACTIVE",A)) Q:A="" D
.W ?5,$E($P(^XTMP("AUM11P1",ADT,"INACTIVE",A),U,1),1,55),?65,$E($P(^XTMP("AUM11P1",ADT,"INACTIVE",A),U,2),1,14)
.D ^DIWW,PG:$Y>AUMBM
.Q
Q
RERR ;Report Errors
S AUMHDR=" Name Mnemonic"
W !,?5,"Name",?65,"Mnemonic"
S A="" F S A=$O(^XTMP("AUM11P1",ADT,"ERROR",A)) Q:A="" D
.W !,?10,"Error: ",A,!
.S B=0 F S B=$O(^XTMP("AUM11P1",ADT,"ERROR",A,B)) Q:B'?1N.N D
..W ?5,$E($P(^XTMP("AUM11P1",ADT,"ERROR",A,B),U,1),1,55),?65,$E($P(^XTMP("AUM11P1",ADT,"ERROR",A,B),U,2),1,14)
..D ^DIWW,PG:$Y>AUMBM
..Q
.Q
Q
RPKL ;Report of pick lists if we have any
;Pick Lists
S AUMHDR=" Pick List Name Topic EIN"
W !,"EHR Pick Lists that may have been affected and need Review:",!
W !,?5,"Pick List Name",?65,"Topic EIN",!
S A="" F S A=$O(^XTMP("AUM11P1",ADT,"PKLST",A)) Q:A="" D
.W ?5,$E(A,1,50)
.S B=0 F S B=$O(^XTMP("AUM11P1",ADT,"PKLST",A,B)) Q:B'?1N.N D
..W ?65,$E(B,1,14),!
..D ^DIWW,PG:$Y>AUMBM
..Q
.W !
.Q
Q
RNAM ;Report on Source items that are missing by name
;Records that are not in AUTTEDT, but should be
W !,"Records that were not updated, by Name",!
S AUMHDR=" Name"
W !,?5,"Name",!
S A="" F S A=$O(^XTMP("AUM11P1",ADT,"MISSING NM",A)) Q:A="" D
.W ?5,$E($P(A,U,1),1,55)
.D ^DIWW,PG:$Y>AUMBM
.Q
Q
RMNE ;Report on Source items that are missing by Mnemonic
;Records that were not updated in AUTTEDT, but should be
W !,"Records that were not updated, by Mnemonic",!
S AUMHDR=" Mnemonic"
W !,?5,"Mnemonic",!
S A="" F S A=$O(^XTMP("AUM11P1",ADT,"MISSING MNE",A)) Q:A="" D
.W ?5,$E($P(A,U,1),1,55)
.D ^DIWW,PG:$Y>AUMBM
.Q
Q
END ;EP
W !!!
I IO(0)=IO D
.I IOST["C-",'$D(IO("S")) S Y=$$DIR^XBDIR("E","Press RETURN To Continue or Escape to Cancel...","","","",1) X ^%ZOSF("TRMRD")
.D ^DIWW
.Q
END1 ;
D ^%ZISC
Q
PG ; --- Paginate, write header
I IOST["C-",'$D(IO("S")) S Y=$$DIR^XBDIR("E","Press RETURN To Continue or Escape to Cancel...","","","",1) X ^%ZOSF("TRMRD")
S AUMPG=AUMPG+1
W @IOF,!!!?DIWL-1,?($S($G(IOM):IOM,1:75)-$L("Page "_AUMPG)),"Page ",AUMPG,!!,AUMHDR,!
Q
;
FBADNAM ;Find all missing names
N A,B,X,MN
S TNMISS=0
S A="" F S A=$O(^AUMPCLN(A)) Q:A="" S X=^(A),MN=$P(X,U,2),B="",B=$O(^AUTTEDT("B",MN,B)) S:B="" ^XTMP("AUM11P1",ADT,"MISSING NM",MN)="",TNMISS=TNMISS+1
Q
FBADMN ;Find all missing Mnemonics
N A,B,X,MN
S TMNMISS=0
S A="" F S A=$O(^AUMPCLN(A)) Q:A="" S X=^(A),MN=$P(X,U,3),B="",B=$O(^AUTTEDT("C",MN,B)) S:B="" ^XTMP("AUM11P1",ADT,"MISSING MNE",MN)="",TMNMISS=TMNMISS+1
Q
RTRIM(X) ;Strip off trailing spaces
F %=$L(X):-1:1 S:$A(X,%)=32 X=$E(X,0,%-1)
Q
;end of routine AUMUPD102
AUMUP102 ;IHS/OIT/ABK - AUM 11 patch 1 AUTTEDT LOAD [ 10/09/2010 4:11 PM ]
+1 ;;11.0;TABLE MAINTENANCE;**5**;Oct 15,2010
+2 ;
QUIT ; This routine should not be called at the top. It is only to be called
+1 ; at START and POST by KIDS as the pre and post inits for AUM*10.2.
+2 ;
START ;IHS/OIT/ABK
+1 DO UPD
+2 QUIT
UPD ;read ^AUMPCLN and update ^AUTTEDT
+1 ; Development Notes - 2/17/2010 - abk
+2 ; 1. Had a lot of trouble setting the sub fields until I called ^XBFMK after every
+3 ; fileman call. Once I did that and reset all the fileman variables before fileman
+4 ; call, it worked flawlessly.
+5 ; 2. We are updating existing Patient Education topics. We are setting all
+6 ; existing topics to inactive before we load the next set updating where we find a
+7 ; match.
+8 ; 3. When updating and deleting the Outcome and Standard sub fields, I had
+9 ; to kill off those entries explicitly because the data contains punctuation
+10 ; at these levels and I get a subscript error from ^DIK trying to parse the data for
+11 ; punctuation because it thinks this is a file specification and not data...
+12 ;
+13 NEW AUMX,AUMICD,XICD,XNAM,AUMXS,AUMCNAM,AUMMNE,AUMMJT,AUMOUTC,AUMPCLN,AUMSTD,AUMDINUM,AUMDA,AUMDA1,XABK,DINUM,TOTCNT,TOTUPD,TOTNEW,AUMSKIP,SKIPIT
+14 KILL DO,DIC,DIE
+15 DO ^XBFMK
+16 SET ADT=$$DT^XLFDT
+17 ;
+18 SET ^XTMP("AUM11P1",0)="3120101^3101101^AUM*11.0*2"
+19 IF $GET(APART)=1
SET ^XTMP("AUM11P1",ADT)="PARTIAL"
+20 IF $GET(APART)'=1
SET ^XTMP("AUM11P1",ADT)="FULL"
+21 SET AUMPCLN=""
SET TOTUPD=0
SET TOTNEW=0
SET TOTCNT=0
SET AUMSKIP=0
SET AUMERR=0
SET TOTINACT=0
+22 FOR
SET AUMPCLN=$ORDER(^AUMPCLN(AUMPCLN))
IF AUMPCLN=""
QUIT
SET AUMXS=^(AUMPCLN)
Begin DoDot:1
+23 SET TOTCNT=TOTCNT+1
+24 SET AUMACT=$PIECE(AUMXS,U,1)
+25 IF AUMACT="I"
DO INACT^AUMP1012
QUIT
+26 SET AUMCNAM=$PIECE(AUMXS,U,2)
SET AUMMNE=$PIECE(AUMXS,U,3)
SET AUMMJT=$PIECE($PIECE(AUMXS,U,4),"-",1)
SET AUMOUTC=$PIECE(AUMXS,U,5)
SET AUMSTD=$PIECE(AUMXS,U,6)
+27 ;
+28 ; Do error checking
+29 IF AUMCNAM=""
DO BMES^XPDUTL("Name field is null "_AUMCNAM_" not inserted - error")
DO BMES^XPDUTL("Record: "_AUMXS)
SET AUMERR=AUMERR+1
QUIT
+30 IF AUMMNE=""
DO BMES^XPDUTL("Mnemonic field is null "_AUMMNE_" not inserted - error")
DO BMES^XPDUTL("Record: "_AUMXS)
SET AUMERR=AUMERR+1
QUIT
+31 ;
+32 ; Ok - past that
+33 SET AUMFND=0
+34 SET AUMDA1=0
SET AUMDA1=$ORDER(^AUTTEDT("B",AUMCNAM,AUMDA1))
IF AUMDA1'=""
SET AUMFND=1
+35 IF 'AUMFND
SET AUMDA1=-1
SET AUMDA1=$ORDER(^AUTTEDT("C",AUMMNE,AUMDA1))
IF AUMDA1'=""
SET AUMFND=1
+36 IF 'AUMFND
Begin DoDot:2
+37 SET X=AUMCNAM
SET DIC="^AUTTEDT("
+38 SET DIC("DR")="1////"_AUMMNE_";.06////"_AUMMJT
+39 DO ^DIC
+40 IF $PIECE(Y,U,1)'=-1
Begin DoDot:3
+41 SET (AUMDA,AUMDA1,DA)=$PIECE(Y,U,1)
SET AUMFND=1
+42 QUIT
End DoDot:3
+43 QUIT
End DoDot:2
+44 IF 'AUMFND
Begin DoDot:2
+45 SET X=AUMCNAM
SET DIC="^AUTTEDT("
+46 SET DIC("DR")="1////"_AUMMNE_";.06////"_AUMMJT
SET DIC(0)="L"
+47 DO ^DIC
+48 IF $PIECE(Y,U,3)=1
Begin DoDot:3
+49 SET TOTNEW=TOTNEW+1
+50 SET ^XTMP("AUM11P1",ADT,"NEW",TOTNEW)=AUMCNAM_"^"_AUMMNE
+51 SET (AUMDA,AUMDA1,DA)=$PIECE(Y,U,1)
+52 DO BMES^XPDUTL("New - Name = "_AUMCNAM_" Mnemonic = "_AUMMNE)
+53 QUIT
End DoDot:3
+54 IF '$TEST
Begin DoDot:3
+55 IF $PIECE(Y,U,1)=-1
Begin DoDot:4
+56 SET AUMERR=AUMERR+1
+57 KILL AUMDA
+58 SET ^XTMP("AUM11P1",ADT,"ERROR","INSERT FAILED",AUMERR)=AUMCNAM_"^"_AUMMNE
+59 DO BMES^XPDUTL("Record: "_AUMPCLN_" not inserted - error")
DO BMES^XPDUTL("AUMCNAM= "_AUMCNAM)
DO BMES^XPDUTL("AUMMNE= "_AUMMNE)
DO BMES^XPDUTL("Record: "_AUMXS)
DO BMES^XPDUTL("Y: "_Y)
+60 QUIT
End DoDot:4
+61 IF '$TEST
Begin DoDot:4
+62 SET (AUMDA,AUMDA1,DA)=$PIECE(Y,U,1)
SET AUMFND=1
+63 QUIT
End DoDot:4
End DoDot:3
+64 QUIT
End DoDot:2
+65 DO ^XBFMK
+66 ;Done with new; so,we are updating
+67 IF AUMFND
Begin DoDot:2
+68 SET SKIPIT=0
+69 SET AUMX=$GET(^AUTTEDT(AUMDA1,0))
SET AUMICD=$PIECE(AUMX,U,4)
SET XICD=$PIECE(AUMX,U,6)
SET XNAM=$PIECE(AUMX,U,1)
+70 ;if this is a local topic, quit
+71 IF AUMICD?1N.N
SET SKIPIT=1
+72 IF XICD?1A.N1P.N
SET SKIPIT=1
+73 IF XICD?.N1P.N
SET SKIPIT=1
+74 IF XICD?1P.N
SET SKIPIT=1
+75 ; OK CHECK TO SEE IF WE'RE SKIIPING, QUIT IF SO
+76 IF SKIPIT=1
Begin DoDot:3
+77 DO BMES^XPDUTL("Local Topic "_XNAM_" not changed - Skipped")
DO BMES^XPDUTL("Record: "_AUMX)
+78 SET AUMSKIP=AUMSKIP+1
+79 SET ^XTMP("AUM11P1",ADT,"SKIPPED",AUMDA1)=AUMCNAM_"^"_AUMMNE
+80 QUIT
End DoDot:3
+81 IF SKIPIT=1
QUIT
+82 ; OK, we're ok to update
+83 SET TOTUPD=TOTUPD+1
+84 ;,DIC(0)="L"
SET DIE="^AUTTEDT("
SET DA=AUMDA1
+85 SET DR=".01////"_AUMCNAM_";1////"_AUMMNE_";.06////"_AUMMJT_";.03////@"
+86 SET ^XTMP("AUM11P1",ADT,"UPDATE",AUMDA1)=AUMCNAM_"^"_AUMMNE
+87 DO ^DIE
DO BMES^XPDUTL("Updated - Name = "_AUMCNAM_" Mnemonic = "_AUMMNE)
DO ^XBFMK
+88 ; abk - hit subscript error due to data on next 2 lines trying to
+89 ; delete outcome and standard data
+90 ;S DA(1)=AUMDA1,DIK="^AUTTEDT("_DA(1)_",",DA=2 D ^DIK D ^XBFMK
+91 ;S DA(1)=AUMDA1,DIK="^AUTTEDT("_DA(1)_",",DA=1 D ^DIK D ^XBFMK
+92 ; so, I am killing them outright - they are not cross-referenced
+93 KILL ^AUTTEDT(AUMDA1,1),^AUTTEDT(AUMDA1,2)
+94 SET AUMDA=AUMDA1
+95 QUIT
End DoDot:2
+96 IF $DATA(AUMDA)
IF AUMOUTC'=""
Begin DoDot:2
+97 SET DIC("P")=$PIECE(^DD(9999999.09,1101,0),U,2)
SET DA=AUMDA
SET DIC="^AUTTEDT("_AUMDA_",1,"
SET DINUM=0
SET X=""
SET DIC(0)="L"
DO FILE^DICN
SET DIC("P")=""
DO ^XBFMK
+98 IF AUMOUTC["|"
FOR AUMDINUM=1:1
SET XABK=$PIECE(AUMOUTC,"|",AUMDINUM)
IF XABK=""
SET AUMDINUM=AUMDINUM+1
SET XABK=$PIECE(AUMOUTC,"|",AUMDINUM)
SET DIC="^AUTTEDT("_AUMDA_",1,"
SET DIC(0)="L"
IF XABK=""
QUIT
SET DA=AUMDA
SET DINUM=AUMDINUM
SET X=XABK
DO FILE^DICN
DO ^XBFMK
+99 IF AUMOUTC'["|"
SET XABK=AUMOUTC
SET DIC="^AUTTEDT("_AUMDA_",1,"
IF XABK'=""
SET DA=AUMDA
SET DINUM=1
SET X=XABK
SET DIC(0)="L"
DO FILE^DICN
DO ^XBFMK
+100 QUIT
+101 ;
End DoDot:2
+102 IF $DATA(AUMDA)
IF AUMSTD'=""
Begin DoDot:2
+103 SET DIC("P")=$PIECE(^DD(9999999.09,1102,0),U,2)
SET DA=AUMDA
SET DIC="^AUTTEDT("_AUMDA_",2,"
SET X=""
SET DINUM=0
SET DIC(0)="L"
DO FILE^DICN
SET DIC("P")=""
DO ^XBFMK
+104 IF AUMSTD["|"
FOR AUMDINUM=1:1
SET XABK=$PIECE(AUMSTD,"|",AUMDINUM)
IF XABK=""
SET AUMDINUM=AUMDINUM+1
SET XABK=$PIECE(AUMSTD,"|",AUMDINUM)
SET DIC="^AUTTEDT("_AUMDA_",2,"
SET DIC(0)="L"
IF XABK=""
QUIT
SET DA=AUMDA
SET DINUM=AUMDINUM
SET X=XABK
DO FILE^DICN
DO ^XBFMK
+105 IF AUMSTD'["|"
SET XABK=AUMSTD
SET DIC="^AUTTEDT("_AUMDA_",2,"
IF XABK'=""
SET DA=AUMDA
SET DINUM=1
SET X=XABK
SET DIC(0)="L"
DO FILE^DICN
DO ^XBFMK
+106 QUIT
End DoDot:2
+107 QUIT
End DoDot:1
+108 ;now check ^AUTTEDT for inactive records
+109 IF $GET(APART)'=1
DO INACT
+110 ;and, check EHR for potential picklist changes, quit if not there
+111 IF $DATA(^BGOEDTPR)
DO PKLST
+112 DO FBADNAM
+113 DO FBADMN
+114 ;
+115 SET AUMX=^XTMP("AUM11P1",ADT)_"^Total Records:^"_TOTCNT_"^Errors:^"_AUMERR_"^New:^"_TOTNEW_"^Updated:^"_TOTUPD_"^Inactive:^"_TOTINACT_"^Not Updated:^"_TMNMISS_"^Skipped:^"_AUMSKIP
+116 SET ^XTMP("AUM11P1",ADT)=AUMX
+117 DO BMES^XPDUTL("Total records processed: "_TOTCNT)
+118 DO BMES^XPDUTL("Total records updated: "_TOTUPD)
+119 DO BMES^XPDUTL("Total records inactivated: "_TOTINACT)
+120 DO BMES^XPDUTL("Total records inserted: "_TOTNEW)
+121 DO BMES^XPDUTL("Total records in error: "_AUMERR)
+122 DO BMES^XPDUTL("Local records skipped: "_AUMSKIP)
+123 QUIT
KILL ;kill "B" and "C" cross-references
+1 KILL ^AUTTEDT("B")
+2 KILL ^AUTTEDT("C")
+3 QUIT
+4 ;
POST ;call to ENALL^DIK for .01 and 1
+1 WRITE !,"Rebuilding Indexes",!
+2 SET DIK="^AUTTEDT("
+3 SET DIK(1)=".01^B"
+4 DO ENALL^DIK
+5 SET DIK(1)="1^C"
+6 DO ENALL^DIK
+7 QUIT
INACT ;Check for new inactive records
+1 NEW A,AUMX,AUMDT
+2 SET A=0
SET TOTINACT=0
SET AUMDT=$$DT^XLFDT
+3 FOR
SET A=$ORDER(^AUTTEDT(A))
IF A'?1N.N
QUIT
SET AUMX=$GET(^AUTTEDT(A,0))
Begin DoDot:1
+4 IF $PIECE(AUMX,U,5)'=AUMDT
QUIT
+5 IF '$DATA(TMP("AUM11P1",ADT,"UPDATE",A))
QUIT
+6 SET ^XTMP("AUM11P1",ADT,"INACTIVE",A)=$PIECE(^AUTTEDT(A,0),U,1,2)
+7 SET TOTINACT=TOTINACT+1
+8 QUIT
End DoDot:1
+9 QUIT
PKLST ;Check to see what EHR pick lists might be affected
+1 SET PKNAM=""
SET PK1=0
+2 FOR
SET PK1=$ORDER(^BGOEDTPR(PK1))
IF PK1'?1N.N
QUIT
Begin DoDot:1
+3 SET PK2=""
FOR
SET PK2=$ORDER(^BGOEDTPR(PK1,PK2))
IF PK2'?1N.N
QUIT
Begin DoDot:2
+4 IF PK2=0
SET PKNAM=$PIECE(^BGOEDTPR(PK1,PK2),U,1)
+5 SET PK3=0
FOR
SET PK3=$ORDER(^BGOEDTPR(PK1,PK2,PK3))
IF PK3'?1N.N
QUIT
Begin DoDot:3
+6 SET PXEDT=$PIECE($GET(^BGOEDTPR(PK1,PK2,PK3,0)),U,1)
+7 IF PXEDT'=""
SET ^XTMP("AUM11P1",ADT,"PKLST",PKNAM,PXEDT)=""
+8 QUIT
End DoDot:3
+9 QUIT
End DoDot:2
+10 QUIT
End DoDot:1
+11 QUIT
RPT ;Actually print the report
+1 ;
+2 NEW A,ADT,L,X,DATAX
+3 SET AUMHDR=""
+4 DO EN^AUMDODEV
+5 SET A=0
FOR J=1:1
SET A=$ORDER(^XTMP("AUM11P1",A))
IF A=""
QUIT
SET DATAX(J)=A
+6 SET JNDX=J-1
OPT ;Select which install to report on
+1 IF JNDX>1
Begin DoDot:1
+2 SET DIR(0)="SO^"
+3 SET DIR("L",1)="Which Date Do You Want To Report On:"
+4 SET DIR("L",2)=""
+5 SET A=""
FOR K=1:1
SET A=$ORDER(DATAX(A))
IF A=""
QUIT
SET DIR("L",K+2)=K_" "_DATAX(A)
SET DIR(0)=DIR(0)_K_":"_DATAX(A)_";"
+6 SET L=$LENGTH(DIR(0))
SET L=L-1
+7 SET DIR(0)=$EXTRACT(DIR(0),1,L)
+8 DO ^DIR
IF X="^"
QUIT
+9 SET ADT=DATAX(X)
+10 QUIT
End DoDot:1
+11 IF '$TEST
SET ADT=DATAX(1)
+12 IF '$DATA(ADT)
QUIT
+13 USE IO
+14 SET AUMBM=IOSL-10
+15 IF '$DATA(IO("S"))
IF '$DATA(ZTQUEUED)
IF IO=IO(0)
SET AUMBM=IOSL-4
+16 SET AUMPG=1
SET DIWL=5
SET DIWR=75
SET DIWF="W"
+17 WRITE !!,"**** Patient Education Topic Report for "_ADT_" ****",!!!
+18 WRITE !,"Records that were not loaded due to errors:",!
+19 IF $DATA(^XTMP("AUM11P1",ADT,"ERROR"))
DO RERR
+20 IF '$TEST
WRITE ?15,"No Errors to Report",!
+21 WRITE !!
+22 WRITE !,"Records that were set as Inactive:",!
+23 IF $DATA(^XTMP("AUM11P1",ADT,"INACTIVE"))
DO RINA
+24 IF '$TEST
WRITE ?15,"No Records were made Inactive",!
+25 WRITE !!
+26 WRITE !,"Records that are New:",!
+27 IF $DATA(^XTMP("AUM11P1",ADT,"NEW"))
DO RNEW
+28 IF '$TEST
WRITE ?15,"No New Records were Added",!
+29 WRITE !!
+30 WRITE !,"Local (ICD9) Records that were Skipped:",!
+31 IF $DATA(^XTMP("AUM11P1",ADT,"SKIPPED"))
DO RSKP
+32 IF '$TEST
WRITE ?15,"No Local Records were Skipped",!
+33 WRITE !!
+34 WRITE !,"Records that were Updated:",!
+35 IF $DATA(^XTMP("AUM11P1",ADT,"UPDATE"))
DO RUPD
+36 IF '$TEST
WRITE ?15,"No Records were Updated",!
+37 WRITE !!
+38 IF $DATA(^XTMP("AUM11P1",ADT,"PKLST"))
DO RPKL
+39 IF '$TEST
WRITE ?15,"EHR Not installed or no Pick Lists were Added",!
+40 WRITE !!
+41 ;I $D(^XTMP("AUM11P1",ADT,"MISSING NM")) D RNAM W !!
+42 IF $DATA(^XTMP("AUM11P1",ADT,"MISSING MNE"))
DO RMNE
WRITE !!
+43 ;
+44 SET AUMX=^XTMP("AUM11P1",ADT)
FOR J=2:2:15
WRITE ?15,$PIECE(AUMX,U,J),?30,$PIECE(AUMX,U,J+1),!
+45 WRITE !,"**** End of Patient Education Topic Report for "_ADT_" ****",!
+46 DO END
+47 QUIT
RUPD ;Report on records that were Updated
+1 SET AUMHDR=" EIN Name Mnemonic"
+2 WRITE !,?2,"EIN",?12,"Name",?65,"Mnemonic",!
+3 SET A=""
FOR
SET A=$ORDER(^XTMP("AUM11P1",ADT,"UPDATE",A))
IF A'?1N.N
QUIT
Begin DoDot:1
+4 WRITE ?2,A,?12,$EXTRACT($PIECE(^XTMP("AUM11P1",ADT,"UPDATE",A),U,1),1,50),?65,$EXTRACT($PIECE(^XTMP("AUM11P1",ADT,"UPDATE",A),U,2),1,14)
+5 DO ^DIWW
IF $Y>AUMBM
DO PG
+6 QUIT
End DoDot:1
+7 QUIT
RNEW ;Report on New Records
+1 SET AUMHDR=" Name Mnemonic"
+2 WRITE !,?5,"Name",?65,"Mnemonic",!
+3 SET A=""
FOR
SET A=$ORDER(^XTMP("AUM11P1",ADT,"NEW",A))
IF A=""
QUIT
Begin DoDot:1
+4 WRITE ?5,$EXTRACT($PIECE(^XTMP("AUM11P1",ADT,"NEW",A),U,1),1,55),?65,$EXTRACT($PIECE(^XTMP("AUM11P1",ADT,"NEW",A),U,2),1,14)
+5 DO ^DIWW
IF $Y>AUMBM
DO PG
+6 QUIT
End DoDot:1
+7 QUIT
RSKP ;Report on Skipped Records
+1 SET AUMHDR=" Name Mnemonic"
+2 WRITE !,?5,"Name",?65,"Mnemonic",!
+3 SET A=""
FOR
SET A=$ORDER(^XTMP("AUM11P1",ADT,"SKIPPED",A))
IF A=""
QUIT
Begin DoDot:1
+4 WRITE ?5,$EXTRACT($PIECE(^XTMP("AUM11P1",ADT,"SKIPPED",A),U,1),1,55),?65,$EXTRACT($PIECE(^XTMP("AUM11P1",ADT,"SKIPPED",A),U,2),1,14)
+5 DO ^DIWW
IF $Y>AUMBM
DO PG
+6 QUIT
End DoDot:1
+7 QUIT
RINA ;Report Inactive records
+1 SET AUMHDR=" Name Mnemonic"
+2 WRITE !,?5,"Name",?65,"Mnemonic",!
+3 SET A=""
FOR
SET A=$ORDER(^XTMP("AUM11P1",ADT,"INACTIVE",A))
IF A=""
QUIT
Begin DoDot:1
+4 WRITE ?5,$EXTRACT($PIECE(^XTMP("AUM11P1",ADT,"INACTIVE",A),U,1),1,55),?65,$EXTRACT($PIECE(^XTMP("AUM11P1",ADT,"INACTIVE",A),U,2),1,14)
+5 DO ^DIWW
IF $Y>AUMBM
DO PG
+6 QUIT
End DoDot:1
+7 QUIT
RERR ;Report Errors
+1 SET AUMHDR=" Name Mnemonic"
+2 WRITE !,?5,"Name",?65,"Mnemonic"
+3 SET A=""
FOR
SET A=$ORDER(^XTMP("AUM11P1",ADT,"ERROR",A))
IF A=""
QUIT
Begin DoDot:1
+4 WRITE !,?10,"Error: ",A,!
+5 SET B=0
FOR
SET B=$ORDER(^XTMP("AUM11P1",ADT,"ERROR",A,B))
IF B'?1N.N
QUIT
Begin DoDot:2
+6 WRITE ?5,$EXTRACT($PIECE(^XTMP("AUM11P1",ADT,"ERROR",A,B),U,1),1,55),?65,$EXTRACT($PIECE(^XTMP("AUM11P1",ADT,"ERROR",A,B),U,2),1,14)
+7 DO ^DIWW
IF $Y>AUMBM
DO PG
+8 QUIT
End DoDot:2
+9 QUIT
End DoDot:1
+10 QUIT
RPKL ;Report of pick lists if we have any
+1 ;Pick Lists
+2 SET AUMHDR=" Pick List Name Topic EIN"
+3 WRITE !,"EHR Pick Lists that may have been affected and need Review:",!
+4 WRITE !,?5,"Pick List Name",?65,"Topic EIN",!
+5 SET A=""
FOR
SET A=$ORDER(^XTMP("AUM11P1",ADT,"PKLST",A))
IF A=""
QUIT
Begin DoDot:1
+6 WRITE ?5,$EXTRACT(A,1,50)
+7 SET B=0
FOR
SET B=$ORDER(^XTMP("AUM11P1",ADT,"PKLST",A,B))
IF B'?1N.N
QUIT
Begin DoDot:2
+8 WRITE ?65,$EXTRACT(B,1,14),!
+9 DO ^DIWW
IF $Y>AUMBM
DO PG
+10 QUIT
End DoDot:2
+11 WRITE !
+12 QUIT
End DoDot:1
+13 QUIT
RNAM ;Report on Source items that are missing by name
+1 ;Records that are not in AUTTEDT, but should be
+2 WRITE !,"Records that were not updated, by Name",!
+3 SET AUMHDR=" Name"
+4 WRITE !,?5,"Name",!
+5 SET A=""
FOR
SET A=$ORDER(^XTMP("AUM11P1",ADT,"MISSING NM",A))
IF A=""
QUIT
Begin DoDot:1
+6 WRITE ?5,$EXTRACT($PIECE(A,U,1),1,55)
+7 DO ^DIWW
IF $Y>AUMBM
DO PG
+8 QUIT
End DoDot:1
+9 QUIT
RMNE ;Report on Source items that are missing by Mnemonic
+1 ;Records that were not updated in AUTTEDT, but should be
+2 WRITE !,"Records that were not updated, by Mnemonic",!
+3 SET AUMHDR=" Mnemonic"
+4 WRITE !,?5,"Mnemonic",!
+5 SET A=""
FOR
SET A=$ORDER(^XTMP("AUM11P1",ADT,"MISSING MNE",A))
IF A=""
QUIT
Begin DoDot:1
+6 WRITE ?5,$EXTRACT($PIECE(A,U,1),1,55)
+7 DO ^DIWW
IF $Y>AUMBM
DO PG
+8 QUIT
End DoDot:1
+9 QUIT
END ;EP
+1 WRITE !!!
+2 IF IO(0)=IO
Begin DoDot:1
+3 IF IOST["C-"
IF '$DATA(IO("S"))
SET Y=$$DIR^XBDIR("E","Press RETURN To Continue or Escape to Cancel...","","","",1)
XECUTE ^%ZOSF("TRMRD")
+4 DO ^DIWW
+5 QUIT
End DoDot:1
END1 ;
+1 DO ^%ZISC
+2 QUIT
PG ; --- Paginate, write header
+1 IF IOST["C-"
IF '$DATA(IO("S"))
SET Y=$$DIR^XBDIR("E","Press RETURN To Continue or Escape to Cancel...","","","",1)
XECUTE ^%ZOSF("TRMRD")
+2 SET AUMPG=AUMPG+1
+3 WRITE @IOF,!!!?DIWL-1,?($SELECT($GET(IOM):IOM,1:75)-$LENGTH("Page "_AUMPG)),"Page ",AUMPG,!!,AUMHDR,!
+4 QUIT
+5 ;
FBADNAM ;Find all missing names
+1 NEW A,B,X,MN
+2 SET TNMISS=0
+3 SET A=""
FOR
SET A=$ORDER(^AUMPCLN(A))
IF A=""
QUIT
SET X=^(A)
SET MN=$PIECE(X,U,2)
SET B=""
SET B=$ORDER(^AUTTEDT("B",MN,B))
IF B=""
SET ^XTMP("AUM11P1",ADT,"MISSING NM",MN)=""
SET TNMISS=TNMISS+1
+4 QUIT
FBADMN ;Find all missing Mnemonics
+1 NEW A,B,X,MN
+2 SET TMNMISS=0
+3 SET A=""
FOR
SET A=$ORDER(^AUMPCLN(A))
IF A=""
QUIT
SET X=^(A)
SET MN=$PIECE(X,U,3)
SET B=""
SET B=$ORDER(^AUTTEDT("C",MN,B))
IF B=""
SET ^XTMP("AUM11P1",ADT,"MISSING MNE",MN)=""
SET TMNMISS=TMNMISS+1
+4 QUIT
RTRIM(X) ;Strip off trailing spaces
+1 FOR %=$LENGTH(X):-1:1
IF $ASCII(X,%)=32
SET X=$EXTRACT(X,0,%-1)
+2 QUIT
+3 ;end of routine AUMUPD102
