ADEXCOD ; IHS/HQT/MJL - UPDATE ADA CODE FILE ;08:42 PM [ 03/24/1999 9:04 AM ]
;;6.0;ADE;;APRIL 1999
;------->INIT
S U="^"
I $D(^ADEXCOD)<10 D K DIFQ G END1
. W !!,*7,"The ADEXCOD global must be restored before installing the IHS DENTAL package.",!,"Please review the installation instructions."
I $P(^ADEXCOD(0),U)'["9-1-94" D K DIFQ G END1
. W !!,*7,"The CURRENT VERSION of the ADEXCOD global must be restored",!,"before installing the IHS DENTAL package. Please review the installation",!,"instructions."
;
CONF S %=0
W !,"Did you back up the ^AUTTADA global before beginning this installation"
D YN^DICN
I %=0 W !?5,"Answer NO if you did not save a backup of the ^AUTTADA global before",!,"beginning this installation.",! G CONF
I %'=1 W !!,"Back up ^AUTTADA before installing the IHS DENTAL package.",!,"Keep the backup on file." K DIFQ G END1
W !!,"CHECKING FOR DUPLICATE CODES AND REINDEXING"
D ^ADEXCOD2
W !!,"UPDATING ADA CODE FILE NOW."
;W !,"TEST--SKIPPING UPDATE" G END ;***COMMENT AND KEEP
;Set Input Transforms
S ADEY=0
F ADEX=.01:.01:.09,8801 S ADEY=ADEY+1,ADEXFRM(ADEY)=$P(^DD(9999999.31,ADEX,0),U,5,99)
S ADECOD=0,ADEXFRM(8)=""
CTRL ;------->$O THRU TEMPFILE ^ADEXCOD AND GET CODE
S ADECOD=$O(^ADEXCOD("B",ADECOD)) G:ADECOD="" END
S ADEZDFN=0 W "." S ADEZDFN=$O(^ADEXCOD("B",ADECOD,ADEZDFN))
;------->IF CODE IN ^AUTTADA, UPDATE
I $D(^AUTTADA("B",ADECOD)) D UPDATE G CTRL
;------->OTHERWISE ADD IT
D ADD G CTRL
END W !,"ADA CODE File update done!"
END1 K ADERROR,ADEODFN,ADEZDFN,ADECOD,ADEOMN,ADEX,ADEY,ADEXFRM,ADENOD
;
RESTYP ;Re-index DENTAL RESOURCE TYPE file
Q:'$D(^ADERSCT)
W !!,"Re-indexing the DENTAL RESOURCE TYPE file - please wait.",!
K ^ADERSCT("B") ;Kill "b" x-ref prior to re-index
S DIK="^ADERSCT("
D IXALL^DIK
Q
;
UPDATE S ADEODFN=0
;
U1 S ADEODFN=$O(^AUTTADA("B",ADECOD,ADEODFN))
G:$O(^AUTTADA("B",ADECOD,ADEODFN))]"" U1
;KILL OLD "C" AND "D" XREFS
I $P(^AUTTADA(ADEODFN,0),U,2)]"" K ^AUTTADA("C",$E($P(^AUTTADA(ADEODFN,0),U,2),1,30),ADEODFN)
I $P(^AUTTADA(ADEODFN,0),U,6)]"" K ^AUTTADA("D",$E($P(^AUTTADA(ADEODFN,0),U,6),1,30),ADEODFN)
;S ^AUTTADA(ADEODFN,0)=^ADEXCOD(ADEZDFN,0)
S ADENOD=^ADEXCOD(ADEZDFN,0)
F ADEX=1:1:9 D
. S X=$P(ADENOD,U,ADEX)
. Q:X=""
. D Q:'$D(X) ;Apply input transform
. . X ADEXFRM(ADEX)
. S $P(^AUTTADA(ADEODFN,0),U,ADEX)=X
D XREF
K ^AUTTADA(ADEODFN,11) S:$D(^ADEXCOD(ADEZDFN,11,0)) ^AUTTADA(ADEODFN,11,0)=^ADEXCOD(ADEZDFN,11,0)
I $D(^ADEXCOD(ADEZDFN,11,0)) D TEXT
I $D(^AUTTADA(ADEODFN,88)),^(88)]"" S ADEOMN=^AUTTADA(ADEODFN,88) K ^AUTTADA("B",ADEOMN),^AUTTADA(ADEODFN,88)
I $D(^ADEXCOD(ADEZDFN,88)),^(88)]"" D
. S X=^ADEXCOD(ADEZDFN,88)
. X ADEXFRM(10) ;Apply input transform
. Q:'$D(X)
. S ^AUTTADA(ADEODFN,88)=X,^AUTTADA("B",$E(X,1,30),ADEODFN)=1
Q
ADD S ADEODFN=$P(^AUTTADA(0),U,3)+1
A1 I $D(^AUTTADA(ADEODFN)) S ADEODFN=ADEODFN+1 G A1
;S ^AUTTADA(ADEODFN,0)=^ADEXCOD(ADEZDFN,0) D XREF
S ADENOD=^ADEXCOD(ADEZDFN,0)
S ADEXFRM(8)=""
F ADEX=1:1:9 D
. S X=$P(ADENOD,U,ADEX)
. Q:X=""
. D Q:'$D(X) ;Apply input transform
. . X ADEXFRM(ADEX)
. S $P(^AUTTADA(ADEODFN,0),U,ADEX)=X
D XREF
S ^AUTTADA("B",$E(ADECOD,1,30),ADEODFN)=""
I $D(^ADEXCOD(ADEZDFN,11,0)) D
. S ^AUTTADA(ADEODFN,11,0)=^ADEXCOD(ADEZDFN,11,0)
. D TEXT
I $D(^ADEXCOD(ADEZDFN,88)),^(88)]"" D
. S X=^ADEXCOD(ADEZDFN,88)
. X ADEXFRM(10) ;Apply input transform
. Q:'$D(X)
. S ^AUTTADA(ADEODFN,88)=X,^AUTTADA("B",$E(X,1,30),ADEODFN)=1
S $P(^AUTTADA(0),U,3)=ADEODFN,$P(^(0),U,4)=$P(^(0),U,4)+1
Q
TEXT S ADETXT=0
;NOTE: There is NO input transform for the field set in next line
;because it is a Fileman word-processing field and Fileman doesn't
;put input-transforms on wp fields.
F S ADETXT=$O(^ADEXCOD(ADEZDFN,11,ADETXT)) Q:'+ADETXT S:$D(^ADEXCOD(ADEZDFN,11,ADETXT,0)) ^AUTTADA(ADEODFN,11,ADETXT,0)=^ADEXCOD(ADEZDFN,11,ADETXT,0)
Q
XREF S:$P(^AUTTADA(ADEODFN,0),U,2)]"" ^AUTTADA("C",$E($P(^AUTTADA(ADEODFN,0),U,2),1,30),ADEODFN)=""
S:$P(^AUTTADA(ADEODFN,0),U,6)]"" ^AUTTADA("D",$E($P(^AUTTADA(ADEODFN,0),U,6),1,30),ADEODFN)=""
S ^AUTTADA("BA",ADECOD_" ",ADEODFN)=""
Q
ADEXCOD ; IHS/HQT/MJL - UPDATE ADA CODE FILE ;08:42 PM [ 03/24/1999 9:04 AM ]
+1 ;;6.0;ADE;;APRIL 1999
+2 ;------->INIT
+3 SET U="^"
+4 IF $DATA(^ADEXCOD)<10
Begin DoDot:1
+5 WRITE !!,*7,"The ADEXCOD global must be restored before installing the IHS DENTAL package.",!,"Please review the installation instructions."
End DoDot:1
KILL DIFQ
GOTO END1
+6 IF $PIECE(^ADEXCOD(0),U)'["9-1-94"
Begin DoDot:1
+7 WRITE !!,*7,"The CURRENT VERSION of the ADEXCOD global must be restored",!,"before installing the IHS DENTAL package. Please review the installation",!,"instructions."
End DoDot:1
KILL DIFQ
GOTO END1
+8 ;
CONF SET %=0
+1 WRITE !,"Did you back up the ^AUTTADA global before beginning this installation"
+2 DO YN^DICN
+3 IF %=0
WRITE !?5,"Answer NO if you did not save a backup of the ^AUTTADA global before",!,"beginning this installation.",!
GOTO CONF
+4 IF %'=1
WRITE !!,"Back up ^AUTTADA before installing the IHS DENTAL package.",!,"Keep the backup on file."
KILL DIFQ
GOTO END1
+5 WRITE !!,"CHECKING FOR DUPLICATE CODES AND REINDEXING"
+6 DO ^ADEXCOD2
+7 WRITE !!,"UPDATING ADA CODE FILE NOW."
+8 ;W !,"TEST--SKIPPING UPDATE" G END ;***COMMENT AND KEEP
+9 ;Set Input Transforms
+10 SET ADEY=0
+11 FOR ADEX=.01:.01:.09,8801
SET ADEY=ADEY+1
SET ADEXFRM(ADEY)=$PIECE(^DD(9999999.31,ADEX,0),U,5,99)
+12 SET ADECOD=0
SET ADEXFRM(8)=""
CTRL ;------->$O THRU TEMPFILE ^ADEXCOD AND GET CODE
+1 SET ADECOD=$ORDER(^ADEXCOD("B",ADECOD))
IF ADECOD=""
GOTO END
+2 SET ADEZDFN=0
WRITE "."
SET ADEZDFN=$ORDER(^ADEXCOD("B",ADECOD,ADEZDFN))
+3 ;------->IF CODE IN ^AUTTADA, UPDATE
+4 IF $DATA(^AUTTADA("B",ADECOD))
DO UPDATE
GOTO CTRL
+5 ;------->OTHERWISE ADD IT
+6 DO ADD
GOTO CTRL
END WRITE !,"ADA CODE File update done!"
END1 KILL ADERROR,ADEODFN,ADEZDFN,ADECOD,ADEOMN,ADEX,ADEY,ADEXFRM,ADENOD
+1 ;
RESTYP ;Re-index DENTAL RESOURCE TYPE file
+1 IF '$DATA(^ADERSCT)
QUIT
+2 WRITE !!,"Re-indexing the DENTAL RESOURCE TYPE file - please wait.",!
+3 ;Kill "b" x-ref prior to re-index
KILL ^ADERSCT("B")
+4 SET DIK="^ADERSCT("
+5 DO IXALL^DIK
+6 QUIT
+7 ;
UPDATE SET ADEODFN=0
+1 ;
U1 SET ADEODFN=$ORDER(^AUTTADA("B",ADECOD,ADEODFN))
+1 IF $ORDER(^AUTTADA("B",ADECOD,ADEODFN))]""
GOTO U1
+2 ;KILL OLD "C" AND "D" XREFS
+3 IF $PIECE(^AUTTADA(ADEODFN,0),U,2)]""
KILL ^AUTTADA("C",$EXTRACT($PIECE(^AUTTADA(ADEODFN,0),U,2),1,30),ADEODFN)
+4 IF $PIECE(^AUTTADA(ADEODFN,0),U,6)]""
KILL ^AUTTADA("D",$EXTRACT($PIECE(^AUTTADA(ADEODFN,0),U,6),1,30),ADEODFN)
+5 ;S ^AUTTADA(ADEODFN,0)=^ADEXCOD(ADEZDFN,0)
+6 SET ADENOD=^ADEXCOD(ADEZDFN,0)
+7 FOR ADEX=1:1:9
Begin DoDot:1
+8 SET X=$PIECE(ADENOD,U,ADEX)
+9 IF X=""
QUIT
+10 ;Apply input transform
Begin DoDot:2
+11 XECUTE ADEXFRM(ADEX)
End DoDot:2
IF '$DATA(X)
QUIT
+12 SET $PIECE(^AUTTADA(ADEODFN,0),U,ADEX)=X
End DoDot:1
+13 DO XREF
+14 KILL ^AUTTADA(ADEODFN,11)
IF $DATA(^ADEXCOD(ADEZDFN,11,0))
SET ^AUTTADA(ADEODFN,11,0)=^ADEXCOD(ADEZDFN,11,0)
+15 IF $DATA(^ADEXCOD(ADEZDFN,11,0))
DO TEXT
+16 IF $DATA(^AUTTADA(ADEODFN,88))
IF ^(88)]""
SET ADEOMN=^AUTTADA(ADEODFN,88)
KILL ^AUTTADA("B",ADEOMN),^AUTTADA(ADEODFN,88)
+17 IF $DATA(^ADEXCOD(ADEZDFN,88))
IF ^(88)]""
Begin DoDot:1
+18 SET X=^ADEXCOD(ADEZDFN,88)
+19 ;Apply input transform
XECUTE ADEXFRM(10)
+20 IF '$DATA(X)
QUIT
+21 SET ^AUTTADA(ADEODFN,88)=X
SET ^AUTTADA("B",$EXTRACT(X,1,30),ADEODFN)=1
End DoDot:1
+22 QUIT
ADD SET ADEODFN=$PIECE(^AUTTADA(0),U,3)+1
A1 IF $DATA(^AUTTADA(ADEODFN))
SET ADEODFN=ADEODFN+1
GOTO A1
+1 ;S ^AUTTADA(ADEODFN,0)=^ADEXCOD(ADEZDFN,0) D XREF
+2 SET ADENOD=^ADEXCOD(ADEZDFN,0)
+3 SET ADEXFRM(8)=""
+4 FOR ADEX=1:1:9
Begin DoDot:1
+5 SET X=$PIECE(ADENOD,U,ADEX)
+6 IF X=""
QUIT
+7 ;Apply input transform
Begin DoDot:2
+8 XECUTE ADEXFRM(ADEX)
End DoDot:2
IF '$DATA(X)
QUIT
+9 SET $PIECE(^AUTTADA(ADEODFN,0),U,ADEX)=X
End DoDot:1
+10 DO XREF
+11 SET ^AUTTADA("B",$EXTRACT(ADECOD,1,30),ADEODFN)=""
+12 IF $DATA(^ADEXCOD(ADEZDFN,11,0))
Begin DoDot:1
+13 SET ^AUTTADA(ADEODFN,11,0)=^ADEXCOD(ADEZDFN,11,0)
+14 DO TEXT
End DoDot:1
+15 IF $DATA(^ADEXCOD(ADEZDFN,88))
IF ^(88)]""
Begin DoDot:1
+16 SET X=^ADEXCOD(ADEZDFN,88)
+17 ;Apply input transform
XECUTE ADEXFRM(10)
+18 IF '$DATA(X)
QUIT
+19 SET ^AUTTADA(ADEODFN,88)=X
SET ^AUTTADA("B",$EXTRACT(X,1,30),ADEODFN)=1
End DoDot:1
+20 SET $PIECE(^AUTTADA(0),U,3)=ADEODFN
SET $PIECE(^(0),U,4)=$PIECE(^(0),U,4)+1
+21 QUIT
TEXT SET ADETXT=0
+1 ;NOTE: There is NO input transform for the field set in next line
+2 ;because it is a Fileman word-processing field and Fileman doesn't
+3 ;put input-transforms on wp fields.
+4 FOR
SET ADETXT=$ORDER(^ADEXCOD(ADEZDFN,11,ADETXT))
IF '+ADETXT
QUIT
IF $DATA(^ADEXCOD(ADEZDFN,11,ADETXT,0))
SET ^AUTTADA(ADEODFN,11,ADETXT,0)=^ADEXCOD(ADEZDFN,11,ADETXT,0)
+5 QUIT
XREF IF $PIECE(^AUTTADA(ADEODFN,0),U,2)]""
SET ^AUTTADA("C",$EXTRACT($PIECE(^AUTTADA(ADEODFN,0),U,2),1,30),ADEODFN)=""
+1 IF $PIECE(^AUTTADA(ADEODFN,0),U,6)]""
SET ^AUTTADA("D",$EXTRACT($PIECE(^AUTTADA(ADEODFN,0),U,6),1,30),ADEODFN)=""
+2 SET ^AUTTADA("BA",ADECOD_" ",ADEODFN)=""
+3 QUIT
