ECX3P114 ;ALB/JAP - National Clinic Update ;June 25, 2008
;;3.0;DSS EXTRACTS;**114**;Dec 22, 1997;Build 1
;
ADD7272 ;** Add entries to file #727.2
;ECXX is in format: ien;test^source
N ECX,ECXX,DA,DIC,DIE,DR,DINUM,X,Y,TEST,SOURCE
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)=""
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 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 MESS
S $P(^DD(727.21,.01,0),U,5)="K X"
Q
;
MESS ;** Add message
N ECXADMSG
S ECXADMSG=" "_TEST
D MES^XPDUTL(ECXADMSG)
S ECXADMSG=" added as record #"_ECXDA_"."
D MES^XPDUTL(ECXADMSG)
D MES^XPDUTL(" ")
Q
;
MESS2 ;** Add message
N ECXADMSG
S ECXADMSG=" "_A1_" - "_A3
D MES^XPDUTL(ECXADMSG)
S ECXADMSG=" added as record #"_ECXDA_"."
D MES^XPDUTL(ECXADMSG)
D MES^XPDUTL(" ")
Q
;
CLEAN2 ;delete records added to file #727.2
N ECX,X,Y,DA,DIK,DIC,JJ,SS
D MES^XPDUTL(" ")
D MES^XPDUTL(" This subroutine will delete those entries in file #727.2,")
D MES^XPDUTL(" DSS LAB TESTS File, which were added by patch ECX*3.0*8.")
D MES^XPDUTL(" ")
I $E(IOST)="C" D Q:'Y
.S SS=22-$Y F JJ=1:1:SS W !
.K X,Y
.S DIR(0)="E" W ! D ^DIR K DIR
D MES^XPDUTL(" ")
D MES^XPDUTL(" Deleting...")
D MES^XPDUTL(" ")
F ECX=60:1:71 D
.S DA=ECX,DA(1)=1,DIK="^ECX(727.2,1,1,"
.D ^DIK
D MES^XPDUTL(" ")
D MES^XPDUTL(" Done.")
D MES^XPDUTL(" ")
Q
;
NEW7272 ;new records for file #727.2
;;72;PHOSPHATE (SERUM)^B
;;73;CEA (SERUM)^B
;;74;PRO B NATRIURETIC PEPTIDE^B
;;75;PHOSPHATE (SERUM)_PRE DIAL^B
;;76;PHOSPHATE (SERUM)_POST DIAL^B
;;QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECX3P114 2026 printed Oct 16, 2024@17:50:58 Page 2
ECX3P114 ;ALB/JAP - National Clinic Update ;June 25, 2008
+1 ;;3.0;DSS EXTRACTS;**114**;Dec 22, 1997;Build 1
+2 ;
ADD7272 ;** Add entries to file #727.2
+1 ;ECXX is in format: ien;test^source
+2 NEW ECX,ECXX,DA,DIC,DIE,DR,DINUM,X,Y,TEST,SOURCE
+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)=""
+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 TEST=$PIECE(ECXX,U,1)
SET SOURCE=$PIECE(ECXX,U,2)
+13 SET DA(1)=1
SET DIC("P")=$PIECE(^DD(727.2,1,0),U,2)
SET DINUM=ECXDA
+14 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"
+15 KILL DD,DO
DO FILE^DICN
KILL DLAYGO
+16 DO MESS
End DoDot:2
End DoDot:1
+17 SET $PIECE(^DD(727.21,.01,0),U,5)="K X"
+18 QUIT
+19 ;
MESS ;** Add message
+1 NEW ECXADMSG
+2 SET ECXADMSG=" "_TEST
+3 DO MES^XPDUTL(ECXADMSG)
+4 SET ECXADMSG=" added as record #"_ECXDA_"."
+5 DO MES^XPDUTL(ECXADMSG)
+6 DO MES^XPDUTL(" ")
+7 QUIT
+8 ;
MESS2 ;** Add message
+1 NEW ECXADMSG
+2 SET ECXADMSG=" "_A1_" - "_A3
+3 DO MES^XPDUTL(ECXADMSG)
+4 SET ECXADMSG=" added as record #"_ECXDA_"."
+5 DO MES^XPDUTL(ECXADMSG)
+6 DO MES^XPDUTL(" ")
+7 QUIT
+8 ;
CLEAN2 ;delete records added to file #727.2
+1 NEW ECX,X,Y,DA,DIK,DIC,JJ,SS
+2 DO MES^XPDUTL(" ")
+3 DO MES^XPDUTL(" This subroutine will delete those entries in file #727.2,")
+4 DO MES^XPDUTL(" DSS LAB TESTS File, which were added by patch ECX*3.0*8.")
+5 DO MES^XPDUTL(" ")
+6 IF $EXTRACT(IOST)="C"
Begin DoDot:1
+7 SET SS=22-$Y
FOR JJ=1:1:SS
WRITE !
+8 KILL X,Y
+9 SET DIR(0)="E"
WRITE !
DO ^DIR
KILL DIR
End DoDot:1
if 'Y
QUIT
+10 DO MES^XPDUTL(" ")
+11 DO MES^XPDUTL(" Deleting...")
+12 DO MES^XPDUTL(" ")
+13 FOR ECX=60:1:71
Begin DoDot:1
+14 SET DA=ECX
SET DA(1)=1
SET DIK="^ECX(727.2,1,1,"
+15 DO ^DIK
End DoDot:1
+16 DO MES^XPDUTL(" ")
+17 DO MES^XPDUTL(" Done.")
+18 DO MES^XPDUTL(" ")
+19 QUIT
+20 ;
NEW7272 ;new records for file #727.2
+1 ;;72;PHOSPHATE (SERUM)^B
+2 ;;73;CEA (SERUM)^B
+3 ;;74;PRO B NATRIURETIC PEPTIDE^B
+4 ;;75;PHOSPHATE (SERUM)_PRE DIAL^B
+5 ;;76;PHOSPHATE (SERUM)_POST DIAL^B
+6 ;;QUIT
