AUM41032 ;IHS/ITSC/DMJ - SCB UPDATE 2/18/2004 [ 04/01/2004 11:14 AM ]
;;04.1;TABLE MAINTENANCE;**3**;OCT 13,2003
;
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
;
E(L) ;-----
Q $P($P($T(@L^AUM4103A),";",3),":",1)
;
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
;
RSLT(%) ; EP- INCREMENTS/UPDATES ^TMP("AUM4103,$J) called here and AUM4103
; global used to generate the email message sent by
; post-install routine
S ^(0)=$G(^TMP("AUM4103",$J,0))+1,^(^(0))=% D MES(%)
Q
;
MES(%) ;--- 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
;
CLINNEW ;EP --- ADD NEW CLINIC
D RSLT($$E("CLINNEW"))
D RSLT($J("",11)_"CODE NAME"_$J("",28)_"ABRV. PRI.CARE 1A WL RPT")
D RSLT($J("",11)_"---- ----"_$J("",28)_"----- -------- ---------")
F T=1:1 S L=$T(CLINNEW+T^AUM4103A) Q:$P(L,";",3)="END" D ADDCLIN
KILL DLAYGO
Q
;
ADDCLIN ;
S L=$P(L,";;",2),C=$P(L,U),N=$P(L,U,2),A=$P(L,U,3),P=$P(L,U,4),R=$P(L,U,5),L=C_" "_N_$J("",(32-$L(N)))_$$LJ^XLFSTR(A,8)_$$LJ^XLFSTR(P,11)_R
I $D(^DIC(40.7,"C",C)) D RSLT($J("",5)_$$M(1)_"CLINIC CODE EXISTS => "_C),RSLT("") Q
S DLAYGO=40.7,DIC="^DIC(40.7,",X=N,DIC("DR")="1///"_C_";999999901///"_A_";90000.01///"_R
I $L(P) S DIC("DR")=DIC("DR")_";999999902///"_P
D FILE,ADDFAIL:Y<0,ADDOK:Y>0
Q
;
CLINMOD ;EP
S E="Clinic Name Changes"
F T=1:2 S L=$T(CLINMOD+T^AUM4103A) Q:$P(L,";",3)="END" D
.S L("TO")=$T(CLINMOD+T+1^AUM4103A)
.S L=$P(L("TO"),"^",2,99),C=$P(L,"^",1),N=$P(L,"^",2)
.S DA=$O(^DIC(40.7,"C",C,0))
.I 'DA S L=";;"_L D ADDCLIN Q
.S DIE="^DIC(40.7,",DR=".01///"_N D ^DIE
.I $D(Y) D RSLT(E_" : CHANGE FAILED => "_L) Q
.D MODOK
Q
;
TRIBEMOD ;EP --- MOD TRIBE
; C=CODE, O=OLD, N=NAME, P=IEN
N @$P($T(SVARS),";",3)
D RSLT($$E("TRIBEMOD"))
D RSLT($$RJ^XLFSTR("CODE OLD NAME",28))
D RSLT($$RJ^XLFSTR("---- --- ----",28))
F T=1:2 S L=$T(TRIBEMOD+T^AUM4103A) Q:$P(L,";",3)="END" S L("TO")=$T(TRIBEMOD+T+1^AUM4103A) D
. S L=$P(L,U,2,99),C=$P(L,U),O=$P(L,U,2),N=$P(L,U,3)
. S P=$O(^AUTTTRI("C",C,0))
. S L=$P(L("TO"),U,2,99),C=$P(L,U),O=$P(L,U,2),N=$P(L,U,3)
. I 'P S P=$O(^AUTTTRI("C",C,0))
. I 'P S L=";;"_L D ADDTRIBE Q
. S L=C_" "_O_" "_N
. S DIE="^AUTTTRI("
. S DA=P
. S DR=".01///"_N_";.02///"_C_";.04///"_O
. D DIE
. I $D(Y) D RSLT($J("",5)_$$M(0)_"EDIT TRIBE FAILED => "_L) Q
. D MODOK
Q
ADDTRIBE ;
S L=$P(L,";;",2),C=$P(L,U),O=$P(L,U,2),N=$P(L,U,3)
S L=" "_$$LJ^XLFSTR(C,5)_$$LJ^XLFSTR(O,4)_N
S %=$O(^AUTTTRI("C",C,0))
I % D RSLT($J("",5)_$$M(1)_"TRIBE EXISTS => "_N) Q
S DLAYGO=9999999.03
S DIC="^AUTTTRI("
S X=N
S DIC("DR")=".02///"_C_";.04///"_O
D FILE
D @$S(Y>0:"ADDOK",1:"ADDFAIL")
Q
;
EXAMNEW ;EP --- NEW EXAM
N @$P($T(SVARS),";",3)
D RSLT($$E("EXAMNEW"))
D RSLT($J("",13)_"NAME")
D RSLT($J("",13)_"----")
F T=1:1 S L=$T(EXAMNEW+T^AUM4103A) Q:$P(L,";",3)="END" D ADDEXAM
Q
ADDEXAM ;
S L=$P(L,";;",2),N=$P(L,U),C=$P(L,U,2),L=N
I $D(^AUTTEXAM("C",C)) D RSLT($J("",5)_$$M(1)_"EXAM CODE EXISTS => "_C_" "_N) Q
S DLAYGO=9999999.15,DIC="^AUTTEXAM(",X=N
S DIC("DR")=".02///"_C
D FILE
D @$S(Y>0:"ADDOK",1:"ADDFAIL")
K DLAYGO
Q
;
EXAMMOD ;EP modify exam file
S E="Exam Name Changes"
F T=1:2 S L=$T(EXAMMOD+T^AUM4103A) Q:$P(L,";",3)="END" D
.S L("TO")=$T(EXAMMOD+T+1^AUM4103A)
.S L=$P(L("TO"),"^",2,99),N=$P(L,"^"),C=$P(L,"^",2)
.S DA=$O(^AUTTEXAM("C",C,0))
.I 'DA S L=";;"_L D ADDEXAM Q
.S L=C_" "_N
.S DIE="^AUTTEXAM(",DR=".01///"_N D DIE
.I $D(Y) D RSLT(E(0)_E_" : CHANGE FAILED => "_L) Q
.D MODOK
Q
EDUCNEW ;EP --- NEW PATIENT ED- P&F
D RSLT($$E("EDUCNEW"))
D RSLT($J("",13)_"NAME")
D RSLT($J("",13)_"----")
F T=1:1 S L=$T(EDUCNEW+T^AUM4103A) Q:$P(L,";",3)="END" D ADDEDUC
Q
ADDEDUC ;--- ADD THE NEW PATIENT EDUCATION
S L=$P(L,";;",2),N=$P(L,U),M=$P(L,U,2),C=$P(L,U,3),L=N
I $D(^AUTTEDPF("B",N)) D RSLT($J("",5)_$$M(1)_"PT ED NAME EXISTS => "_N) Q
S DLAYGO=9999999.98,DIC="^AUTTEDPF(",X=N
S DIC("DR")=".02///"_M_";.03///"_C
D FILE
D @$S(Y>0:"ADDOK",1:"ADDFAIL")
Q
;
HFNEW ;EP --- NEW HEALTH FACTORS
D RSLT($$E("HFNEW"))
D RSLT($J("",13)_"NAME")
D RSLT($J("",13)_"----")
F T=1:1 S L=$T(HFNEW+T^AUM4103A) Q:$P(L,";",3)="END" D ADDHF
Q
ADDHF ;
S L=$P(L,";;",2),N=$P(L,U),O=$P(L,U,2),C=$P(L,U,3),S=$P(L,U,4),L=N_" "_O_" "_C_" "_S
I $D(^AUTTHF("B",N)) D RSLT($J("",5)_$$M(1)_"HEALTH FACTOR EXISTS => "_N),RSLT("") Q
S DLAYGO=9999999.64,DIC="^AUTTHF(",X=N,DIC("DR")=".03///"_O_";.1///"_C_";.14///"_S
D FILE
D @$S(Y>0:"ADDOK",1:"ADDFAIL")
Q
;
PCLASNEW ;EP --- NEW PROV CLASS
S E=$$E("PCLASNEW")
D RSLT(E)
D RSLT($J("",11)_"CODE NAME"_$J("",28)_"ABRV.")
D RSLT($J("",11)_"---- ----"_$J("",28)_"-----")
F T=1:1 S L=$T(PCLASNEW+T^AUM4103A) Q:$P(L,";",3)="END" D ADDPCLAS
Q
ADDPCLAS ;
S L=$P(L,";;",2),C=$P(L,U),N=$P(L,U,2),A=$P(L,U,3),F=$P(L,"^",4),W=$P(L,"^",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
S DIC("DR")="1///"_A_";9999999.01///"_C_";9999999.03///"_F_";9999999.05///"_W
D FILE
D @$S(Y>0:"ADDOK",1:"ADDFAIL")
Q
;
PCLASMOD ;EP
D RSLT($$E("PCLASMOD"))
F T=1:2 S L=$T(PCLASMOD+T^AUM4103A) Q:$P(L,";",3)="END" S L("TO")=$T(PCLASMOD+T+1^AUM4103A) D
.S L=$P(L,"^",2,99),C=$P(L,"^",1),N=$P(L,"^",2),A=$P(L,"^",3),F=$P(L,"^",4),W=$P(L,"^",5)
.S P=$O(^DIC(7,"D",C,0))
.I 'P S L=L("TO") D ADDPCLAS Q
.S L=$P(L("TO"),"^",2,99),C=$P(L,"^",1),N=$P(L,"^",2),A=$P(L,"^",3),F=$P(L,"^",4),W=$P(L,"^",5)
.S L=C_" "_N_" "_A
.S DIE="^DIC(7,",DA=P
.S DR=".01///"_N_";1///"_A_";9999999.01///"_C_";9999999.03///"_F_";9999999.05///"_W
.D ^DIE
.I $D(Y) D RSLT($J("",5)_$$M(0)_"EDIT PROVIDER CODE FAILED => "_L) Q
.D MODOK
Q
;
MEASNEW ;EP
S E="New Measurement Type"
F T=1:1 S L=$T(MEASNEW+T^AUM4103A) Q:$P(L,";",3)="END" D
.D ADDMEAS
Q
ADDMEAS ;
S L=$P(L,";;",2),N=$P(L,"^"),S=$P(L,"^",2),C=$P(L,"^",3),L=N_" "_S_" "_C
I $D(^AUTTMSR("C",C)) D RSLT(E_" : MEASUREMENT TYPE CODE EXISTS => "_C) Q
S DLAYGO=9999999.07,DIC="^AUTTMSR(",X=N,DIC("DR")=".02///"_S_";.03///"_C D FILE
D ADDFAIL:Y<0,ADDOK:Y>0
Q
;
SVARS ;;A,C,E,F,L,M,N,O,P,R,S,T,V,W;Single-character work variables
Q
AUM41032 ;IHS/ITSC/DMJ - SCB UPDATE 2/18/2004 [ 04/01/2004 11:14 AM ]
+1 ;;04.1;TABLE MAINTENANCE;**3**;OCT 13,2003
+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 ;
E(L) ;-----
+1 QUIT $PIECE($PIECE($TEXT(@L^AUM4103A),";",3),":",1)
+2 ;
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 ;
RSLT(%) ; EP- INCREMENTS/UPDATES ^TMP("AUM4103,$J) called here and AUM4103
+1 ; global used to generate the email message sent by
+2 ; post-install routine
+3 SET ^(0)=$GET(^TMP("AUM4103",$JOB,0))+1
SET ^(^(0))=%
DO MES(%)
+4 QUIT
+5 ;
MES(%) ;--- 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 ;
CLINNEW ;EP --- ADD NEW CLINIC
+1 DO RSLT($$E("CLINNEW"))
+2 DO RSLT($JUSTIFY("",11)_"CODE NAME"_$JUSTIFY("",28)_"ABRV. PRI.CARE 1A WL RPT")
+3 DO RSLT($JUSTIFY("",11)_"---- ----"_$JUSTIFY("",28)_"----- -------- ---------")
+4 FOR T=1:1
SET L=$TEXT(CLINNEW+T^AUM4103A)
IF $PIECE(L,";",3)="END"
QUIT
DO ADDCLIN
+5 KILL DLAYGO
+6 QUIT
+7 ;
ADDCLIN ;
+1 SET L=$PIECE(L,";;",2)
SET C=$PIECE(L,U)
SET N=$PIECE(L,U,2)
SET A=$PIECE(L,U,3)
SET P=$PIECE(L,U,4)
SET R=$PIECE(L,U,5)
SET L=C_" "_N_$JUSTIFY("",(32-$LENGTH(N)))_$$LJ^XLFSTR(A,8)_$$LJ^XLFSTR(P,11)_R
+2 IF $DATA(^DIC(40.7,"C",C))
DO RSLT($JUSTIFY("",5)_$$M(1)_"CLINIC CODE EXISTS => "_C)
DO RSLT("")
QUIT
+3 SET DLAYGO=40.7
SET DIC="^DIC(40.7,"
SET X=N
SET DIC("DR")="1///"_C_";999999901///"_A_";90000.01///"_R
+4 IF $LENGTH(P)
SET DIC("DR")=DIC("DR")_";999999902///"_P
+5 DO FILE
IF Y<0
DO ADDFAIL
IF Y>0
DO ADDOK
+6 QUIT
+7 ;
CLINMOD ;EP
+1 SET E="Clinic Name Changes"
+2 FOR T=1:2
SET L=$TEXT(CLINMOD+T^AUM4103A)
IF $PIECE(L,";",3)="END"
QUIT
Begin DoDot:1
+3 SET L("TO")=$TEXT(CLINMOD+T+1^AUM4103A)
+4 SET L=$PIECE(L("TO"),"^",2,99)
SET C=$PIECE(L,"^",1)
SET N=$PIECE(L,"^",2)
+5 SET DA=$ORDER(^DIC(40.7,"C",C,0))
+6 IF 'DA
SET L=";;"_L
DO ADDCLIN
QUIT
+7 SET DIE="^DIC(40.7,"
SET DR=".01///"_N
DO ^DIE
+8 IF $DATA(Y)
DO RSLT(E_" : CHANGE FAILED => "_L)
QUIT
+9 DO MODOK
End DoDot:1
+10 QUIT
+11 ;
TRIBEMOD ;EP --- MOD TRIBE
+1 ; C=CODE, O=OLD, N=NAME, P=IEN
+2 NEW @$PIECE($TEXT(SVARS),";",3)
+3 DO RSLT($$E("TRIBEMOD"))
+4 DO RSLT($$RJ^XLFSTR("CODE OLD NAME",28))
+5 DO RSLT($$RJ^XLFSTR("---- --- ----",28))
+6 FOR T=1:2
SET L=$TEXT(TRIBEMOD+T^AUM4103A)
IF $PIECE(L,";",3)="END"
QUIT
SET L("TO")=$TEXT(TRIBEMOD+T+1^AUM4103A)
Begin DoDot:1
+7 SET L=$PIECE(L,U,2,99)
SET C=$PIECE(L,U)
SET O=$PIECE(L,U,2)
SET N=$PIECE(L,U,3)
+8 SET P=$ORDER(^AUTTTRI("C",C,0))
+9 SET L=$PIECE(L("TO"),U,2,99)
SET C=$PIECE(L,U)
SET O=$PIECE(L,U,2)
SET N=$PIECE(L,U,3)
+10 IF 'P
SET P=$ORDER(^AUTTTRI("C",C,0))
+11 IF 'P
SET L=";;"_L
DO ADDTRIBE
QUIT
+12 SET L=C_" "_O_" "_N
+13 SET DIE="^AUTTTRI("
+14 SET DA=P
+15 SET DR=".01///"_N_";.02///"_C_";.04///"_O
+16 DO DIE
+17 IF $DATA(Y)
DO RSLT($JUSTIFY("",5)_$$M(0)_"EDIT TRIBE FAILED => "_L)
QUIT
+18 DO MODOK
End DoDot:1
+19 QUIT
ADDTRIBE ;
+1 SET L=$PIECE(L,";;",2)
SET C=$PIECE(L,U)
SET O=$PIECE(L,U,2)
SET N=$PIECE(L,U,3)
+2 SET L=" "_$$LJ^XLFSTR(C,5)_$$LJ^XLFSTR(O,4)_N
+3 SET %=$ORDER(^AUTTTRI("C",C,0))
+4 IF %
DO RSLT($JUSTIFY("",5)_$$M(1)_"TRIBE EXISTS => "_N)
QUIT
+5 SET DLAYGO=9999999.03
+6 SET DIC="^AUTTTRI("
+7 SET X=N
+8 SET DIC("DR")=".02///"_C_";.04///"_O
+9 DO FILE
+10 DO @$SELECT(Y>0:"ADDOK",1:"ADDFAIL")
+11 QUIT
+12 ;
EXAMNEW ;EP --- NEW EXAM
+1 NEW @$PIECE($TEXT(SVARS),";",3)
+2 DO RSLT($$E("EXAMNEW"))
+3 DO RSLT($JUSTIFY("",13)_"NAME")
+4 DO RSLT($JUSTIFY("",13)_"----")
+5 FOR T=1:1
SET L=$TEXT(EXAMNEW+T^AUM4103A)
IF $PIECE(L,";",3)="END"
QUIT
DO ADDEXAM
+6 QUIT
ADDEXAM ;
+1 SET L=$PIECE(L,";;",2)
SET N=$PIECE(L,U)
SET C=$PIECE(L,U,2)
SET L=N
+2 IF $DATA(^AUTTEXAM("C",C))
DO RSLT($JUSTIFY("",5)_$$M(1)_"EXAM CODE EXISTS => "_C_" "_N)
QUIT
+3 SET DLAYGO=9999999.15
SET DIC="^AUTTEXAM("
SET X=N
+4 SET DIC("DR")=".02///"_C
+5 DO FILE
+6 DO @$SELECT(Y>0:"ADDOK",1:"ADDFAIL")
+7 KILL DLAYGO
+8 QUIT
+9 ;
EXAMMOD ;EP modify exam file
+1 SET E="Exam Name Changes"
+2 FOR T=1:2
SET L=$TEXT(EXAMMOD+T^AUM4103A)
IF $PIECE(L,";",3)="END"
QUIT
Begin DoDot:1
+3 SET L("TO")=$TEXT(EXAMMOD+T+1^AUM4103A)
+4 SET L=$PIECE(L("TO"),"^",2,99)
SET N=$PIECE(L,"^")
SET C=$PIECE(L,"^",2)
+5 SET DA=$ORDER(^AUTTEXAM("C",C,0))
+6 IF 'DA
SET L=";;"_L
DO ADDEXAM
QUIT
+7 SET L=C_" "_N
+8 SET DIE="^AUTTEXAM("
SET DR=".01///"_N
DO DIE
+9 IF $DATA(Y)
DO RSLT(E(0)_E_" : CHANGE FAILED => "_L)
QUIT
+10 DO MODOK
End DoDot:1
+11 QUIT
EDUCNEW ;EP --- NEW PATIENT ED- P&F
+1 DO RSLT($$E("EDUCNEW"))
+2 DO RSLT($JUSTIFY("",13)_"NAME")
+3 DO RSLT($JUSTIFY("",13)_"----")
+4 FOR T=1:1
SET L=$TEXT(EDUCNEW+T^AUM4103A)
IF $PIECE(L,";",3)="END"
QUIT
DO ADDEDUC
+5 QUIT
ADDEDUC ;--- ADD THE NEW PATIENT EDUCATION
+1 SET L=$PIECE(L,";;",2)
SET N=$PIECE(L,U)
SET M=$PIECE(L,U,2)
SET C=$PIECE(L,U,3)
SET L=N
+2 IF $DATA(^AUTTEDPF("B",N))
DO RSLT($JUSTIFY("",5)_$$M(1)_"PT ED NAME EXISTS => "_N)
QUIT
+3 SET DLAYGO=9999999.98
SET DIC="^AUTTEDPF("
SET X=N
+4 SET DIC("DR")=".02///"_M_";.03///"_C
+5 DO FILE
+6 DO @$SELECT(Y>0:"ADDOK",1:"ADDFAIL")
+7 QUIT
+8 ;
HFNEW ;EP --- NEW HEALTH FACTORS
+1 DO RSLT($$E("HFNEW"))
+2 DO RSLT($JUSTIFY("",13)_"NAME")
+3 DO RSLT($JUSTIFY("",13)_"----")
+4 FOR T=1:1
SET L=$TEXT(HFNEW+T^AUM4103A)
IF $PIECE(L,";",3)="END"
QUIT
DO ADDHF
+5 QUIT
ADDHF ;
+1 SET L=$PIECE(L,";;",2)
SET N=$PIECE(L,U)
SET O=$PIECE(L,U,2)
SET C=$PIECE(L,U,3)
SET S=$PIECE(L,U,4)
SET L=N_" "_O_" "_C_" "_S
+2 IF $DATA(^AUTTHF("B",N))
DO RSLT($JUSTIFY("",5)_$$M(1)_"HEALTH FACTOR EXISTS => "_N)
DO RSLT("")
QUIT
+3 SET DLAYGO=9999999.64
SET DIC="^AUTTHF("
SET X=N
SET DIC("DR")=".03///"_O_";.1///"_C_";.14///"_S
+4 DO FILE
+5 DO @$SELECT(Y>0:"ADDOK",1:"ADDFAIL")
+6 QUIT
+7 ;
PCLASNEW ;EP --- NEW PROV CLASS
+1 SET E=$$E("PCLASNEW")
+2 DO RSLT(E)
+3 DO RSLT($JUSTIFY("",11)_"CODE NAME"_$JUSTIFY("",28)_"ABRV.")
+4 DO RSLT($JUSTIFY("",11)_"---- ----"_$JUSTIFY("",28)_"-----")
+5 FOR T=1:1
SET L=$TEXT(PCLASNEW+T^AUM4103A)
IF $PIECE(L,";",3)="END"
QUIT
DO ADDPCLAS
+6 QUIT
ADDPCLAS ;
+1 SET L=$PIECE(L,";;",2)
SET C=$PIECE(L,U)
SET N=$PIECE(L,U,2)
SET A=$PIECE(L,U,3)
SET F=$PIECE(L,"^",4)
SET W=$PIECE(L,"^",5)
+2 SET L=C_" "_N_$JUSTIFY("",(32-$LENGTH(N)))_A
+3 IF $DATA(^DIC(7,"D",C))
DO RSLT($JUSTIFY("",5)_$$M(1)_"PROVIDER CODE EXISTS => "_C)
DO RSLT("")
QUIT
+4 SET DLAYGO=7
SET DIC="^DIC(7,"
SET X=N
+5 SET DIC("DR")="1///"_A_";9999999.01///"_C_";9999999.03///"_F_";9999999.05///"_W
+6 DO FILE
+7 DO @$SELECT(Y>0:"ADDOK",1:"ADDFAIL")
+8 QUIT
+9 ;
PCLASMOD ;EP
+1 DO RSLT($$E("PCLASMOD"))
+2 FOR T=1:2
SET L=$TEXT(PCLASMOD+T^AUM4103A)
IF $PIECE(L,";",3)="END"
QUIT
SET L("TO")=$TEXT(PCLASMOD+T+1^AUM4103A)
Begin DoDot:1
+3 SET L=$PIECE(L,"^",2,99)
SET C=$PIECE(L,"^",1)
SET N=$PIECE(L,"^",2)
SET A=$PIECE(L,"^",3)
SET F=$PIECE(L,"^",4)
SET W=$PIECE(L,"^",5)
+4 SET P=$ORDER(^DIC(7,"D",C,0))
+5 IF 'P
SET L=L("TO")
DO ADDPCLAS
QUIT
+6 SET L=$PIECE(L("TO"),"^",2,99)
SET C=$PIECE(L,"^",1)
SET N=$PIECE(L,"^",2)
SET A=$PIECE(L,"^",3)
SET F=$PIECE(L,"^",4)
SET W=$PIECE(L,"^",5)
+7 SET L=C_" "_N_" "_A
+8 SET DIE="^DIC(7,"
SET DA=P
+9 SET DR=".01///"_N_";1///"_A_";9999999.01///"_C_";9999999.03///"_F_";9999999.05///"_W
+10 DO ^DIE
+11 IF $DATA(Y)
DO RSLT($JUSTIFY("",5)_$$M(0)_"EDIT PROVIDER CODE FAILED => "_L)
QUIT
+12 DO MODOK
End DoDot:1
+13 QUIT
+14 ;
MEASNEW ;EP
+1 SET E="New Measurement Type"
+2 FOR T=1:1
SET L=$TEXT(MEASNEW+T^AUM4103A)
IF $PIECE(L,";",3)="END"
QUIT
Begin DoDot:1
+3 DO ADDMEAS
End DoDot:1
+4 QUIT
ADDMEAS ;
+1 SET L=$PIECE(L,";;",2)
SET N=$PIECE(L,"^")
SET S=$PIECE(L,"^",2)
SET C=$PIECE(L,"^",3)
SET L=N_" "_S_" "_C
+2 IF $DATA(^AUTTMSR("C",C))
DO RSLT(E_" : MEASUREMENT TYPE CODE EXISTS => "_C)
QUIT
+3 SET DLAYGO=9999999.07
SET DIC="^AUTTMSR("
SET X=N
SET DIC("DR")=".02///"_S_";.03///"_C
DO FILE
+4 IF Y<0
DO ADDFAIL
IF Y>0
DO ADDOK
+5 QUIT
+6 ;
SVARS ;;A,C,E,F,L,M,N,O,P,R,S,T,V,W;Single-character work variables
+1 QUIT
