ACDENVCK ;IHS/ADC/EDE/KML - ENVIRONMENT CHECK ROUTINE FOR V4.1;
;;4.1;CHEMICAL DEPENDENCY MIS;;MAY 11, 1998
;
START ;
; kill off gbl left by v4.0 post-init
K ^ACDTEMP ; kills temp global SAC EXEMPTION (2.3.2.3 killing of unsubscripted globals is prohibited)
D ^XBKVAR
S ACDQ=0
W !!,"Beginning ENVIRONMENTAL CHECK routine."
D DUZ ; check DUZ values
I ACDQ D STOP,EOJ Q ; quit if not good DUZ values
D VIRGIN ; check for virgin install
I ACDQ D EOJ Q ; quit if virgin install
D FILE200 ; check file 6/200
I ACDQ D STOP,EOJ Q ; quit if 6/200 cnv bad
D VERSION ; check current version
I ACDQ D STOP,EOJ Q ; quit if not v4.0/v4.1
D SERVICE ; check for OTH service
I ACDQ D STOP,EOJ Q ; quit if no OTH
D LOCATION ; check for SCHOOL
I ACDQ D STOP,EOJ Q ; quit if no SCHOOL
D COMPONEN ; check for DROP IN CENTER
I ACDQ D STOP,EOJ Q ; quit if no DROP IN CENTER
D PCCCHK ; check for PCC link
W !!,"This initialization will delete all data from your CDMIS PROGRAM"
W !,"file except the site name. If you have data in that file that you"
W !,"don't want to lose do not continue with this install."
W !
S DIR(0)="Y",DIR("A")="Do you want to continue with this install",DIR("B")="Y" K DA D ^DIR K DIR
I 'Y D STOP,EOJ Q
D EOJ
Q
;
DUZ ; GET CORRECT DUZ VALUES
S ACDQ=1
I '$G(DUZ) D
. W !!,"DUZ is not set. I am going to do ^XUP. You must enter your ACCESS Code but"
. W !,"just press RETURN to the Select OPTION NAME: prompt.",!
. D XUP
. Q
I '$G(DUZ) W !,"DUZ is still not set." Q
I $G(DUZ(0))'["@" W !!,"You must have programmer access to run this install.",! Q
S ACDQ=0
Q
;
XUP ; DO ^XUP
NEW ACDQ,DIFQ
D ^XUP
Q
;
VIRGIN ; CHECK FOR VIRGIN INSTALL
S ACDQ=1
K ^TMP("ACD",$J)
S ^TMP("ACD",$J,"VIRGIN INSTALL")=""
S Y=$O(^DIC(9.4,"C","ACD",0))
I 'Y W !,"VIRGIN install. No further checking necessary." Q
K ^TMP("ACD",$J,"VIRGIN INSTALL")
S ACDQ=0
Q
;
VERSION ; CHECK FOR VERSION 4.0
S Y=$O(^DIC(9.4,"C","ACD",0))
Q:'Y ; no package entry to check
S ACDQ=1
S ACDVER=^DIC(9.4,Y,"VERSION")
I +ACDVER=4.1 D Q
. W !
. S DIR(0)="Y",DIR("A")="You already have version 4.1. Do you want to run this install again",DIR("B")="N" K DA D ^DIR K DIR
. I Y S ACDQ=0 Q
. W !!,"Terminating install.",!
. Q
I ACDVER<4 D Q
. W !!,"The current version is ",ACDVER
. W !,"You must install version 4.0 before you upgrade to version 4.1"
. W !!,"Terminating install.",!
. Q
I ACDVER'="4.0" D Q
. W !!,"The current version is ",ACDVER
. W !,"You must install version 4.0 before you upgrade to version 4.1"
. S DIR(0)="Y",DIR("A")="Do you want to run this install",DIR("B")="N" K DA D ^DIR K DIR
. I Y S ACDQ=0 Q
. W !!,"Terminating install.",!
. Q
S ACDQ=0
Q
;
SERVICE ; check for OTH service
S ACDQ=1
S Y=$O(^ACDSERV("C","OTH",0))
I 'Y W !!,"There is no 'OTH' entry in your CDMIS SERVICE file." Q
S ACDQ=0
Q
;
LOCATION ; check for SCHOOL location
S ACDQ=1
S Y=$O(^ACDLOT("C",1,0))
I 'Y W !!,"There is no 'SCHOOL' entry in your CDMIS LOCATION file." Q
S ACDQ=0
Q
;
COMPONEN ; check for DROP IN CENTER component
S ACDQ=1
S Y=$O(^ACDCOMP("B","DROP IN CENTER",0))
I 'Y W !!,"There is no 'DROP IN CENTER' entry in your CDMIS COMPONENT file." Q
S ACDQ=0
Q
;
PCCCHK ; CHECK FOR PCC ENVIRONMENT
D ^ACDPCCLC
Q
;
STOP ; STOP THE INSTALL
W !!,"Terminating this install.",!!
K DIFQ
Q
;
EOJ ;
K ACDQ,ACDVER
Q
;
;
FILE200 ; CHECK FOR FILES 6/200 CONVERSION
;
; This routine checks the environment for file 6 to 200
; conversion.
;
START2 ;
D INIT2
I ACDQ S:'ACDBAD ACDQ=0 Q
D MAIN
S ACDQ=$S(ACDBAD:1,1:0)
K ACDBAD
Q
;
INIT2 ; INITIALIZATION
S (ACDBAD,ACDQ)=0
I $D(^ACDCNV("B","1")) D S ACDQ=1 Q ; quit if conversion done
. W !,"File 6 to file 200 conversion already done.",!
. Q
S X="AVAPCHK"
X ^%ZOSF("TEST")
I '$T W !!,"^AVAPCHK routine missing!",! S (ACDBAD,ACDQ)=1 Q
Q
;
MAIN ;
D CHKPRV ; check file 3,6,16,200
Q:ACDQ ; quit if not ok
D CHKACDF ; check ACD fields
Q:ACDQ ; quit if not ok
Q
;
CHKPRV ; CHECK FILE 3, 6, 16, 200
S ACDQ=1
W !!,"I am going to make sure your USER, PROVIDER, PERSON,",!," and NEW PERSON files are in sync. Please wait.",!
D EN^AVAPCHK
I '$D(^AVA("OK")) S ACDBAD=1 W !,"Files not in sync. Do RESULTS^AVAPCHK to see errors and fix",!," before trying this install again.",! Q
S ACDQ=0
Q
;
CHKACDF ; CHECK CDMIS FIELDS
W !,"I am now going to make sure your CDMIS provider pointers",!," are all convertible. Please wait.",!
D CHK70P7 ; check file 9002170.7 (CDMIS PREVENTION)
D CHK72 ; check file 9002172 (CDMIS CLIENT SVCS)
D CHK72P1 ; check file 9002172.1 (CDMIS VISIT)
D CHK72P7 ; check file 9002172.7 (CDMIS CLIENT SVCS COPY SET)
D CHK73P5 ; check file 9002173.5 (CDMIS NTERVENTIONS)
I ACDBAD W !,"Some provider pointers are not convertible. Fix errors before",!," trying this install again.",!
Q
;
CHK70P7 ; CHECK FILE 9002170.7
W !,"Checking file 9002170.7",!
NEW D0,D1,D2
S D0=0
F S D0=$O(^ACDPD(D0)) Q:'D0 I $D(^ACDPD(D0,0)) D
. S Y=$P(^ACDPD(D0,0),U,5)
. I Y D CONVERT
. S D1=0
. F S D1=$O(^ACDPD(D0,1,D1)) Q:'D1 I $D(^ACDPD(D0,1,D1,0)) D
.. S D2=0
.. F S D2=$O(^ACDPD(D0,1,D1,"PRV",D2)) Q:'D2 I $D(^ACDPD(D0,1,D1,"PRV",D2,0)) D
... S Y=$P(^ACDPD(D0,1,D1,"PRV",D2,0),U)
... Q:'Y
... D CONVERT
... Q
.. Q
. Q
Q
;
CHK72 ; CHECK FILE 9002172
W !,"Checking file 9002172",!
NEW D0,D1
S D0=0
F S D0=$O(^ACDCS(D0)) Q:'D0 I $D(^ACDCS(D0,0)) D
. S D1=0
. F S D1=$O(^ACDCS(D0,1,D1)) Q:'D1 I $D(^ACDCS(D0,1,D1,0)) D
.. S Y=$P(^ACDCS(D0,1,D1,0),U)
.. Q:'Y
.. D CONVERT
.. Q
. Q
Q
;
CHK72P1 ; CHECK FILE 9002172.1
W !,"Checking file 9002172.1",!
S D0=0
F S D0=$O(^ACDVIS(D0)) Q:'D0 I $D(^ACDVIS(D0,0)) D
. S Y=$P(^ACDVIS(D0,0),U,3)
. Q:'Y
. D CONVERT
. Q
Q
;
CHK72P7 ; CHECK FILE 9002172.7
W !,"Checking file 9002172.7",!
NEW D0,D1,D2
S D0=0
F S D0=$O(^ACDCSCS(D0)) Q:'D0 I $D(^ACDCSCS(D0,0)) D
. S D1=0
. F S D1=$O(^ACDCSCS(D0,11,D1)) Q:'D1 I $D(^ACDCSCS(D0,11,D1,0)) D
.. S D2=0
.. F S D2=$O(^ACDCSCS(D0,11,D1,11,D2)) Q:'D2 I $D(^ACDCSCS(D0,11,D1,11,D2,0)) D
... S Y=$P(^ACDCSCS(D0,11,D1,11,D2,0),U)
... Q:'Y
... D CONVERT
... Q
.. Q
. Q
Q
;
CHK73P5 ; CHECK FILE 9002173.5
W !,"Checking file 9002173.5",!
NEW D0,D1
S D0=0
F S D0=$O(^ACDINTV(D0)) Q:'D0 I $D(^ACDINTV(D0,0)) D
. S D1=0
. F S D1=$O(^ACDINTV(D0,2,D1)) Q:'D1 I $D(^ACDINTV(D0,2,D1,0)) D
.. S Y=$P(^ACDINTV(D0,2,D1,0),U)
.. Q:'Y
.. D CONVERT
.. Q
. Q
Q
;
CONVERT ; CONVERT FILE 6 POINTER TO FILE 200 POINTER
NEW E,M,ACDZR,X
S ACDZR=$$LGR^%ZOSV ; save file entry
D CONVERT2 ; see if ptr converts
I E D Q ; write error and exit
. W ACDZR,!," "_$P($T(CONVERR+E),";;",2),!," "_M,!
. S ACDBAD=1
. Q
Q
;
CONVERR ; ERROR DESCRIPTIONS
;;Dangling pointer to file 6
;;File 6 pointer not in file 16
;;No A3 node in file 16
;;A3 pointer null or not numeric
;;No entry in file 200 for A3 pointer
;
CONVERT2 ;
S E=0
S M="File 6 ptr="_Y
I '$D(^DIC(6,Y,0)) S E=1 Q ; dangling 6 ptr
I '$D(^DIC(16,Y,0)) S E=2 Q ; 6 ptr not in 16
I '$D(^DIC(16,Y,"A3")) S E=3 Q ; no A3 node in 16
S X=^DIC(16,Y,"A3")
I 'X S E=4 Q ; A3 ptr null or not numeric
S M=M_", A3 ptr="_X
I '$D(^VA(200,X,0)) S E=5 Q ; no 200 entry for A3 ptr
Q
ACDENVCK ;IHS/ADC/EDE/KML - ENVIRONMENT CHECK ROUTINE FOR V4.1;
+1 ;;4.1;CHEMICAL DEPENDENCY MIS;;MAY 11, 1998
+2 ;
START ;
+1 ; kill off gbl left by v4.0 post-init
+2 ; kills temp global SAC EXEMPTION (2.3.2.3 killing of unsubscripted globals is prohibited)
KILL ^ACDTEMP
+3 DO ^XBKVAR
+4 SET ACDQ=0
+5 WRITE !!,"Beginning ENVIRONMENTAL CHECK routine."
+6 ; check DUZ values
DO DUZ
+7 ; quit if not good DUZ values
IF ACDQ
DO STOP
DO EOJ
QUIT
+8 ; check for virgin install
DO VIRGIN
+9 ; quit if virgin install
IF ACDQ
DO EOJ
QUIT
+10 ; check file 6/200
DO FILE200
+11 ; quit if 6/200 cnv bad
IF ACDQ
DO STOP
DO EOJ
QUIT
+12 ; check current version
DO VERSION
+13 ; quit if not v4.0/v4.1
IF ACDQ
DO STOP
DO EOJ
QUIT
+14 ; check for OTH service
DO SERVICE
+15 ; quit if no OTH
IF ACDQ
DO STOP
DO EOJ
QUIT
+16 ; check for SCHOOL
DO LOCATION
+17 ; quit if no SCHOOL
IF ACDQ
DO STOP
DO EOJ
QUIT
+18 ; check for DROP IN CENTER
DO COMPONEN
+19 ; quit if no DROP IN CENTER
IF ACDQ
DO STOP
DO EOJ
QUIT
+20 ; check for PCC link
DO PCCCHK
+21 WRITE !!,"This initialization will delete all data from your CDMIS PROGRAM"
+22 WRITE !,"file except the site name. If you have data in that file that you"
+23 WRITE !,"don't want to lose do not continue with this install."
+24 WRITE !
+25 SET DIR(0)="Y"
SET DIR("A")="Do you want to continue with this install"
SET DIR("B")="Y"
KILL DA
DO ^DIR
KILL DIR
+26 IF 'Y
DO STOP
DO EOJ
QUIT
+27 DO EOJ
+28 QUIT
+29 ;
DUZ ; GET CORRECT DUZ VALUES
+1 SET ACDQ=1
+2 IF '$GET(DUZ)
Begin DoDot:1
+3 WRITE !!,"DUZ is not set. I am going to do ^XUP. You must enter your ACCESS Code but"
+4 WRITE !,"just press RETURN to the Select OPTION NAME: prompt.",!
+5 DO XUP
+6 QUIT
End DoDot:1
+7 IF '$GET(DUZ)
WRITE !,"DUZ is still not set."
QUIT
+8 IF $GET(DUZ(0))'["@"
WRITE !!,"You must have programmer access to run this install.",!
QUIT
+9 SET ACDQ=0
+10 QUIT
+11 ;
XUP ; DO ^XUP
+1 NEW ACDQ,DIFQ
+2 DO ^XUP
+3 QUIT
+4 ;
VIRGIN ; CHECK FOR VIRGIN INSTALL
+1 SET ACDQ=1
+2 KILL ^TMP("ACD",$JOB)
+3 SET ^TMP("ACD",$JOB,"VIRGIN INSTALL")=""
+4 SET Y=$ORDER(^DIC(9.4,"C","ACD",0))
+5 IF 'Y
WRITE !,"VIRGIN install. No further checking necessary."
QUIT
+6 KILL ^TMP("ACD",$JOB,"VIRGIN INSTALL")
+7 SET ACDQ=0
+8 QUIT
+9 ;
VERSION ; CHECK FOR VERSION 4.0
+1 SET Y=$ORDER(^DIC(9.4,"C","ACD",0))
+2 ; no package entry to check
IF 'Y
QUIT
+3 SET ACDQ=1
+4 SET ACDVER=^DIC(9.4,Y,"VERSION")
+5 IF +ACDVER=4.1
Begin DoDot:1
+6 WRITE !
+7 SET DIR(0)="Y"
SET DIR("A")="You already have version 4.1. Do you want to run this install again"
SET DIR("B")="N"
KILL DA
DO ^DIR
KILL DIR
+8 IF Y
SET ACDQ=0
QUIT
+9 WRITE !!,"Terminating install.",!
+10 QUIT
End DoDot:1
QUIT
+11 IF ACDVER<4
Begin DoDot:1
+12 WRITE !!,"The current version is ",ACDVER
+13 WRITE !,"You must install version 4.0 before you upgrade to version 4.1"
+14 WRITE !!,"Terminating install.",!
+15 QUIT
End DoDot:1
QUIT
+16 IF ACDVER'="4.0"
Begin DoDot:1
+17 WRITE !!,"The current version is ",ACDVER
+18 WRITE !,"You must install version 4.0 before you upgrade to version 4.1"
+19 SET DIR(0)="Y"
SET DIR("A")="Do you want to run this install"
SET DIR("B")="N"
KILL DA
DO ^DIR
KILL DIR
+20 IF Y
SET ACDQ=0
QUIT
+21 WRITE !!,"Terminating install.",!
+22 QUIT
End DoDot:1
QUIT
+23 SET ACDQ=0
+24 QUIT
+25 ;
SERVICE ; check for OTH service
+1 SET ACDQ=1
+2 SET Y=$ORDER(^ACDSERV("C","OTH",0))
+3 IF 'Y
WRITE !!,"There is no 'OTH' entry in your CDMIS SERVICE file."
QUIT
+4 SET ACDQ=0
+5 QUIT
+6 ;
LOCATION ; check for SCHOOL location
+1 SET ACDQ=1
+2 SET Y=$ORDER(^ACDLOT("C",1,0))
+3 IF 'Y
WRITE !!,"There is no 'SCHOOL' entry in your CDMIS LOCATION file."
QUIT
+4 SET ACDQ=0
+5 QUIT
+6 ;
COMPONEN ; check for DROP IN CENTER component
+1 SET ACDQ=1
+2 SET Y=$ORDER(^ACDCOMP("B","DROP IN CENTER",0))
+3 IF 'Y
WRITE !!,"There is no 'DROP IN CENTER' entry in your CDMIS COMPONENT file."
QUIT
+4 SET ACDQ=0
+5 QUIT
+6 ;
PCCCHK ; CHECK FOR PCC ENVIRONMENT
+1 DO ^ACDPCCLC
+2 QUIT
+3 ;
STOP ; STOP THE INSTALL
+1 WRITE !!,"Terminating this install.",!!
+2 KILL DIFQ
+3 QUIT
+4 ;
EOJ ;
+1 KILL ACDQ,ACDVER
+2 QUIT
+3 ;
+4 ;
FILE200 ; CHECK FOR FILES 6/200 CONVERSION
+1 ;
+2 ; This routine checks the environment for file 6 to 200
+3 ; conversion.
+4 ;
START2 ;
+1 DO INIT2
+2 IF ACDQ
IF 'ACDBAD
SET ACDQ=0
QUIT
+3 DO MAIN
+4 SET ACDQ=$SELECT(ACDBAD:1,1:0)
+5 KILL ACDBAD
+6 QUIT
+7 ;
INIT2 ; INITIALIZATION
+1 SET (ACDBAD,ACDQ)=0
+2 ; quit if conversion done
IF $DATA(^ACDCNV("B","1"))
Begin DoDot:1
+3 WRITE !,"File 6 to file 200 conversion already done.",!
+4 QUIT
End DoDot:1
SET ACDQ=1
QUIT
+5 SET X="AVAPCHK"
+6 XECUTE ^%ZOSF("TEST")
+7 IF '$TEST
WRITE !!,"^AVAPCHK routine missing!",!
SET (ACDBAD,ACDQ)=1
QUIT
+8 QUIT
+9 ;
MAIN ;
+1 ; check file 3,6,16,200
DO CHKPRV
+2 ; quit if not ok
IF ACDQ
QUIT
+3 ; check ACD fields
DO CHKACDF
+4 ; quit if not ok
IF ACDQ
QUIT
+5 QUIT
+6 ;
CHKPRV ; CHECK FILE 3, 6, 16, 200
+1 SET ACDQ=1
+2 WRITE !!,"I am going to make sure your USER, PROVIDER, PERSON,",!," and NEW PERSON files are in sync. Please wait.",!
+3 DO EN^AVAPCHK
+4 IF '$DATA(^AVA("OK"))
SET ACDBAD=1
WRITE !,"Files not in sync. Do RESULTS^AVAPCHK to see errors and fix",!," before trying this install again.",!
QUIT
+5 SET ACDQ=0
+6 QUIT
+7 ;
CHKACDF ; CHECK CDMIS FIELDS
+1 WRITE !,"I am now going to make sure your CDMIS provider pointers",!," are all convertible. Please wait.",!
+2 ; check file 9002170.7 (CDMIS PREVENTION)
DO CHK70P7
+3 ; check file 9002172 (CDMIS CLIENT SVCS)
DO CHK72
+4 ; check file 9002172.1 (CDMIS VISIT)
DO CHK72P1
+5 ; check file 9002172.7 (CDMIS CLIENT SVCS COPY SET)
DO CHK72P7
+6 ; check file 9002173.5 (CDMIS NTERVENTIONS)
DO CHK73P5
+7 IF ACDBAD
WRITE !,"Some provider pointers are not convertible. Fix errors before",!," trying this install again.",!
+8 QUIT
+9 ;
CHK70P7 ; CHECK FILE 9002170.7
+1 WRITE !,"Checking file 9002170.7",!
+2 NEW D0,D1,D2
+3 SET D0=0
+4 FOR
SET D0=$ORDER(^ACDPD(D0))
IF 'D0
QUIT
IF $DATA(^ACDPD(D0,0))
Begin DoDot:1
+5 SET Y=$PIECE(^ACDPD(D0,0),U,5)
+6 IF Y
DO CONVERT
+7 SET D1=0
+8 FOR
SET D1=$ORDER(^ACDPD(D0,1,D1))
IF 'D1
QUIT
IF $DATA(^ACDPD(D0,1,D1,0))
Begin DoDot:2
+9 SET D2=0
+10 FOR
SET D2=$ORDER(^ACDPD(D0,1,D1,"PRV",D2))
IF 'D2
QUIT
IF $DATA(^ACDPD(D0,1,D1,"PRV",D2,0))
Begin DoDot:3
+11 SET Y=$PIECE(^ACDPD(D0,1,D1,"PRV",D2,0),U)
+12 IF 'Y
QUIT
+13 DO CONVERT
+14 QUIT
End DoDot:3
+15 QUIT
End DoDot:2
+16 QUIT
End DoDot:1
+17 QUIT
+18 ;
CHK72 ; CHECK FILE 9002172
+1 WRITE !,"Checking file 9002172",!
+2 NEW D0,D1
+3 SET D0=0
+4 FOR
SET D0=$ORDER(^ACDCS(D0))
IF 'D0
QUIT
IF $DATA(^ACDCS(D0,0))
Begin DoDot:1
+5 SET D1=0
+6 FOR
SET D1=$ORDER(^ACDCS(D0,1,D1))
IF 'D1
QUIT
IF $DATA(^ACDCS(D0,1,D1,0))
Begin DoDot:2
+7 SET Y=$PIECE(^ACDCS(D0,1,D1,0),U)
+8 IF 'Y
QUIT
+9 DO CONVERT
+10 QUIT
End DoDot:2
+11 QUIT
End DoDot:1
+12 QUIT
+13 ;
CHK72P1 ; CHECK FILE 9002172.1
+1 WRITE !,"Checking file 9002172.1",!
+2 SET D0=0
+3 FOR
SET D0=$ORDER(^ACDVIS(D0))
IF 'D0
QUIT
IF $DATA(^ACDVIS(D0,0))
Begin DoDot:1
+4 SET Y=$PIECE(^ACDVIS(D0,0),U,3)
+5 IF 'Y
QUIT
+6 DO CONVERT
+7 QUIT
End DoDot:1
+8 QUIT
+9 ;
CHK72P7 ; CHECK FILE 9002172.7
+1 WRITE !,"Checking file 9002172.7",!
+2 NEW D0,D1,D2
+3 SET D0=0
+4 FOR
SET D0=$ORDER(^ACDCSCS(D0))
IF 'D0
QUIT
IF $DATA(^ACDCSCS(D0,0))
Begin DoDot:1
+5 SET D1=0
+6 FOR
SET D1=$ORDER(^ACDCSCS(D0,11,D1))
IF 'D1
QUIT
IF $DATA(^ACDCSCS(D0,11,D1,0))
Begin DoDot:2
+7 SET D2=0
+8 FOR
SET D2=$ORDER(^ACDCSCS(D0,11,D1,11,D2))
IF 'D2
QUIT
IF $DATA(^ACDCSCS(D0,11,D1,11,D2,0))
Begin DoDot:3
+9 SET Y=$PIECE(^ACDCSCS(D0,11,D1,11,D2,0),U)
+10 IF 'Y
QUIT
+11 DO CONVERT
+12 QUIT
End DoDot:3
+13 QUIT
End DoDot:2
+14 QUIT
End DoDot:1
+15 QUIT
+16 ;
CHK73P5 ; CHECK FILE 9002173.5
+1 WRITE !,"Checking file 9002173.5",!
+2 NEW D0,D1
+3 SET D0=0
+4 FOR
SET D0=$ORDER(^ACDINTV(D0))
IF 'D0
QUIT
IF $DATA(^ACDINTV(D0,0))
Begin DoDot:1
+5 SET D1=0
+6 FOR
SET D1=$ORDER(^ACDINTV(D0,2,D1))
IF 'D1
QUIT
IF $DATA(^ACDINTV(D0,2,D1,0))
Begin DoDot:2
+7 SET Y=$PIECE(^ACDINTV(D0,2,D1,0),U)
+8 IF 'Y
QUIT
+9 DO CONVERT
+10 QUIT
End DoDot:2
+11 QUIT
End DoDot:1
+12 QUIT
+13 ;
CONVERT ; CONVERT FILE 6 POINTER TO FILE 200 POINTER
+1 NEW E,M,ACDZR,X
+2 ; save file entry
SET ACDZR=$$LGR^%ZOSV
+3 ; see if ptr converts
DO CONVERT2
+4 ; write error and exit
IF E
Begin DoDot:1
+5 WRITE ACDZR,!," "_$PIECE($TEXT(CONVERR+E),";;",2),!," "_M,!
+6 SET ACDBAD=1
+7 QUIT
End DoDot:1
QUIT
+8 QUIT
+9 ;
CONVERR ; ERROR DESCRIPTIONS
+1 ;;Dangling pointer to file 6
+2 ;;File 6 pointer not in file 16
+3 ;;No A3 node in file 16
+4 ;;A3 pointer null or not numeric
+5 ;;No entry in file 200 for A3 pointer
+6 ;
CONVERT2 ;
+1 SET E=0
+2 SET M="File 6 ptr="_Y
+3 ; dangling 6 ptr
IF '$DATA(^DIC(6,Y,0))
SET E=1
QUIT
+4 ; 6 ptr not in 16
IF '$DATA(^DIC(16,Y,0))
SET E=2
QUIT
+5 ; no A3 node in 16
IF '$DATA(^DIC(16,Y,"A3"))
SET E=3
QUIT
+6 SET X=^DIC(16,Y,"A3")
+7 ; A3 ptr null or not numeric
IF 'X
SET E=4
QUIT
+8 SET M=M_", A3 ptr="_X
+9 ; no 200 entry for A3 ptr
IF '$DATA(^VA(200,X,0))
SET E=5
QUIT
+10 QUIT
