DVBAPTEX ;ALB/CMM EXAM FILE UPDATE - POST INT ; 12 MARCH 1997
;;2.7;AMIE;**12**;Apr 10, 1995
;
; This is the post-in for patch 12 to add a new body system to the
; 2507 Body System file (396.7) and to inactivate Exams and add the
; new Exams into the AMIE EXAM file (396.6).
;
DRIVE ;
D MES^XPDUTL("Post Init Installation:")
D MES^XPDUTL("Updating 2507 Body System file.")
D ^DVBAPTBD
; ^ update 2507 Body System file (396.7)
D MES^XPDUTL("Updating AMIE EXAM file.")
I '$D(^DVB(396.6)) D MES^XPDUTL("Missing file 396.6, AMIE EXAM file")
I $D(^DVB(396.6)) D
.D INACT
.D LOAD
.D LOOP
D MES^XPDUTL("Removing Files: ")
D MES^XPDUTL("EXAM EXCEPTION (#396.93)")
D MES^XPDUTL("AMIE DOCUMENT (#396.91)")
D MES^XPDUTL("AMIE DOCUMENT TABLE OF CONTENTS (#396.92)")
D REMOVE
Q
;
REMOVE ;deletes files 396.93, 396.92 and 396.92 for Physician's Guide
;removes data and dd
N NAME
F NAME="^DVBP(396.91,","^DVBP(396.92,","^DVB(396.93," D
.S DIU=NAME,DIU(0)="D"
.D EN^DIU2
K DIU
Q
;
LOAD ;
S DIF="^TMP($J,""DVBAPT"",",XCNP=0
K ^TMP($J,"DVBAPT")
F ROU="DVBAPT1" S X=ROU X ^%ZOSF("LOAD")
;DVBAPT1 contains all New exams to be active after this patch
K DIF,XCNP,ROU
Q
;
LOOP ;
K LP,EXM,WKS,ROU,PNM,BDY,STAT,LINE,NAME
S LP=0,NUM=99
F S LP=$O(^TMP($J,"DVBAPT",LP)) Q:LP="" D
.S LINE=^TMP($J,"DVBAPT",LP,0)
.I (LINE'[";;")!(LINE[";AMIE;")!(LINE="") Q
.S NUM=NUM+1
.S EXM=$P(LINE,";",3) ;current exam name
.S NAME=$P(LINE,";",4) ;new exam name
.S WKS=$P(LINE,";",5) ;worksheet number
.S PNM=$P(LINE,";",6) ;print name
.S BDY=$P(LINE,";",7) ;body system
.S STAT=$P(LINE,";",8) ;status
.S ROU=$P(LINE,";",9) ;routine name
.;
.I NAME="" S NAME=EXM ;same name
.;
.I STAT="A" D NEW(NUM)
K LP,EXM,WKS,ROU,PNM,BDY,STAT,LINE,NAME,NUM
Q
;
INACT ; inactivate exam
N LOOP
S LOOP=0
F S LOOP=$O(^DVB(396.6,LOOP)) Q:'LOOP D
.S DIE="^DVB(396.6,",DA=+LOOP,DR=".5///I"
.D ^DIE
.K DIE,DA,DR
Q
;
NEW(EN) ; add new exam
K DD,DO,DIC,DA
S DIC="^DVB(396.6,",DIC(0)="LZ",X=NAME,DINUM=EN
S DIC("DR")=".07///"_WKS_";.5///"_STAT_";2///"_BDY_";6///"_PNM_";7///"_ROU
D FILE^DICN
I +Y=-1,$D(^DVB(396.6,EN)) D
.;have entry already, make sure fields are all populated correctly
.S DA=EN,DIE="^DVB(396.6,"
.S DR=".07///"_WKS_";.5///"_STAT_";2///"_BDY_";6///"_PNM_";7///"_ROU_";.01///"_NAME
.D ^DIE
.K DIE,DA,DR
I '$D(^DVB(396.6,EN)) D MES^XPDUTL("Unable to add exam, "_NAME_", IEN= ",EN)
K DIC,X,Y,DINUM
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBAPTEX 2518 printed Apr 09, 2024@20:55:41 Page 2
DVBAPTEX ;ALB/CMM EXAM FILE UPDATE - POST INT ; 12 MARCH 1997
+1 ;;2.7;AMIE;**12**;Apr 10, 1995
+2 ;
+3 ; This is the post-in for patch 12 to add a new body system to the
+4 ; 2507 Body System file (396.7) and to inactivate Exams and add the
+5 ; new Exams into the AMIE EXAM file (396.6).
+6 ;
DRIVE ;
+1 DO MES^XPDUTL("Post Init Installation:")
+2 DO MES^XPDUTL("Updating 2507 Body System file.")
+3 DO ^DVBAPTBD
+4 ; ^ update 2507 Body System file (396.7)
+5 DO MES^XPDUTL("Updating AMIE EXAM file.")
+6 IF '$DATA(^DVB(396.6))
DO MES^XPDUTL("Missing file 396.6, AMIE EXAM file")
+7 IF $DATA(^DVB(396.6))
Begin DoDot:1
+8 DO INACT
+9 DO LOAD
+10 DO LOOP
End DoDot:1
+11 DO MES^XPDUTL("Removing Files: ")
+12 DO MES^XPDUTL("EXAM EXCEPTION (#396.93)")
+13 DO MES^XPDUTL("AMIE DOCUMENT (#396.91)")
+14 DO MES^XPDUTL("AMIE DOCUMENT TABLE OF CONTENTS (#396.92)")
+15 DO REMOVE
+16 QUIT
+17 ;
REMOVE ;deletes files 396.93, 396.92 and 396.92 for Physician's Guide
+1 ;removes data and dd
+2 NEW NAME
+3 FOR NAME="^DVBP(396.91,","^DVBP(396.92,","^DVB(396.93,"
Begin DoDot:1
+4 SET DIU=NAME
SET DIU(0)="D"
+5 DO EN^DIU2
End DoDot:1
+6 KILL DIU
+7 QUIT
+8 ;
LOAD ;
+1 SET DIF="^TMP($J,""DVBAPT"","
SET XCNP=0
+2 KILL ^TMP($JOB,"DVBAPT")
+3 FOR ROU="DVBAPT1"
SET X=ROU
XECUTE ^%ZOSF("LOAD")
+4 ;DVBAPT1 contains all New exams to be active after this patch
+5 KILL DIF,XCNP,ROU
+6 QUIT
+7 ;
LOOP ;
+1 KILL LP,EXM,WKS,ROU,PNM,BDY,STAT,LINE,NAME
+2 SET LP=0
SET NUM=99
+3 FOR
SET LP=$ORDER(^TMP($JOB,"DVBAPT",LP))
if LP=""
QUIT
Begin DoDot:1
+4 SET LINE=^TMP($JOB,"DVBAPT",LP,0)
+5 IF (LINE'[";;")!(LINE[";AMIE;")!(LINE="")
QUIT
+6 SET NUM=NUM+1
+7 ;current exam name
SET EXM=$PIECE(LINE,";",3)
+8 ;new exam name
SET NAME=$PIECE(LINE,";",4)
+9 ;worksheet number
SET WKS=$PIECE(LINE,";",5)
+10 ;print name
SET PNM=$PIECE(LINE,";",6)
+11 ;body system
SET BDY=$PIECE(LINE,";",7)
+12 ;status
SET STAT=$PIECE(LINE,";",8)
+13 ;routine name
SET ROU=$PIECE(LINE,";",9)
+14 ;
+15 ;same name
IF NAME=""
SET NAME=EXM
+16 ;
+17 IF STAT="A"
DO NEW(NUM)
End DoDot:1
+18 KILL LP,EXM,WKS,ROU,PNM,BDY,STAT,LINE,NAME,NUM
+19 QUIT
+20 ;
INACT ; inactivate exam
+1 NEW LOOP
+2 SET LOOP=0
+3 FOR
SET LOOP=$ORDER(^DVB(396.6,LOOP))
if 'LOOP
QUIT
Begin DoDot:1
+4 SET DIE="^DVB(396.6,"
SET DA=+LOOP
SET DR=".5///I"
+5 DO ^DIE
+6 KILL DIE,DA,DR
End DoDot:1
+7 QUIT
+8 ;
NEW(EN) ; add new exam
+1 KILL DD,DO,DIC,DA
+2 SET DIC="^DVB(396.6,"
SET DIC(0)="LZ"
SET X=NAME
SET DINUM=EN
+3 SET DIC("DR")=".07///"_WKS_";.5///"_STAT_";2///"_BDY_";6///"_PNM_";7///"_ROU
+4 DO FILE^DICN
+5 IF +Y=-1
IF $DATA(^DVB(396.6,EN))
Begin DoDot:1
+6 ;have entry already, make sure fields are all populated correctly
+7 SET DA=EN
SET DIE="^DVB(396.6,"
+8 SET DR=".07///"_WKS_";.5///"_STAT_";2///"_BDY_";6///"_PNM_";7///"_ROU_";.01///"_NAME
+9 DO ^DIE
+10 KILL DIE,DA,DR
End DoDot:1
+11 IF '$DATA(^DVB(396.6,EN))
DO MES^XPDUTL("Unable to add exam, "_NAME_", IEN= ",EN)
+12 KILL DIC,X,Y,DINUM
+13 QUIT
