ECX333PT ;ALB/JAM - PATCH ECX*3.0*33 Post-Init Rtn ; 06/07/00
;;3.0;DSS EXTRACTS;**33**;Jun 07, 2000
;
;post-init routine to add new entries to file 727.831 and add LAR codes
;
D DOMADD
D ADD7272
Q
DOMADD ;* add entries to file 727.831
;
; ECXX is in format:
; TREATING SPECIALTY IEN TO ADD^DSS DOM CODE^IN/OUT CODE
;
N ECX,ECXX,LOC,CODE,INOUT,X,Y,DIC,DA,DR,DLAYGO,DINUM
D MES^XPDUTL(" ")
D BMES^XPDUTL("Adding entries to DOM PRRTP SAARTP ETC File (#727.831)...")
F ECX=1:1 S ECXX=$P($T(NEW+ECX),";;",2) Q:ECXX="QUIT" D
.S LOC=$P(ECXX,U),CODE=$P(ECXX,U,2),INOUT=$P(ECXX,U,3)
.I '$D(^ECX(727.831,LOC)) D Q
..S X=LOC,DINUM=X,DIC(0)="L",DLAYGO=727.831,DIC="^ECX(727.831,"
..S DIC("DR")="2////^S X=CODE;3////^S X=INOUT"
..D FILE^DICN I +Y>0 D Q
...D BMES^XPDUTL(" Treating Specialty "_LOC_" ...successfully added.")
..D BMES^XPDUTL("ERROR when attempting to add Treating Specialty "_LOC)
.D BMES^XPDUTL(" Treating Specialty "_LOC_" already added.")
Q
NEW ;treating speciality ien to add^dss dom code^in/out code
;;25^P^3
;;26^T^3
;;27^S^3
;;28^H^3
;;29^A^3
;;37^D^3
;;38^B^3
;;39^C^3
;;85^D^3
;;86^D^3
;;87^D^3
;;88^D^3
;;QUIT
ADD7272 ;add entries to file #727.2
;ECXX is in format: ien;test^source
N ECX,ECXX,DA,DIC,DINUM,DIE,DR,X,Y,TEST,SOURCE,CNT
D MES^XPDUTL(" ")
D MES^XPDUTL(" ")
D MES^XPDUTL(" Adding entries to DSS LAB TESTS File (#727.2)...")
D MES^XPDUTL(" ")
S $P(^DD(727.21,.01,0),U,5)="",CNT=0
F ECX=1:1 S ECXX=$P($T(NEW7272+ECX),";;",2) Q:ECXX="QUIT" D
.S ECXDA=$P(ECXX,";",1),ECXX=$P(ECXX,";",2)
.Q:'$D(^ECX(727.2,1))
.I $D(^ECX(727.2,1,1,0)),'$D(^ECX(727.2,1,1,ECXDA,0)) D
..S CNT=CNT+1
..S TEST=$P(ECXX,U,1),SOURCE=$P(ECXX,U,2)
..S DA(1)=1,DIC("P")=$P(^DD(727.2,1,0),U,2),DINUM=ECXDA
..S X=TEST,DIC="^ECX(727.2,1,1,",DLAYGO=727.21,DIC(0)="LX",DIC("DR")="2///^S X=SOURCE"
..K DD,DO D FILE^DICN K DLAYGO
..D MES^XPDUTL(" ")
..D MES^XPDUTL(" Adding "_TEST_" as entry #"_ECXDA_"... ok.")
..D MES^XPDUTL(" ")
I CNT=0 D
.D MES^XPDUTL(" Entries already exist -- nothing added.")
.D MES^XPDUTL(" ")
S $P(^DD(727.21,.01,0),U,5)="K X"
Q
;
NEW7272 ;new records for file #727.2
;;41;HEPATITIS A AB^B
;;42;HEPATITIS A IGM AB^B
;;43;HEPATITIS A, IGG AB^B
;;44;BILIRUBIN, TOTAL^B
;;45;ALT (TRANSFERASE ALANINE AMINO)^B
;;46;HEPATITIS B CORE AB^B
;;47;HEPATITIS B E AG^B
;;48;PHOSPHATASE ALKALINE^B
;;49;ALBUMIN^B
;;QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECX333PT 2483 printed Apr 09, 2024@20:55:32 Page 2
ECX333PT ;ALB/JAM - PATCH ECX*3.0*33 Post-Init Rtn ; 06/07/00
+1 ;;3.0;DSS EXTRACTS;**33**;Jun 07, 2000
+2 ;
+3 ;post-init routine to add new entries to file 727.831 and add LAR codes
+4 ;
+5 DO DOMADD
+6 DO ADD7272
+7 QUIT
DOMADD ;* add entries to file 727.831
+1 ;
+2 ; ECXX is in format:
+3 ; TREATING SPECIALTY IEN TO ADD^DSS DOM CODE^IN/OUT CODE
+4 ;
+5 NEW ECX,ECXX,LOC,CODE,INOUT,X,Y,DIC,DA,DR,DLAYGO,DINUM
+6 DO MES^XPDUTL(" ")
+7 DO BMES^XPDUTL("Adding entries to DOM PRRTP SAARTP ETC File (#727.831)...")
+8 FOR ECX=1:1
SET ECXX=$PIECE($TEXT(NEW+ECX),";;",2)
if ECXX="QUIT"
QUIT
Begin DoDot:1
+9 SET LOC=$PIECE(ECXX,U)
SET CODE=$PIECE(ECXX,U,2)
SET INOUT=$PIECE(ECXX,U,3)
+10 IF '$DATA(^ECX(727.831,LOC))
Begin DoDot:2
+11 SET X=LOC
SET DINUM=X
SET DIC(0)="L"
SET DLAYGO=727.831
SET DIC="^ECX(727.831,"
+12 SET DIC("DR")="2////^S X=CODE;3////^S X=INOUT"
+13 DO FILE^DICN
IF +Y>0
Begin DoDot:3
+14 DO BMES^XPDUTL(" Treating Specialty "_LOC_" ...successfully added.")
End DoDot:3
QUIT
+15 DO BMES^XPDUTL("ERROR when attempting to add Treating Specialty "_LOC)
End DoDot:2
QUIT
+16 DO BMES^XPDUTL(" Treating Specialty "_LOC_" already added.")
End DoDot:1
+17 QUIT
NEW ;treating speciality ien to add^dss dom code^in/out code
+1 ;;25^P^3
+2 ;;26^T^3
+3 ;;27^S^3
+4 ;;28^H^3
+5 ;;29^A^3
+6 ;;37^D^3
+7 ;;38^B^3
+8 ;;39^C^3
+9 ;;85^D^3
+10 ;;86^D^3
+11 ;;87^D^3
+12 ;;88^D^3
+13 ;;QUIT
ADD7272 ;add entries to file #727.2
+1 ;ECXX is in format: ien;test^source
+2 NEW ECX,ECXX,DA,DIC,DINUM,DIE,DR,X,Y,TEST,SOURCE,CNT
+3 DO MES^XPDUTL(" ")
+4 DO MES^XPDUTL(" ")
+5 DO MES^XPDUTL(" Adding entries to DSS LAB TESTS File (#727.2)...")
+6 DO MES^XPDUTL(" ")
+7 SET $PIECE(^DD(727.21,.01,0),U,5)=""
SET CNT=0
+8 FOR ECX=1:1
SET ECXX=$PIECE($TEXT(NEW7272+ECX),";;",2)
if ECXX="QUIT"
QUIT
Begin DoDot:1
+9 SET ECXDA=$PIECE(ECXX,";",1)
SET ECXX=$PIECE(ECXX,";",2)
+10 if '$DATA(^ECX(727.2,1))
QUIT
+11 IF $DATA(^ECX(727.2,1,1,0))
IF '$DATA(^ECX(727.2,1,1,ECXDA,0))
Begin DoDot:2
+12 SET CNT=CNT+1
+13 SET TEST=$PIECE(ECXX,U,1)
SET SOURCE=$PIECE(ECXX,U,2)
+14 SET DA(1)=1
SET DIC("P")=$PIECE(^DD(727.2,1,0),U,2)
SET DINUM=ECXDA
+15 SET X=TEST
SET DIC="^ECX(727.2,1,1,"
SET DLAYGO=727.21
SET DIC(0)="LX"
SET DIC("DR")="2///^S X=SOURCE"
+16 KILL DD,DO
DO FILE^DICN
KILL DLAYGO
+17 DO MES^XPDUTL(" ")
+18 DO MES^XPDUTL(" Adding "_TEST_" as entry #"_ECXDA_"... ok.")
+19 DO MES^XPDUTL(" ")
End DoDot:2
End DoDot:1
+20 IF CNT=0
Begin DoDot:1
+21 DO MES^XPDUTL(" Entries already exist -- nothing added.")
+22 DO MES^XPDUTL(" ")
End DoDot:1
+23 SET $PIECE(^DD(727.21,.01,0),U,5)="K X"
+24 QUIT
+25 ;
NEW7272 ;new records for file #727.2
+1 ;;41;HEPATITIS A AB^B
+2 ;;42;HEPATITIS A IGM AB^B
+3 ;;43;HEPATITIS A, IGG AB^B
+4 ;;44;BILIRUBIN, TOTAL^B
+5 ;;45;ALT (TRANSFERASE ALANINE AMINO)^B
+6 ;;46;HEPATITIS B CORE AB^B
+7 ;;47;HEPATITIS B E AG^B
+8 ;;48;PHOSPHATASE ALKALINE^B
+9 ;;49;ALBUMIN^B
+10 ;;QUIT
