AUM4101 ;TASSC/MFD - SCB UPDATE 10/31/2003 [ 11/25/2003 12:43 PM ]
;;04.1;TABLE MAINTENANCE;**1**;OCT 31,2003
;
ENV ;----- ENVIRONMENT CHECK
;
D ^XBKVAR
D HOME^%ZIS
;
K XPDQUIT
;
D DUZ(.DUZ,.XPDQUIT)
Q:$D(XPDQUIT)
;
D HELLO(DUZ)
;
; Check for required versons and patches
;
I $$VCHK("XU","8.0",2,"<")
I $$VCHK("DI","21.0",2,"<")
I $$VCHK("AUM","4.1",2,"'=")
I $$VCHK("AUT","98.1",2,"'=")
I $$PCHK("AUT","98.1",13,2,"<")
Q:$D(XPDQUIT)
;
D CKPKG(.XPDQUIT) ;Check for dupes in package file
;
D OK(.XPDQUIT)
Q:$D(XPDQUIT)
;
D HELP^XBHELP("INTROE","AUM4101")
;
D XPZ
;
I '$$DIR^XBDIR("E","","","","","",1) D SORRY(3,.XPDQUIT)
;
Q
;
DUZ(DUZ,XPDQUIT) ;
;----- CHECK FOR VALID DUZ
;
I '$G(DUZ) D
. W !,"DUZ UNDEFINED OR 0"
. D SORRY(2,.XPDQUIT)
I '$L($G(DUZ(0))) D
. W !,"DUZ(0) UNDEFINED OR NULL"
. D SORRY(2,.XPDQUIT)
Q
HELLO(DUZ) ;
;----- DISPLAY GREETING
;
N X
S X=$P($G(^VA(200,DUZ,0)),U)
W !!,$$CJ^XLFSTR("Hello, "_$P(X,",",2)_" "_$P(X,","),IOM)
W !!,$$CJ^XLFSTR("Checking Environment for "_$P($T(+2),";",4)_" V "_$P($T(+2),";",3)_" Patch "_$P($T(+2),";",5)_".",IOM)
Q
CKPKG(XPDQUIT) ;
;----- CHECK PACKAGE FILE FOR DUPLICATE ENTRY
;
N D,DIC,X,Y
S X="AUM"
S DIC="^DIC(9.4,"
S DIC(0)=""
S D="C"
D IX^DIC
I Y<0,$D(^DIC(9.4,"C","AUM")) D
. W !!,*7,*7,$$CJ^XLFSTR("You have more than one entry in the",IOM)
. W !,$$CJ^XLFSTR("PACKAGE file with an ""AUM"" prefix.",IOM)
. W !,$$CJ^XLFSTR("One entry needs to be deleted.",IOM)
. S XPDQUIT=2
Q
XPZ ;----- SET XPDDIQ ARRAY TO KEEP KIDS FROM ASKING DISABLE AND CPU
; MOVE QUESTIONS
I $G(XPDENV)=1 D
. S (XPDDIQ("XPZ1"))=0
. S (XPDDIQ("XPZ2"))=0
. D HELP^XBHELP("INTROI","AUM4101")
Q
OK(XPDQUIT) ;
;----- ISSUE OK MESSAGE
;
I $D(XPDQUIT) D Q
. W !,$$CJ^XLFSTR("FIX IT! Before Proceeding",IOM),!!,*7,*7,*7
W !!,$$CJ^XLFSTR("ENVIRONMENT OK",IOM)
Q
SORRY(X,XPDQUIT) ;
K DIFQ
I X=3 S XPDQUIT=2 Q
S XPDQUIT=X
W *7,!,$$CJ^XLFSTR("Sorry....FIX IT!",IOM)
Q
;
VCHK(AUMPRE,AUMVER,AUMQUIT,AUMCOMP) ;
;----- CHECK VERSIONS NEEDED
;
N AUMV
S AUMV=$$VERSION^XPDUTL(AUMPRE)
W !,$$CJ^XLFSTR("Need "_$S(AUMCOMP="<":"at least ",1:"")_AUMPRE_" v "_AUMVER_"....."_AUMPRE_" v "_AUMV_" Present",IOM)
I @(+AUMV_AUMCOMP_AUMVER) D SORRY(AUMQUIT) Q 0
Q 1
;
PCHK(AUMPRE,AUMVER,AUMPAT,AUMQUIT,AUMCOMP) ;
;----- CHECK PATCHES NEEDED
N AUMV,AUMX
S AUMV=AUMPRE_"*"_AUMVER_"*"_AUMPAT
S AUMX=$$PATCH^XPDUTL(AUMV)
W !,$$CJ^XLFSTR("Need "_$S(AUMCOMP="<":"at least ",1:"")_AUMV_"....."_$S(AUMX:" Present",1:" NOT Present"),IOM)
I 'AUMX D SORRY(AUMQUIT) Q 0
Q 1
;
POST ;EP -- POST INSTALL FROM KIDS
;
I ^DD(9999999.03,.01,1,1,1)["1,40)," D BINDEX
K ^TMP("AUM4101",$J)
D AUDS
D START^AUM41011
D AUDR
D MAIL
;D QUE ;this deletes the routines from this update
Q
MAIL ;----- SEND EMAIL
;
K ^TMP("AUM4101",$J)
N DIFROM,XMSUB,XMDUZ,XMTEXT,XMY
D MES^XPDUTL("BEGIN Delivering MailMan message to select users...")
D RSLT^AUM41011(" --- AUM v 4.1, Patch 1, has been installed ---")
F %=1:1 D RSLT^AUM41011($P($T(GREET+%),";",3)) Q:$P($T(GREET+%+1),";",3)="###"
S %=0
F S %=$O(^XTMP("XPDI",XPDA,"BLD",XPDBLD,1,%)) Q:'% D RSLT^AUM41011(^(%,0))
S XMSUB=$P($P($T(+1),";",2)," ",3,99),XMDUZ=$G(DUZ,.5),XMTEXT="^TMP(""AUM4101"",$J,",XMY(1)="",XMY(DUZ)=""
F %="XUMGR","XUPROG","XUPROGMODE","AGZBILL","ABMDZ TABLE MAINTENANCE","APCCZMGR" D SINGLE(%)
D ^XMD
K ^TMP("AUM4101",$J)
D MES^XPDUTL("END Delivering MailMan message to select users...")
Q
;
QUE ;----- QUEUE ROUTINE DELETION
;
N X,Y,ZTDESC,ZTDTH,ZTIO,ZTPRI,ZTREQ,ZTRTN,ZTSK
I $D(ZTQUEUED) S ZTREQ="@"
Q:'$L($T(+1^AUMDELR))
S ZTRTN="DEL^AUMDELR(""AUM4101"")"
S ZTDESC="Delete routines in the 'AUM4101' namespace"
S ZTDTH=$$HADD^XLFDT($H,0,0,30,0)
S ZTIO=""
S ZTPRI=1
D ^%ZTLOAD
I '$D(ZTSK) D Q
. D BMES^XPDUTL("Q to TaskMan to delete routines in background failed (?)")
D BMES^XPDUTL("NOTE: The routines in this update will be deleted in the background")
D BMES^XPDUTL("30 minutes from now by Task #"_ZTSK)
Q
SINGLE(K) ;
;----- GET HOLDERS OF A SINGLE KEY K, PUT IN XMY ARRAY
;
N Y
S Y=0
Q:'$D(^XUSEC(K))
F S Y=$O(^XUSEC(K,Y)) Q:'Y S XMY(Y)=""
Q
AUDS ;----- SAVE CURRENT SETTINGS AND SET DATA AUDITING 'ON'
;
; NOTE:
; Data auditing at the file level is indicated by a lower case "a"
; in the 2nd piece of the 0th node of the global.
; Data auditing at the field level is indicated by a lower case "a"
; in the 2nd piece of the 0th node of the field definition in ^DD(.
;
S ^XTMP("AUM4101",0)=$$FMADD^XLFDT(DT,56)_"^"_DT_"^"_"**ADD DATE** STANDARD TABLE UPDATES"
N G,P
F %=1:1 S G=$P($T(AUD+%),";",3) Q:G="END" D
. S P=$P(@(G_"0)"),"^",2)
. I '$D(^XTMP("AUM4101",G)) S ^XTMP("AUM4101",G)=P
. S:'(P["a") $P(@(G_"0)"),"^",2)=P_"a"
. D AUDF(+P)
Q
AUDF(F) ;----- PROCESS ALL FIELDS FOR FILE 4, INCLUDING SUB-FILES
;
N D,P
S D=0
F S D=$O(^DD(F,D)) Q:'D D
. I $P(^DD(F,D,0),U,2) D AUDF(+$P(^(0),U,2)) Q
. S P=$P(^DD(F,D,0),U,2),G="^DD("_F_","_D_","
. I '$D(^XTMP("AUM4101",G)) S ^XTMP("AUM4101",G)=P
. I '$D(^XTMP("AUM4101",G,"AUDIT")) S ^XTMP("AUM4101",G,"AUDIT")=$G(@(G_"""AUDIT"")"))
. S:'(P["a") $P(@(G_"0)"),"^",2)=P_"a"
. S ^DD(F,D,"AUDIT")="y"
Q
AUDR ;----- RESTORE THE FILE DATA AUDIT VALUES TO THEIR ORIGINAL VALUES
;
N G,P
S G=0
F S G=$O(^XTMP("AUM4101",G)) Q:'$L(G) D
. S $P(@(G_"0)"),"^",2)=^XTMP("AUM4101",G)
. Q:'(G["^DD(")
. S (@(G_"""AUDIT"")"))=^XTMP("AUM4101",G,"AUDIT")
. K:@(G_"""AUDIT"")")="" @(G_"""AUDIT"")")
Q
AUD ;----- THESE ARE FILES TO BE DATA AUDITED FOR THIS PATCH ONLY
;;^AUTTEXAM(
;;^AUTTTRI(
;;^AUTTEDPF(
;;^AUTTAREA(
;;^AUTTCOM(
;;^AUTTCTY(
;;^AUTTHF(
;;^AUTTLOC(
;;^AUTTMSR(
;;^AUTTSU(
;;^DIC(7,
;;^DIC(40.7,
;;END
Q
AUDPRT ;----- PRINT FROM AUDIT FILE
;
N BY,DIC,FLDS,X,Y
Q:$D(ZTQUEUED)
W !,"*** Print from the AUDIT file."
S DIC=1
S DIC("A")="Select the file from which you want to print the data AUDIT: "
S DIC(0)="A"
D ^DIC
Q:+Y<1
S DIC="^DIA("_+Y_","
S FLDS="[CAPTIONED]"
S BY=.02
D EN1^DIP
Q
INTROE ;----- INTRO TEXT DURING KIDS ENVIRONMENT CHECK
;;This distribution:
;;(1) Implements SCB mods for the past several months
;;(2) New entry into EXAM file- INT PARTNER VIOLENCE SCREEN
;;(3) New entries into HEALTH FACTORS
;;(4) New PROVIDER CLASS added - PHARMACY TECHNICIAN
;;(5) Several new entries to the CLINIC STOP file
;;###
;
INTROI ;----- INTRO TEXT DURING KIDS INSTALL
;;A standard message will be produced by this update.
;;
;;If you run interactively, results will be displayed on your screen,
;;as well as in the mail message and the entry in the INSTALL file.
;;If you queue to TaskMan, please read the mail message for results of
;;this update, and remember not to Q to the HOME device.
;;###
;
GREET ;;EP - TO ADD TO MAIL MESSAGE
;;
;;Greetings.
;;
;;Standard tables on your RPMS system have been updated.
;;
;;You are receiving this message because of the particular RPMS
;;security keys that you hold. This is for your information, only.
;;You need do nothing in response to this message.
;;
;;Requests for modifications or additions to RPMS standard tables,
;;whether they are or are not contained in the IHS Standard Code
;;Book (SCB), can be submitted to your Area Information System
;;Coordinator (ISC).
;;
;;Sections of the IHS Standard Code Book (SCB) can be viewed, printed,
;;and extracted from the NPIRS Intranet website at url:
;; http://dpsntweb1.hqw.DOMAIN.NAME/ciweb/main.html
;;
;;Questions about this patch, which is a product of the RPMS DBA
;;can be directed to the Help Desk,
;;". Please
;;refer to patch "AUM*4.1*1".
;;
;;###;NOTE: This line indicates the end of text in this message.
;
BINDEX ;
K ^AUTTTRI("B")
S ^DD(9999999.03,.01,1,1,1)="S ^AUTTTRI(""B"",$E(X,1,30),DA)="""""
S ^DD(9999999.03,.01,1,1,2)="K ^AUTTTRI(""B"",$E(X,1,30),DA)"
S DIK="^AUTTTRI(",DIK(1)=".01^B" D ENALL^DIK
Q
AUM4101 ;TASSC/MFD - SCB UPDATE 10/31/2003 [ 11/25/2003 12:43 PM ]
+1 ;;04.1;TABLE MAINTENANCE;**1**;OCT 31,2003
+2 ;
ENV ;----- ENVIRONMENT CHECK
+1 ;
+2 DO ^XBKVAR
+3 DO HOME^%ZIS
+4 ;
+5 KILL XPDQUIT
+6 ;
+7 DO DUZ(.DUZ,.XPDQUIT)
+8 IF $DATA(XPDQUIT)
QUIT
+9 ;
+10 DO HELLO(DUZ)
+11 ;
+12 ; Check for required versons and patches
+13 ;
+14 IF $$VCHK("XU","8.0",2,"<")
+15 IF $$VCHK("DI","21.0",2,"<")
+16 IF $$VCHK("AUM","4.1",2,"'=")
+17 IF $$VCHK("AUT","98.1",2,"'=")
+18 IF $$PCHK("AUT","98.1",13,2,"<")
+19 IF $DATA(XPDQUIT)
QUIT
+20 ;
+21 ;Check for dupes in package file
DO CKPKG(.XPDQUIT)
+22 ;
+23 DO OK(.XPDQUIT)
+24 IF $DATA(XPDQUIT)
QUIT
+25 ;
+26 DO HELP^XBHELP("INTROE","AUM4101")
+27 ;
+28 DO XPZ
+29 ;
+30 IF '$$DIR^XBDIR("E","","","","","",1)
DO SORRY(3,.XPDQUIT)
+31 ;
+32 QUIT
+33 ;
DUZ(DUZ,XPDQUIT) ;
+1 ;----- CHECK FOR VALID DUZ
+2 ;
+3 IF '$GET(DUZ)
Begin DoDot:1
+4 WRITE !,"DUZ UNDEFINED OR 0"
+5 DO SORRY(2,.XPDQUIT)
End DoDot:1
+6 IF '$LENGTH($GET(DUZ(0)))
Begin DoDot:1
+7 WRITE !,"DUZ(0) UNDEFINED OR NULL"
+8 DO SORRY(2,.XPDQUIT)
End DoDot:1
+9 QUIT
HELLO(DUZ) ;
+1 ;----- DISPLAY GREETING
+2 ;
+3 NEW X
+4 SET X=$PIECE($GET(^VA(200,DUZ,0)),U)
+5 WRITE !!,$$CJ^XLFSTR("Hello, "_$PIECE(X,",",2)_" "_$PIECE(X,","),IOM)
+6 WRITE !!,$$CJ^XLFSTR("Checking Environment for "_$PIECE($TEXT(+2),";",4)_" V "_$PIECE($TEXT(+2),";",3)_" Patch "_$PIECE($TEXT(+2),";",5)_".",IOM)
+7 QUIT
CKPKG(XPDQUIT) ;
+1 ;----- CHECK PACKAGE FILE FOR DUPLICATE ENTRY
+2 ;
+3 NEW D,DIC,X,Y
+4 SET X="AUM"
+5 SET DIC="^DIC(9.4,"
+6 SET DIC(0)=""
+7 SET D="C"
+8 DO IX^DIC
+9 IF Y<0
IF $DATA(^DIC(9.4,"C","AUM"))
Begin DoDot:1
+10 WRITE !!,*7,*7,$$CJ^XLFSTR("You have more than one entry in the",IOM)
+11 WRITE !,$$CJ^XLFSTR("PACKAGE file with an ""AUM"" prefix.",IOM)
+12 WRITE !,$$CJ^XLFSTR("One entry needs to be deleted.",IOM)
+13 SET XPDQUIT=2
End DoDot:1
+14 QUIT
XPZ ;----- SET XPDDIQ ARRAY TO KEEP KIDS FROM ASKING DISABLE AND CPU
+1 ; MOVE QUESTIONS
+2 IF $GET(XPDENV)=1
Begin DoDot:1
+3 SET (XPDDIQ("XPZ1"))=0
+4 SET (XPDDIQ("XPZ2"))=0
+5 DO HELP^XBHELP("INTROI","AUM4101")
End DoDot:1
+6 QUIT
OK(XPDQUIT) ;
+1 ;----- ISSUE OK MESSAGE
+2 ;
+3 IF $DATA(XPDQUIT)
Begin DoDot:1
+4 WRITE !,$$CJ^XLFSTR("FIX IT! Before Proceeding",IOM),!!,*7,*7,*7
End DoDot:1
QUIT
+5 WRITE !!,$$CJ^XLFSTR("ENVIRONMENT OK",IOM)
+6 QUIT
SORRY(X,XPDQUIT) ;
+1 KILL DIFQ
+2 IF X=3
SET XPDQUIT=2
QUIT
+3 SET XPDQUIT=X
+4 WRITE *7,!,$$CJ^XLFSTR("Sorry....FIX IT!",IOM)
+5 QUIT
+6 ;
VCHK(AUMPRE,AUMVER,AUMQUIT,AUMCOMP) ;
+1 ;----- CHECK VERSIONS NEEDED
+2 ;
+3 NEW AUMV
+4 SET AUMV=$$VERSION^XPDUTL(AUMPRE)
+5 WRITE !,$$CJ^XLFSTR("Need "_$SELECT(AUMCOMP="<":"at least ",1:"")_AUMPRE_" v "_AUMVER_"....."_AUMPRE_" v "_AUMV_" Present",IOM)
+6 IF @(+AUMV_AUMCOMP_AUMVER)
DO SORRY(AUMQUIT)
QUIT 0
+7 QUIT 1
+8 ;
PCHK(AUMPRE,AUMVER,AUMPAT,AUMQUIT,AUMCOMP) ;
+1 ;----- CHECK PATCHES NEEDED
+2 NEW AUMV,AUMX
+3 SET AUMV=AUMPRE_"*"_AUMVER_"*"_AUMPAT
+4 SET AUMX=$$PATCH^XPDUTL(AUMV)
+5 WRITE !,$$CJ^XLFSTR("Need "_$SELECT(AUMCOMP="<":"at least ",1:"")_AUMV_"....."_$SELECT(AUMX:" Present",1:" NOT Present"),IOM)
+6 IF 'AUMX
DO SORRY(AUMQUIT)
QUIT 0
+7 QUIT 1
+8 ;
POST ;EP -- POST INSTALL FROM KIDS
+1 ;
+2 IF ^DD(9999999.03,.01,1,1,1)["1,40),"
DO BINDEX
+3 KILL ^TMP("AUM4101",$JOB)
+4 DO AUDS
+5 DO START^AUM41011
+6 DO AUDR
+7 DO MAIL
+8 ;D QUE ;this deletes the routines from this update
+9 QUIT
MAIL ;----- SEND EMAIL
+1 ;
+2 KILL ^TMP("AUM4101",$JOB)
+3 NEW DIFROM,XMSUB,XMDUZ,XMTEXT,XMY
+4 DO MES^XPDUTL("BEGIN Delivering MailMan message to select users...")
+5 DO RSLT^AUM41011(" --- AUM v 4.1, Patch 1, has been installed ---")
+6 FOR %=1:1
DO RSLT^AUM41011($PIECE($TEXT(GREET+%),";",3))
IF $PIECE($TEXT(GREET+%+1),";",3)="###"
QUIT
+7 SET %=0
+8 FOR
SET %=$ORDER(^XTMP("XPDI",XPDA,"BLD",XPDBLD,1,%))
IF '%
QUIT
DO RSLT^AUM41011(^(%,0))
+9 SET XMSUB=$PIECE($PIECE($TEXT(+1),";",2)," ",3,99)
SET XMDUZ=$GET(DUZ,.5)
SET XMTEXT="^TMP(""AUM4101"",$J,"
SET XMY(1)=""
SET XMY(DUZ)=""
+10 FOR %="XUMGR","XUPROG","XUPROGMODE","AGZBILL","ABMDZ TABLE MAINTENANCE","APCCZMGR"
DO SINGLE(%)
+11 DO ^XMD
+12 KILL ^TMP("AUM4101",$JOB)
+13 DO MES^XPDUTL("END Delivering MailMan message to select users...")
+14 QUIT
+15 ;
QUE ;----- QUEUE ROUTINE DELETION
+1 ;
+2 NEW X,Y,ZTDESC,ZTDTH,ZTIO,ZTPRI,ZTREQ,ZTRTN,ZTSK
+3 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+4 IF '$LENGTH($TEXT(+1^AUMDELR))
QUIT
+5 SET ZTRTN="DEL^AUMDELR(""AUM4101"")"
+6 SET ZTDESC="Delete routines in the 'AUM4101' namespace"
+7 SET ZTDTH=$$HADD^XLFDT($HOROLOG,0,0,30,0)
+8 SET ZTIO=""
+9 SET ZTPRI=1
+10 DO ^%ZTLOAD
+11 IF '$DATA(ZTSK)
Begin DoDot:1
+12 DO BMES^XPDUTL("Q to TaskMan to delete routines in background failed (?)")
End DoDot:1
QUIT
+13 DO BMES^XPDUTL("NOTE: The routines in this update will be deleted in the background")
+14 DO BMES^XPDUTL("30 minutes from now by Task #"_ZTSK)
+15 QUIT
SINGLE(K) ;
+1 ;----- GET HOLDERS OF A SINGLE KEY K, PUT IN XMY ARRAY
+2 ;
+3 NEW Y
+4 SET Y=0
+5 IF '$DATA(^XUSEC(K))
QUIT
+6 FOR
SET Y=$ORDER(^XUSEC(K,Y))
IF 'Y
QUIT
SET XMY(Y)=""
+7 QUIT
AUDS ;----- SAVE CURRENT SETTINGS AND SET DATA AUDITING 'ON'
+1 ;
+2 ; NOTE:
+3 ; Data auditing at the file level is indicated by a lower case "a"
+4 ; in the 2nd piece of the 0th node of the global.
+5 ; Data auditing at the field level is indicated by a lower case "a"
+6 ; in the 2nd piece of the 0th node of the field definition in ^DD(.
+7 ;
+8 SET ^XTMP("AUM4101",0)=$$FMADD^XLFDT(DT,56)_"^"_DT_"^"_"**ADD DATE** STANDARD TABLE UPDATES"
+9 NEW G,P
+10 FOR %=1:1
SET G=$PIECE($TEXT(AUD+%),";",3)
IF G="END"
QUIT
Begin DoDot:1
+11 SET P=$PIECE(@(G_"0)"),"^",2)
+12 IF '$DATA(^XTMP("AUM4101",G))
SET ^XTMP("AUM4101",G)=P
+13 IF '(P["a")
SET $PIECE(@(G_"0)"),"^",2)=P_"a"
+14 DO AUDF(+P)
End DoDot:1
+15 QUIT
AUDF(F) ;----- PROCESS ALL FIELDS FOR FILE 4, INCLUDING SUB-FILES
+1 ;
+2 NEW D,P
+3 SET D=0
+4 FOR
SET D=$ORDER(^DD(F,D))
IF 'D
QUIT
Begin DoDot:1
+5 IF $PIECE(^DD(F,D,0),U,2)
DO AUDF(+$PIECE(^(0),U,2))
QUIT
+6 SET P=$PIECE(^DD(F,D,0),U,2)
SET G="^DD("_F_","_D_","
+7 IF '$DATA(^XTMP("AUM4101",G))
SET ^XTMP("AUM4101",G)=P
+8 IF '$DATA(^XTMP("AUM4101",G,"AUDIT"))
SET ^XTMP("AUM4101",G,"AUDIT")=$GET(@(G_"""AUDIT"")"))
+9 IF '(P["a")
SET $PIECE(@(G_"0)"),"^",2)=P_"a"
+10 SET ^DD(F,D,"AUDIT")="y"
End DoDot:1
+11 QUIT
AUDR ;----- RESTORE THE FILE DATA AUDIT VALUES TO THEIR ORIGINAL VALUES
+1 ;
+2 NEW G,P
+3 SET G=0
+4 FOR
SET G=$ORDER(^XTMP("AUM4101",G))
IF '$LENGTH(G)
QUIT
Begin DoDot:1
+5 SET $PIECE(@(G_"0)"),"^",2)=^XTMP("AUM4101",G)
+6 IF '(G["^DD(")
QUIT
+7 SET (@(G_"""AUDIT"")"))=^XTMP("AUM4101",G,"AUDIT")
+8 IF @(G_"""AUDIT"")")=""
KILL @(G_"""AUDIT"")")
End DoDot:1
+9 QUIT
AUD ;----- THESE ARE FILES TO BE DATA AUDITED FOR THIS PATCH ONLY
+1 ;;^AUTTEXAM(
+2 ;;^AUTTTRI(
+3 ;;^AUTTEDPF(
+4 ;;^AUTTAREA(
+5 ;;^AUTTCOM(
+6 ;;^AUTTCTY(
+7 ;;^AUTTHF(
+8 ;;^AUTTLOC(
+9 ;;^AUTTMSR(
+10 ;;^AUTTSU(
+11 ;;^DIC(7,
+12 ;;^DIC(40.7,
+13 ;;END
+14 QUIT
AUDPRT ;----- PRINT FROM AUDIT FILE
+1 ;
+2 NEW BY,DIC,FLDS,X,Y
+3 IF $DATA(ZTQUEUED)
QUIT
+4 WRITE !,"*** Print from the AUDIT file."
+5 SET DIC=1
+6 SET DIC("A")="Select the file from which you want to print the data AUDIT: "
+7 SET DIC(0)="A"
+8 DO ^DIC
+9 IF +Y<1
QUIT
+10 SET DIC="^DIA("_+Y_","
+11 SET FLDS="[CAPTIONED]"
+12 SET BY=.02
+13 DO EN1^DIP
+14 QUIT
INTROE ;----- INTRO TEXT DURING KIDS ENVIRONMENT CHECK
+1 ;;This distribution:
+2 ;;(1) Implements SCB mods for the past several months
+3 ;;(2) New entry into EXAM file- INT PARTNER VIOLENCE SCREEN
+4 ;;(3) New entries into HEALTH FACTORS
+5 ;;(4) New PROVIDER CLASS added - PHARMACY TECHNICIAN
+6 ;;(5) Several new entries to the CLINIC STOP file
+7 ;;###
+8 ;
INTROI ;----- INTRO TEXT DURING KIDS INSTALL
+1 ;;A standard message will be produced by this update.
+2 ;;
+3 ;;If you run interactively, results will be displayed on your screen,
+4 ;;as well as in the mail message and the entry in the INSTALL file.
+5 ;;If you queue to TaskMan, please read the mail message for results of
+6 ;;this update, and remember not to Q to the HOME device.
+7 ;;###
+8 ;
GREET ;;EP - TO ADD TO MAIL MESSAGE
+1 ;;
+2 ;;Greetings.
+3 ;;
+4 ;;Standard tables on your RPMS system have been updated.
+5 ;;
+6 ;;You are receiving this message because of the particular RPMS
+7 ;;security keys that you hold. This is for your information, only.
+8 ;;You need do nothing in response to this message.
+9 ;;
+10 ;;Requests for modifications or additions to RPMS standard tables,
+11 ;;whether they are or are not contained in the IHS Standard Code
+12 ;;Book (SCB), can be submitted to your Area Information System
+13 ;;Coordinator (ISC).
+14 ;;
+15 ;;Sections of the IHS Standard Code Book (SCB) can be viewed, printed,
+16 ;;and extracted from the NPIRS Intranet website at url:
+17 ;; http://dpsntweb1.hqw.DOMAIN.NAME/ciweb/main.html
+18 ;;
+19 ;;Questions about this patch, which is a product of the RPMS DBA
+20 ;;can be directed to the Help Desk,
+21 ;;". Please
+22 ;;refer to patch "AUM*4.1*1".
+23 ;;
+24 ;;###;NOTE: This line indicates the end of text in this message.
+25 ;
BINDEX ;
+1 KILL ^AUTTTRI("B")
+2 SET ^DD(9999999.03,.01,1,1,1)="S ^AUTTTRI(""B"",$E(X,1,30),DA)="""""
+3 SET ^DD(9999999.03,.01,1,1,2)="K ^AUTTTRI(""B"",$E(X,1,30),DA)"
+4 SET DIK="^AUTTTRI("
SET DIK(1)=".01^B"
DO ENALL^DIK
+5 QUIT
