- 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