7:00 PM 16-MAY-2001 AUM v 01.1 Patch 3, SCB Updates 2001May15. Restore 5 routines and DO ^AUM1103. A9AUM3 A9AUM3 ; IHS/RPMSDBA/GTH - STANDARD TABLE UPDATES, 2001MAY15, RPI ; [ 05/16/2001 6:59 PM ] ;;1.1;TABLE MAINTENANCE;**3**;DEC 6,2000 ; D START^AUM1103 DEL ;EP - Delete routines. Q:'$L($G(^%ZOSF("DEL"))) NEW X I $$RSEL^ZIBRSEL("AUM1103*") D D I $$RSEL^ZIBRSEL("A9AUM*") KILL ^TMP("ZIBRSEL",$J,"A9AUM3") ; Don't delete the current routine. D D Q ; D ; S X="" F S X=$O(^TMP("ZIBRSEL",$J,X)) Q:X="" X ^%ZOSF("DEL") I '$D(ZTQUEUED) W !,X,$E("...........",1,11-$L(X)),"" KILL ^TMP("ZIBRSEL",$J) Q ; AUM1103 AUM1103 ; IHS/RPMSDBA/GTH - STANDARD TABLE UPDATES, 2001MAY15 ; [ 05/16/2001 6:59 PM ] ;;1.1;TABLE MAINTENANCE;**3**;DEC 6,2000 ; I '$G(DUZ) W !,"DUZ UNDEFINED OR ZERO.",! Q D HOME^%ZIS,DT^DICRW,VP,HELP^XBHELP("INTRO","AUM1103") S (DIR(0),DIR("B"))="Y" S DIR("A")="Do you want to queue the update to TaskMan" S DIR("??")="^D HELP^XBHELP(""Q2"",""AUM1103"")" D ^DIR KILL DIR I $D(DIRUT) D HELP^XBHELP("Q2","AUM1103") Q G START:'Y QUE ; S %DT="AERSX",%DT("A")="Requested Start Time: ",%DT("B")="T@2015",%DT(0)="NOW" D ^%DT I Y<1 W !,"QUEUE INFORMATION MISSING - NOT QUEUED" D HELP^XBHELP("Q2","AUM1103") G AUM1103 S X=+Y D H^%DTC S ZTDTH=%H_","_%T,ZTRTN="START^AUM1103",ZTIO="",ZTDESC=$P($P($T(+1),";",2)," ",4,99) D ^%ZTLOAD,HOME^%ZIS I $D(ZTSK) W !!,"QUEUED TO TASK ",ZTSK,!!,"A mail message with the results will be sent to your MailMan 'IN' basket.",! E W !!,*7,"QUEUE UNSUCCESSFUL. RESTART UTILITY." Q ; START ;EP - From Taskman ; NEW XMSUB,XMDUZ,XMTEXT,XMY KILL ^TMP("AUM1103",$J) D START^AUM11031 S XMSUB=$P($P($T(+1),";",2)," ",4,99),XMDUZ=$G(DUZ,.5),XMTEXT="^TMP(""AUM1103"",$J,",XMY(DUZ)="" F %="XUPROGMODE","AG TM MENU","ABMDZ TABLE MAINTENANCE","APCCZMGR" D SINGLE(%) D ^XMD KILL ^TMP("AUM1103",$J) I $D(ZTQUEUED) S ZTREQ="@" G DEL^A9AUM3 W !!,"The results are in your MailMan 'IN' basket.",! I $L($T(DIR^XBDIR)),$$DIR^XBDIR("Y","Want me to delete the routines in this patch","Y") G DEL^A9AUM3 Q ; INTRO ;EP - To write to mail message, too. ;;This updates standard tables according to the changes specified in ;;the message from Joe Herrera, with subject "Standard Code Book ;;modifications", released on Tue, 05/15/2001, and amended on ;;05/16/2001. Please consult that message, and the local RPMS mail ;;message produced by this update. ;; ;;###;NOTE: This line indicates the end of the message. ; Q2 ; ;;Answer "Y" if you want to queue this standard table update to TaskMan. ;;Answer "N" if you want to run this update interactively. ;; ;;If you run interactively, results will be displayed on your screen, ;;as well as in the mail message sent to you and user 1. If you queue ;;to TaskMan, please read the mail message for results of this update. ;;###;NOTE: This line indicates the end of the message. ; HELP(L) ;EP - Display text at label L. W ! F %=1:1 W !?4,$P($T(@L+%),";",3) Q:$P($T(@L+%+1),";",3)="###" Q ; SINGLE(K) ; Get holders of a single key K. NEW Y S Y=0 Q:'$D(^XUSEC(K)) F S Y=$O(^XUSEC(K,Y)) Q:'Y S XMY(Y)="" Q ; VP ; W !?4,"**** AUM Version ",$P($T(+2),";",3)," Patch ",$P($P($T(+2),";",5),"*",3),?65,"****" W !?4,"**** ",$P($P($T(+1),";",2),"-",2),?65,"****" Q ; GREET ;;EP - To add to mail message. ;; ;;Greetings. ;; ;;Standard tables on your RPMS system have been updated. ;; ;;**************************************************************** ;;* NOTE: BEGINNING WITH PATCH 2 TO AUM 01.1, DATA AUDITING IS * ;;* TURNED ON FOR FILES AND FIELDS BEING ADDED TO, OR * ;;* BEING MODIFIED BY THESE AUM UPDATES. DATA AUDITING * ;;* IS RECORDED IN THE "AUDIT" FILE. ENTRIES IN THE * ;;* "AUDIT" FILE RECORD WHO MODIFIED THE DATA, AND IT * ;;* MIGHT APPEAR AS THOUGH WHOMEVER RAN THIS UPDATE * ;;* MODIFIED THE DATA. THIS PORTION OF THIS MESSAGE IS * ;;* NOTIFICATION OF THE ABOVE CONDITION. * ;;**************************************************************** ;; ;;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 reflected in the IHS Standard Code ;;Book (SCB), can be submitted to your Area Information System ;;Coordinator (ISC). ;; ;;Sections of the current IHS SCB can be retrieved from the ;;IntrAnet location: http://dpsntweb1.hqw.ihs.gov/ciweb/main.html ;; ;;Questions about this patch, which is a product of the RPMS DBA, ;;can be directed to the Information Technology Support Center ;;(ITSC) help desk, at 505-248-4371, or via e-mail to ;;"hqwhd@mail.ihs.gov". Please refer to patch "AUM*1.1*3". ;; ;;###;NOTE: This line indicates the end of text in this message. ; AUM11031 AUM11031 ; IHS/RPMSDBA/GTH - STANDARD TABLE UPDATES, 2001MAY15 ; [ 05/16/2001 6:59 PM ] ;;1.1;TABLE MAINTENANCE;**3**;DEC 6,2000 ; Q ; START ;EP ; NEW A,C,DIC,DIE,DINUM,DLAYGO,DR,E,L,M,N,O,P,R,S,T ; D RSLT($J("",5)_$P($T(UPDATE^AUM1103A),";",3)) F %=1:1 D RSLT($P($T(GREET+%^AUM1103),";",3)) Q:$P($T(GREET+%+1^AUM1103),";",3)="###" F %=1:1 D RSLT($P($T(INTRO+%^AUM1103),";",3)) Q:$P($T(INTRO+%+1^AUM1103),";",3)="###" D AUDS,DASH,LOCNEW,DASH,LOCMOD,DASH,COMMNEW,DASH,COMMMOD,DASH,EXAMNEW,DASH,PCLASMOD,DASH,AUDR Q ; ; ----------------------------------------------------- ; ADDOK D RSLT($J("",5)_"Added : "_L) Q ADDFAIL D RSLT($J("",5)_$$M(0)_"ADD FAILED => "_L) Q DASH D RSLT(""),RSLT($$REPEAT^XLFSTR("-",$S($G(IOM):IOM-10,1:70))),RSLT("") Q DIE NEW A,C,E,L,M,N,O,P,R,S,T LOCK +(@(DIE_DA_")")):10 E D RSLT($J("",5)_$$M(0)_"Entry '"_DIE_DA_"' IS LOCKED. NOTIFY PROGRAMMER.") S Y=1 Q D ^DIE LOCK -(@(DIE_DA_")")) KILL DA,DIE,DR Q E(L) Q $P($P($T(@L^AUM1103A),";",3),":",1) IEN(X,%,Y) ; S Y=$O(@(X_"""C"",%,0)")) I 'Y S Y=$$VAL^AUM1103M(X,%) I Y D S:Y<0 Y="" . NEW A,C,L,M,N,O,P,R,S,V,% . S L=Y . I X["AREA" NEW X D RSLT("(Add Missing Area)") D ADDAREA D RSLT("(END Add Missing Area)") Q . I X["SU" NEW X D RSLT("(Add Missing SU)") D ADDSU D RSLT("(END Add Missing SU)") Q . I X["CTY" NEW X D RSLT("(Add Missing County)") D ADDCNTY D RSLT("(END Add Missing County)") Q .Q D:'Y RSLT($J("",5)_$$M(0)_$P(@(X_"0)"),U)_" DOES NOT EXIST => "_%) Q +Y DIK NEW A,C,E,L,M,N,O,P,R,S,T D ^DIK KILL DIK Q FILE NEW A,C,E,L,M,N,O,P,R,S,T K DD,DO S DIC(0)="L" D FILE^DICN KILL DIC Q M(%) Q $S(%=0:"ERROR : ",%=1:"NOT ADDED : ",1:"") MODOK D RSLT($J("",5)_"Changed : "_L) Q RSLT(%) S ^(0)=$G(^TMP("AUM1103",$J,0))+1,^(^(0))=% W:'$D(ZTQUEUED) !,% Q ZEROTH(A,B,C,D,E,F,G,H,I,J,K) ; Return 0th node. A is file #, rest fields. I '$G(A) Q -1 I '$G(B) Q -1 F %=67:1:75 Q:'$G(@($C(%))) S A=+$P(^DD(A,B,0),U,2),B=@($C(%)) I 'A!('B) Q -1 I '$D(^DD(A,B,0)) Q -1 Q U_$P(^DD(A,B,0),U,2) ; ; ----------------------------------------------------- ; 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(. AUDS ; Save current settings, and SET data auditing 'on'. S ^XTMP("AUM11031",0)=$$FMADD^XLFDT(DT,56)_"^"_DT_"^"_"AUM11031 STANDARD TABLE UPDATES" NEW G,P F %=1:1 S G=$P($T(AUD+%),";",3) Q:G="END" D . S P=$P(@(G_"0)"),"^",2) . I '$D(^XTMP("AUM11031",G)) S ^XTMP("AUM11031",G)=P . S:'(P["a") $P(@(G_"0)"),"^",2)=P_"a" . Q:'(G["^DD(") . I '$D(^XTMP("AUM11031",G,"AUDIT")) S ^XTMP("AUM11031",G,"AUDIT")=$G(@(G_"""AUDIT"")")) . S (@(G_"""AUDIT"")"))="y" .Q Q ; AUDR ; Restore the file data audit values to their original values. NEW G,P F %=1:1 S G=$P($T(AUD+%),";",3) Q:G="END" D . S $P(@(G_"0)"),"^",2)=^XTMP("AUM11031",G) . Q:'(G["^DD(") . S (@(G_"""AUDIT"")"))=^XTMP("AUM11031",G,"AUDIT") . K:@(G_"""AUDIT"")")="" @(G_"""AUDIT"")") .Q Q ; AUD ; These are files/fields to be audited for this patch, only. ;;^AUTTAREA( ;;^AUTTSU( ;;^AUTTCTY( ;;^AUTTLOC( ;;^DIC(4, ;;^AUTTCOM( ;;^AUTTEXAM( ;;^DIC(7, ;;^DD(9999999.21,.01, ;;^DD(9999999.21,.02, ;;^DD(9999999.21,.03, ;;^DD(9999999.21,.04, ;;^DD(9999999.22,.01, ;;^DD(9999999.22,.02, ;;^DD(9999999.22,.03, ;;^DD(9999999.22,.04, ;;^DD(9999999.23,.01, ;;^DD(9999999.23,.02, ;;^DD(9999999.23,.03, ;;^DD(9999999.23,.04, ;;^DD(9999999.23,.06, ;;^DD(9999999.06,.01, ;;^DD(9999999.06,.04, ;;^DD(9999999.06,.05, ;;^DD(9999999.06,.07, ;;^DD(9999999.06,.31, ;;^DD(4,.01, ;;^DD(9999999.05,.01, ;;^DD(9999999.05,.02, ;;^DD(9999999.05,.03, ;;^DD(9999999.05,.05, ;;^DD(9999999.05,.06, ;;^DD(9999999.05,.07, ;;^DD(9999999.15,.01, ;;^DD(9999999.15,.02, ;;^DD(9999999.15,.11, ;;^DD(7,.01, ;;^DD(7,1, ;;^DD(7,9999999.01, ;;END ; ; ----------------------------------------------------- ; ADDAREA ; PROGRAMMER NOTE: This s/r is required for every patch. S L=$P(L,";;",2),A=$P(L,U),N=$P(L,U,2),R=$P(L,U,3),C=$P(L,U,4),L=A_" "_N_" "_R_" "_C I $D(^AUTTAREA("B",N)) D RSLT($J("",5)_$$M(1)_"NAME EXISTS => "_N) Q I $D(^AUTTAREA("C",A)) D RSLT($J("",5)_$$M(1)_"CODE EXISTS => "_A) Q S DLAYGO=9999999.21,DIC="^AUTTAREA(",X=N,DIC("DR")=".02///"_A_";.03///"_R_";.04///"_C D FILE,ADDFAIL:Y<0,ADDOK:Y>0 KILL DLAYGO Q ; ; ----------------------------------------------------- ; ADDCNTY ; PROGRAMMER NOTE: This s/r is required for every patch. S L=$P(L,";;",2),S=$P(L,U),C=$P(L,U,2),N=$P(L,U,3),L=S_" "_C_" "_N I $D(^AUTTCTY("C",S_C)) D RSLT($J("",5)_$$M(1)_"CODE EXISTS => "_S_C) Q S P("S")=$$IEN("^DIC(5,",S) Q:'P("S") S DIC="^AUTTCTY(",X=N,DIC("DR")=".02////"_P("S")_";.03///"_C D FILE,ADDFAIL:Y<0,ADDOK:Y>0 Q ; ; ----------------------------------------------------- ; ADDSU ; PROGRAMMER NOTE: This s/r is required for every patch. S L=$P(L,";;",2),A=$P(L,U),S=$P(L,U,2),N=$P(L,U,3),L=A_" "_S_" "_N I $D(^AUTTSU("C",A_S)) D RSLT($J("",5)_$$M(1)_"ASU EXISTS => "_A_S) Q S P=$$IEN("^AUTTAREA(",A) Q:'P S DLAYGO=9999999.22,DIC="^AUTTSU(",X=N,DIC("DR")=".02////"_P_";.03///"_S D FILE,ADDFAIL:Y<0,ADDOK:Y>0 KILL DLAYGO Q ; ; ----------------------------------------------------- LOCNEW ; D RSLT($$E("LOCNEW")) D RSLT($J("",13)_"AA SU FA NAME"_$J("",28)_"PSEUDO") D RSLT($J("",13)_"-- -- -- ----"_$J("",28)_"------") F T=1:1 S L=$T(LOCNEW+T^AUM1103A) Q:$P(L,";",3)="END" D ADDLOC Q ; ADDLOC ; S L=$P(L,";;",2),A=$P(L,U),S=$P(L,U,2),F=$P(L,U,3),N=$P(L,U,4),P=$P(L,U,5) S L=A_" "_S_" "_F_" "_N_$J("",32-$L(N))_P S %=A_S_F,%=$O(^AUTTLOC("C",%,0)) I % D RSLT($J("",5)_$$M(1)_"ASUFAC EXISTS => "_A_S_F) D Q . I $P($G(^AUTTLOC(%,0)),U,21) S DIE="^AUTTLOC(",DA=%,DR=".27///@;.28////"_DT D DIE D:$D(Y) RSLT($J("",5)_$$M(0)_"DELETE INACTIVE DATE FAILED => "_L) D:'$D(Y) RSLT($J("",5)_"INACTIVE DATE DELETED => "_L) . S %=$O(^AUTTLOC("C",A_S_F,0)),%=$P(^AUTTLOC(%,0),U) . I %,$D(^DIC(4,%,0)),N'=$P(^DIC(4,%,0),U) S DIE="^DIC(4,",DA=%,DR=".01///"_N D DIE D:$D(Y) RSLT($J("",5)_$$M(0)_"EDIT INSTITUTION FAILED => "_L) D:'$D(Y) RSLT($J("",5)_"INSTITUTION NAME UPDATED => "_L) . S %=$O(^AUTTLOC("C",A_S_F,0)) . I P'=$P($G(^AUTTLOC(%,1)),U,2) S DIE="^AUTTLOC(",DA=%,DR=".28////"_DT_";.31///"_P D DIE D:$D(Y) RSLT($J("",5)_$$M(0)_"EDIT PSEUDO PREFIX FAILED => "_L) D:'$D(Y) RSLT($J("",5)_"PSEUDO PREFIX UPDATED => "_L) .Q S P("A")=$$IEN("^AUTTAREA(",A) Q:'P("A") S P("S")=$$IEN("^AUTTSU(",A_S) Q:'P("S") F DINUM=+$P(^DIC(4,0),U,3):1 Q:'$D(^DIC(4,DINUM))&('$D(^AUTTLOC(DINUM))) I DINUM>99999 D RSLT($J("",5)_$$M(0)_"DINUM FOR LOC/INSTITUTION TOO BIG. NOTIFY ISC.") Q Q:DINUM>99999 S DLAYGO=4,DIC="^DIC(4,",X=N D FILE KILL DINUM,DLAYGO I Y<0 D RSLT($J("",5)_$$M(0)_"^DIC(4 ADD FAILED => "_L) Q S DINUM=+Y,DLAYGO=9999999.06,DIC="^AUTTLOC(",X=DINUM,DIC("DR")=".04////"_P("A")_";.05////"_P("S")_";.07///"_F_";.28////"_DT_";.31///"_P D FILE,ADDFAIL:Y<0,ADDOK:Y>0 KILL DINUM,DLAYGO Q ; ; ----------------------------------------------------- ; LOCMOD ; D RSLT($$E("LOCMOD")) D RSLT($J("",15)_"AA SU FA NAME"_$J("",28)_"PSEUDO") D RSLT($J("",15)_"-- -- -- ----"_$J("",28)_"------") F T=1:2 S L=$T(LOCMOD+T^AUM1103A) Q:$P(L,";",3)="END" S L("TO")=$T(LOCMOD+T+1^AUM1103A) D . S L=$P(L,U,2,99),A=$P(L,U),S=$P(L,U,2),F=$P(L,U,3) . S P=$O(^AUTTLOC("C",A_S_F,0)) . S L=$P(L("TO"),U,2,99),A=$P(L,U),S=$P(L,U,2),F=$P(L,U,3),N=$P(L,U,4) . I 'P S P=$O(^AUTTLOC("C",A_S_F,0)) I 'P S L=";;"_L D ADDLOC Q . S L=A_" "_S_" "_F_" "_N_$J("",32-$L(N))_$P(L("TO"),U,6) . S P("A")=$$IEN("^AUTTAREA(",A) . Q:'P("A") . S P("S")=$$IEN("^AUTTSU(",A_S) . Q:'P("S") . S DIE="^AUTTLOC(",DA=P,DR=".04////"_P("A")_";.05////"_P("S")_";.07///"_F_";.28////"_DT_";.31///"_$P(L("TO"),U,6) . D DIE . I $D(Y) D RSLT($J("",5)_$$M(0)_"EDIT LOCATION FAILED => "_L) Q . S DIE="^DIC(4,",DA=$P(^AUTTLOC(P,0),U),DR=".01///"_N . D DIE . I $D(Y) D RSLT($J("",5)_$$M(0)_"EDIT INSTITUTION FAILED => "_L) Q . D MODOK .Q ; D DASH D RSLT("Checking Location Code changes to determine export status.") D RSLT("Patient data is not exported if the only change is to the Location NAME.") D RSLT("Location Code changes must be rolled up into the national data repository...") D DASH,RSLT($$LOCMOD^AUMXPORT("AUM1103A")_" patients marked for export because of the Location Code changes.") Q ; ; ----------------------------------------------------- ; COMMNEW ; D RSLT($$E("COMMNEW")) D RSLT($J("",13)_"ST CT COM NAME"_$J("",28)_"AA SU") D RSLT($J("",13)_"-- -- --- ----"_$J("",28)_"-- --") F T=1:1 S L=$T(COMMNEW+T^AUM1103A) Q:$P(L,";",3)="END" D ADDCOMM Q ; ADDCOMM ; S L=$P(L,";;",2),S=$P(L,U),O=$P(L,U,2),C=$P(L,U,3),N=$P(L,U,4),A=$P(L,U,5),V=$P(L,U,6),L=S_" "_O_" "_C_" "_N_$J("",32-$L(N))_A_" "_V I $D(^AUTTCOM("C",S_O_C)) D RSLT($J("",5)_$$M(1)_"STCTYCOM CODE EXISTS => "_S_O_C) Q S P("O")=$$IEN("^AUTTCTY(",S_O) Q:'P("O") S P("A")=$$IEN("^AUTTAREA(",A) Q:'P("A") S P("V")=$$IEN("^AUTTSU(",A_V) Q:'P("V") S DLAYGO=9999999.05,DIC="^AUTTCOM(",X=N,DIC("DR")=".02////"_P("O")_";.05////"_P("V")_";.06////"_P("A")_";.07///"_C D FILE,ADDFAIL:Y<0,ADDOK:Y>0 KILL DLAYGO Q ; ; ----------------------------------------------------- ; COMMMOD ; D RSLT($$E("COMMMOD")) D RSLT($J("",15)_"ST CT COM NAME"_$J("",28)_"AA SU") D RSLT($J("",15)_"-- -- --- ----"_$J("",28)_"-- --") F T=1:2 S L=$T(COMMMOD+T^AUM1103A) Q:$P(L,";",3)="END" S L("TO")=$T(COMMMOD+T+1^AUM1103A) D . S L=$P(L,U,2,99),S=$P(L,U),O=$P(L,U,2),C=$P(L,U,3) . S P=$O(^AUTTCOM("C",S_O_C,0)) . S L=$P(L("TO"),U,2,99),S=$P(L,U),O=$P(L,U,2),C=$P(L,U,3),N=$P(L,U,4),A=$P(L,U,5),V=$P(L,U,6) . I 'P S P=$O(^AUTTCOM("C",S_O_C,0)) I 'P S L=";;"_L D ADDCOMM Q . S L=S_" "_O_" "_C_" "_N_$J("",32-$L(N))_A_" "_V . S P("O")=$$IEN("^AUTTCTY(",S_O) . Q:'P("O") . S P("A")=$$IEN("^AUTTAREA(",A) . Q:'P("A") . S P("V")=$$IEN("^AUTTSU(",A_V) . Q:'P("V") . S DIE="^AUTTCOM(",DA=P,DR=".01///"_N_";.02////"_P("O")_";.05////"_P("V")_";.06////"_P("A")_";.07///"_C . D DIE . I $D(Y) D RSLT($J("",5)_$$M(0)_"CHANGE FAILED => "_L) Q . D MODOK .Q ; D DASH D RSLT("Checking Community Code changes to determine export status.") D RSLT("Patient data is not exported if the only change is to the Commnuity NAME.") D RSLT("Commnity Code changes must be rolled up into the national data repository...") D DASH,RSLT($$COMMMOD^AUMXPORT("AUM1103A")_" patients marked for export because of the Community Code changes.") Q ; ; ----------------------------------------------------- ; EXAMNEW ; D RSLT($$E("EXAMNEW")) D RSLT($J("",13)_"CC NAME"_$J("",26)_"CPT CODE") D RSLT($J("",13)_"-- ----"_$J("",26)_"--------") F T=1:1 S L=$T(EXAMNEW+T^AUM1103A) Q:$P(L,";",3)="END" D ADDEXAM Q ; ADDEXAM ; S L=$P(L,";;",2),C=$P(L,U),N=$P(L,U,2),O=$P(L,U,3),L=C_" "_$E(N_$J("",30),1,29)_" "_O I $D(^AUTTEXAM("C",C)) D RSLT($J("",5)_$$M(1)_"EXAM CODE EXISTS => "_C) Q S DLAYGO=9999999.15,DIC="^AUTTEXAM(",X=N,DIC("DR")=".02///"_C_";.11///"_O D FILE,ADDFAIL:Y<0,ADDOK:Y>0 Q ; ; ----------------------------------------------------- ADDPCLAS ; S L=$P(L,";;",2),C=$P(L,U),N=$P(L,U,2),A=$P(L,U,3),L=C_" "_N_$J("",(32-$L(N)))_A I $D(^DIC(7,"D",C)) D RSLT($J("",5)_$$M(1)_"PROVIDER CODE EXISTS => "_C) Q S DLAYGO=7,DIC="^DIC(7,",X=N,DIC("DR")="1///"_A_";9999999.01///"_C D FILE,ADDFAIL:Y<0,ADDOK:Y>0 Q ; ; ----------------------------------------------------- ; PCLASMOD ; D RSLT($$E("PCLASMOD")) F T=1:2 S L=$T(PCLASMOD+T^AUM1103A) Q:$P(L,";",3)="END" S L("TO")=$T(PCLASMOD+T+1^AUM1103A) D . S L=$P(L,U,2,99),C=$P(L,U),N=$P(L,U,2),A=$P(L,U,3) . S P=$O(^DIC(7,"D",C,0)) . I 'P S L=L("TO") D ADDPCLAS Q . S L=$P(L("TO"),U,2,99),C=$P(L,U),N=$P(L,U,2),A=$P(L,U,3) . S L=C_" "_N_" "_A . S DIE="^DIC(7,",DA=P,DR=".01///"_N_";1///"_A_";9999999.01///"_C . D DIE . I $D(Y) D RSLT($J("",5)_$$M(0)_"EDIT PROVIDER CODE FAILED => "_L) Q . D MODOK .Q Q ; ; ----------------------------------------------------- ; AUM1103A AUM1103A ; IHS/RPMSDBA/GTH - STANDARD TABLE UPDATES, 2001MAY15 ; [ 05/16/2001 6:59 PM ] ;;1.1;TABLE MAINTENANCE;**3**;DEC 6,2000 ; UPDATE ;;IHS STANDARD CODE BOOK MODIFICATIONS - FEB/MAR/APR 2001 05/15/2001 ; LOCNEW ;;A. NEW FACILITY CODES (SECTION VIII-C): AREA^S.U.^FAC.^NAME^PSEUDO ;;10^12^58^PARSHALL^CCH ;;15^37^50^SIOUX CITY^CCF ;;15^37^51^LINCOLN^CCG ;;54^77^81^LIFELINE FOUND NAT AMER PROG^UBI ;;55^62^14^CHICKASAW NATION FAM PRAC CTR^OAH ;;64^50^98^OTHER^LEB ;;65^67^32^GILA RIVER CRIM JUSTICE FAC^XET ;;65^67^98^OTHER^XER ;;66^26^11^POTAWOT HEALTH VILLAGE^LEC ;;66^26^32^FORTUNA^LED ;;66^26^50^WEITCHPEC^LQP ;;80^88^67^WINSLOW MOBILE HLTH SCREENING^NHZ ;;END ; LOCMOD ;;B. FACILITY CODE CHANGES (SECTION VIII-C): AREA^S.U.^FAC.^NAME^PSEUDO ;;FROM^75^73^10^NE MEE POO HEALTH CENTER^POV ;; TO^75^73^10^NIMIIPUU HEALTH CENTER^POV ;;FROM^75^79^82^SEQUIM^PPO ;; TO^75^79^82^JAMESTOWN S'KLALLAM PROGRAM^PPO ;;END ; COMMNEW ;;C. NEW COMMUNITY CODES (SECTION V-C); STATE^CNTY^COMM^NAME^AREA^S.U. ;;26^03^035^SAUGATUCK^18^23 ;;38^51^030^RYDER^10^12 ;;END ; COMMMOD ;;D. COMMUNITY CODES CHANGES (SECTION V-C): STATE^CNTY^COMM^NAME^AREA^S.U. ;;FROM^02^16^026^WARD COVE^30^36 ;; TO^02^10^026^WARD COVE^30^36 ;;FROM^30^55^200^GLENDIVE^40^00 ;; TO^30^55^200^WIBAUX^40^00 ;;END ; EXAMNEW ;;(1) EXAM FILE (FIELD REQUEST): CODE^NAME^CPT CODE ;;32^FOOT EXAM - GENERAL^ ;;33^EYE EXAM - GENERAL^ ;;END ; PCLASMOD ;;(2) SERVICES RENDERED BY (PROVIDER) CODE CHANGES (SECTION XV): CODE^NAME^ABRV ;;FROM^24^CONTRACT OPTOMETRTIST^COP ;; TO^24^CONTRACT OPTOMETRIST^COP ;;END ; AUM1103M AUM1103M ; IHS/RPMSDBA/GTH - BACKGROUND VALUES FOR STANDARD TABLE UPDATES, 2001MAY15 ; [ 05/16/2001 6:59 PM ] ;;1.1;TABLE MAINTENANCE;**3**;DEC 6,2000 ; VAL(X,%,Y) ;EP - return background info. I X["AREA" Q $T(@%) S Y=0 I X["SU" D Q Y . NEW C,T . F C=1:1 S T=$P($T(SU+C),";",3) Q:T="END" I $P(T,U,1,2)=($E(%,1,2)_U_$E(%,3,4)) S Y=1_";;"_T Q .Q I '(X["CTY") Q 0 NEW C,T F C=1:1 S T=$P($T(COUNTY+C),";",3) Q:T="END" I $P(T,U,1,2)=($E(%,1,2)_U_$E(%,3,4)) S Y=1_";;"_T Q Q Y ; AREA ; CODE^NAME^PREFIX/REGION^CAN PREFIX 10 ;;10^ABERDEEN^C^J45 15 ;;15^ABERDEEN TRIBE/638^C^J45 18 ;;18^BEMIDJI NON-IHS^D^J46 30 ;;30^ALASKA^A^J59 40 ;;40^BILLINGS^B^J47 54 ;;54^NASHVILLE URBAN^U^J51 55 ;;55^OKLAHOMA TRIBE/638^O^J50 64 ;;64^CALIFORNIA URBAN^L^J41 65 ;;65^PHOENIX TRIBE/638^X^J40 66 ;;66^CALIFORNIA TRIBE/638^L^J41 75 ;;75^PORTLAND TRIBE/638^P^J64 80 ;;80^NAVAJO^N^J54 ;;END ; SU ; AREA^SU^NAME 1012 ;;10^12^FT BERTHOLD 1537 ;;15^37^NORTHERN PONCA 3036 ;;30^36^MT.EDGECUMBE 4000 ;;40^00^NON SERVICE UNIT 5477 ;;54^77^BALTIMORE 5562 ;;55^62^ADA 6450 ;;64^50^L.A. AMER IND HLTH PROJ 6567 ;;65^67^SACATON 6626 ;;66^26^UIHS-TSURAI 7573 ;;75^73^NORTHERN IDAHO 7579 ;;75^79^NEAH BAY TRIBAL 8088 ;;80^88^WINSLOW ;;END ; COUNTY ; STATE^COUNTY^NAME 0210 ;;02^10^KETCHIKAN GATEWAY BOROUGH 2603 ;;26^03^ALLEGAN 3055 ;;30^55^WIBAUX 3851 ;;38^51^WARD ;;END ;