ECX3P90P ;ALB/JAP - National Clinic Update ;DEC 06, 2005
;;3.0;DSS EXTRACTS;**90**;Dec 22, 1997
;
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 CLEAN2
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*87.")
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
;;60;BILIRUBIN, DIRECT^B
;;61;C REACTIVE PROTEIN^B
;;62;C REACTIVE PROTEIN HS^B
;;63;CALCIUM SERUM^B
;;64;CARBON DIOXIDE^B
;;65;CHLORIDE^B
;;66;CREATININE EGFR^B
;;67;B NATRIURETIC PEPTIDE^B
;;68;O2 SATURATION^B
;;69;PO2^B
;;70;PCO2^B
;;71;TOTAL PROTEIN^B
;;QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECX3P90P 2156 printed Dec 13, 2024@01:50:49 Page 2
ECX3P90P ;ALB/JAP - National Clinic Update ;DEC 06, 2005
+1 ;;3.0;DSS EXTRACTS;**90**;Dec 22, 1997
+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 CLEAN2
+4 DO MES^XPDUTL(" ")
+5 DO MES^XPDUTL(" ")
+6 DO MES^XPDUTL(" Adding entries to DSS LAB TESTS File (#727.2)...")
+7 DO MES^XPDUTL(" ")
+8 SET $PIECE(^DD(727.21,.01,0),U,5)=""
+9 FOR ECX=1:1
SET ECXX=$PIECE($TEXT(NEW7272+ECX),";;",2)
if ECXX="QUIT"
QUIT
Begin DoDot:1
+10 SET ECXDA=$PIECE(ECXX,";",1)
SET ECXX=$PIECE(ECXX,";",2)
+11 if '$DATA(^ECX(727.2,1))
QUIT
+12 IF $DATA(^ECX(727.2,1,1,0))
IF '$DATA(^ECX(727.2,1,1,ECXDA,0))
Begin DoDot:2
+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 MESS
End DoDot:2
End DoDot:1
+18 SET $PIECE(^DD(727.21,.01,0),U,5)="K X"
+19 QUIT
+20 ;
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*87.")
+5 DO MES^XPDUTL(" ")
+6 ;I $E(IOST)="C" D Q:'Y
+7 ;.S SS=22-$Y F JJ=1:1:SS W !
+8 ;.K X,Y
+9 ;.S DIR(0)="E" W ! D ^DIR K DIR
+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 ;;60;BILIRUBIN, DIRECT^B
+2 ;;61;C REACTIVE PROTEIN^B
+3 ;;62;C REACTIVE PROTEIN HS^B
+4 ;;63;CALCIUM SERUM^B
+5 ;;64;CARBON DIOXIDE^B
+6 ;;65;CHLORIDE^B
+7 ;;66;CREATININE EGFR^B
+8 ;;67;B NATRIURETIC PEPTIDE^B
+9 ;;68;O2 SATURATION^B
+10 ;;69;PO2^B
+11 ;;70;PCO2^B
+12 ;;71;TOTAL PROTEIN^B
+13 ;;QUIT
