ACD4P1P.m

ACD4P1P ;IHS/ADC/EDE/KML - POST-INIT CONVERSIONS FOR V4.1; 

 ;;4.1;CHEMICAL DEPENDENCY MIS;;MAY 11, 1998

 ;

START ;

 W !!,"Beginning the post-init routine ",$T(+0)

 W !!,"Installing Protocols..." D ^ACDONIT

 W !!,"Installing List templates..." D ^ACDL

 I $D(^TMP("ACD",$J,"VIRGIN INSTALL")) W !!,"Virgin install so post-init not necessary.",! K ^TMP("ACD",$J) Q

 I '$G(DUZ)!($G(DUZ(0))'["@") W !!,"Either DUZ is not set or you do not have programmer access.  I don't",!,"know how you got here but I cannot run this post-int routine.",!! Q

 D PGMFIX ;                      kill most program data

 D VXREFS ;                      kill CDMIS VISIT xrefs

 D SERVICE ;                     convert CDMIS SERVICE file

 D LOCATION ;                    convert CDMIS LOCATION file

 D COMPONEN ;                    convert CDMIS COMPONENT file

 D REPOINT ;                     repoint data files

 D TOBACCO ;                     fix tobacco debacle

 D PROBS ;                       delete problems

 D FILE200 ;                     convert file 6 ptrs to file 200 ptrs

 D GBLKILL ;                     kill file gbls to be restored

 D EOJ

 Q

 ;

PGMFIX ; DELETE PROGRAM DATA

 S ACDPGM=0

 F  S ACDPGM=$O(^ACDF5PI(ACDPGM)) Q:'ACDPGM  D

 .  S ACDN11=$G(^ACDF5PI(ACDPGM,11))

 .  S DIK="^ACDF5PI(",DA=ACDPGM

 .  D DIK^ACDFMC

 .  S DIC="^ACDF5PI(",X="`"_ACDPGM,DIC(0)="LQ",DLAYGO=9002173

 .  D DIC^ACDFMC

 .  Q:ACDN11=""

 .  S ^ACDF5PI(ACDPGM,11)=ACDN11

 .  Q

 Q

 ;

VXREFS ; KILL CDMIS VISIT XREFS

 K ^ACDVIS("E")

 K ^ACDVIS("F")

 K ^ACDVIS("G")

 K ^ACDVIS("H")

 Q

 ;

SERVICE ; DELETE CDMIS SERVICE TP AND TPR

 W !!,"Now converting your CDMIS SERVICE file."

 S ACDSIEN("TP")=$O(^ACDSERV("C","TP",0))

 I ACDSIEN("TP") S DIK="^ACDSERV(",DA=ACDSIEN("TP") D DIK^ACDFMC W "."

 S ACDSIEN("TPR")=$O(^ACDSERV("C","TPR",0))

 I ACDSIEN("TPR") S DIK="^ACDSERV(",DA=ACDSIEN("TPR") D DIK^ACDFMC W "."

 S ACDSIEN("OTH")=$O(^ACDSERV("C","OTH",0))

 Q

 ;

LOCATION ; DELETE CDMIS LOCATION SCHOOL-*

 W !!,"Now converting your CDMIS LOCATION file."

 ; school-pre-headstart

 S ACDLIEN("11")=$O(^ACDLOT("C","11",0))

 I ACDLIEN("11") S DIK="^ACDLOT(",DA=ACDLIEN("11") D DIK^ACDFMC W "."

 ; school-primary

 S ACDLIEN("12")=$O(^ACDLOT("C","12",0))

 I ACDLIEN("12") S DIK="^ACDLOT(",DA=ACDLIEN("12") D DIK^ACDFMC W "."

 ; school-secondary

 S ACDLIEN("13")=$O(^ACDLOT("C","13",0))

 I ACDLIEN("13") S DIK="^ACDLOT(",DA=ACDLIEN("13") D DIK^ACDFMC W "."

 ; school-post secondary

 S ACDLIEN("14")=$O(^ACDLOT("C","14",0))

 I ACDLIEN("14") S DIK="^ACDLOT(",DA=ACDLIEN("14") D DIK^ACDFMC W "."

 ; school

 S ACDLIEN("1")=$O(^ACDLOT("C","1",0))

 Q

 ;

COMPONEN ; DELETE CDMIS COMPONENETS LARGE, SMALL, & SPECL DROP IN

 W !!,"Now converting your CDMIS COMPONENT file."

 S ACDCIEN("LARGE DROP IN")=$O(^ACDCOMP("B","LARGE DROP IN",0))

 I ACDCIEN("LARGE DROP IN") S DIK="^ACDCOMP(",DA=ACDCIEN("LARGE DROP IN") D DIK^ACDFMC W "."

 S ACDCIEN("SMALL DROP IN")=$O(^ACDCOMP("B","SMALL DROP IN",0))

 I ACDCIEN("SMALL DROP IN") S DIK="^ACDCOMP(",DA=ACDCIEN("SMALL DROP IN") D DIK^ACDFMC W "."

 S ACDCIEN("SPECL DROP IN")=$O(^ACDCOMP("B","SPECL DROP IN",0))

 I ACDCIEN("SPECL DROP IN") S DIK="^ACDCOMP(",DA=ACDCIEN("SPECL DROP IN") D DIK^ACDFMC W "."

 S ACDCIEN("DROP IN CENTER")=$O(^ACDCOMP("B","DROP IN CENTER",0))

 Q

 ;

REPOINT ; REPOINT DATA FILES

 W !!,"Now repointing files that point to the CDMIS COMPONENT file."

 S ACDGBL="^ACDIIF(",ACDFP="15;16,17;18,101;21"

 D REPOINT2 ;                   repoint init/info/fu

 S ACDGBL="^ACDPD(",ACDFP="1;2"

 D REPOINT2 ;                   repoint prevention

 S ACDGBL="^ACDTDC(",ACDFP="12;13,14;15"

 D REPOINT2 ;                   repoint trans/disc/close

 S ACDGBL="^ACDVIS(",ACDFP="1;2"

 D REPOINT2 ;                   repoint visit

 S ACDGBL="^ACDPAT(",ACDFP=".03;3"

 D REPOINT2 ;                   repoint client category

 S ACDGBL="^ACDINTV(",ACDFP="10;10,11;11"

 D REPOINT2 ;                   repoint interventions

 W !!,"Now repointing files that point to the CDMIS SERVICE file."

 S ACDRIEN=0

 F  S ACDRIEN=$O(^ACDCS(ACDRIEN)) Q:ACDRIEN'=+ACDRIEN  S X=$G(^ACDCS(ACDRIEN,0)),X=$P(X,U,3) D  D:ACDHIT REPCS

 . S ACDHIT=0

 . I X=ACDLIEN("11") S ACDHIT=1 Q

 . I X=ACDLIEN("12") S ACDHIT=1 Q

 . I X=ACDLIEN("13") S ACDHIT=1 Q

 . I X=ACDLIEN("14") S ACDHIT=1 Q

 . Q

 Q

 ;

REPOINT2 ; REPOINT SPECIFIC FILE

 S ACDRIEN=0

 F  S ACDRIEN=$O(@(ACDGBL_ACDRIEN_")")) Q:ACDRIEN'=+ACDRIEN  S ACDNODE0=$G(^(ACDRIEN,0)) D

 .  Q:ACDNODE0=""

 .  F ACDY=1:1 S X=$P(ACDFP,",",ACDY) Q:X=""  D

 ..  S F=$P(X,";"),P=$P(X,";",2)

 ..  S X=$P(ACDNODE0,U,P) D  D:ACDHIT REPF

 ...  S ACDHIT=0

 ...  I X=ACDCIEN("LARGE DROP IN") S ACDHIT=1 Q

 ...  I X=ACDCIEN("SMALL DROP IN") S ACDHIT=1 Q

 ...  I X=ACDCIEN("SPECL DROP IN") S ACDHIT=1 Q

 ...  Q

 ..  Q

 .  Q

 K F,P

 Q

 ;

REPF ; REPOINT FIELD

 S DIE=ACDGBL,DA=ACDRIEN,DR=F_"////"_ACDCIEN("DROP IN CENTER")

 D DIE^ACDFMC

 W "."

 Q

 ;

REPCS ; REPOINT CDMIS CLIENT SVCS

 S DIE="^ACDCS(",DA=ACDRIEN,DR="2////"_ACDLIEN("1")

 D DIE^ACDFMC

 W "."

 Q

 ;

TOBACCO ; DELETE TOBACCO FROM DRUGS USED AND SET NEW FIELD

 W !!,"Now converting tobacco use to new field."

 S ACDTOB1=$O(^ACDDRUG("B","TOBACCO (SMOKING)",0))

 S ACDTOB2=$O(^ACDDRUG("B","TOBACCO (SMOKELESS)",0))

 I 'ACDTOB1!('ACDTOB2) W !!,"Cannot locate TOBACCO entries in CDMIS DRUG file.  No conversion necessary.",! Q

 S ACDGBL="^ACDIIF("

 D TOBACCO2 ;                       fix init/info/fu

 S ACDGBL="^ACDTDC("

 D TOBACCO2 ;                       fix trans/disc/close

 F Y=ACDTOB1,ACDTOB2 S DIK="^ACDDRUG(",DA=Y D ^DIK

 Q

 ;

TOBACCO2 ; FIX ONE FILE

 S ACDRIEN=0

 F  S ACDRIEN=$O(@(ACDGBL_ACDRIEN_")")) Q:ACDRIEN'=+ACDRIEN  S ACDNODE0=$G(^(ACDRIEN,0)) D

 .  Q:ACDNODE0=""

 .  K ACDTOB

 .  S ACDMIEN=0

 .  ; drug multiple

 .  F  S ACDMIEN=$O(@(ACDGBL_ACDRIEN_",2,"_ACDMIEN_")")) Q:ACDMIEN'=+ACDMIEN  S X=+^(ACDMIEN,0)  D

 ..  I X'=ACDTOB1,X'=ACDTOB2 Q  ;     quit if not tobacco

 ..  S ACDTOB(X)=""  ;                save type of tobacco

 ..  S DIK=ACDGBL_ACDRIEN_",2,",DA(1)=ACDRIEN,DA=ACDMIEN D ^DIK

 ..  Q

 .  Q:'$D(ACDTOB)  ;                  no tobacco use for entry

 .  S Y=$O(ACDTOB(0)) ;               get type used

 .  S ACDTOB=$S(Y=ACDTOB1:1,1:2)

 .  S X=0

 .  F Y=ACDTOB1,ACDTOB2 S X=X+$D(ACDTOB(Y))

 .  S:X>1 ACDTOB=3 ;                  uses both kinds

 .  S DIE=ACDGBL,DA=ACDRIEN,DR="30////"_ACDTOB

 .  D DIE^ACDFMC

 .  W "."

 .  Q

 Q

 ;

PROBS ; DELETE SELECTED PROBLEMS FROM APPROPRIATE FILES

 W !!,"Now converting CDMIS PROBLEM file."

 S ACDPIEN=$O(^ACDPROB("C",51,0))

 I 'ACDPIEN W !!,"Cannot find PREVIOUS TREATMENT in CDMIS PROBLEM file.  No conversion necessary.",! Q

 S ACDGBL="^ACDIIF(",ACDNODE=3

 D PROBSDEL ;                       fix init/info/fu

 S ACDGBL="^ACDTDC(",ACDNODE=3

 D PROBSDEL ;                       fix trans/disc/close

 S ACDGBL="^ACDINTV(",ACDNODE=1

 D PROBSDEL ;                       fix interventions

 S DIK="^ACDPROB(",DA=ACDPIEN D ^DIK

 Q

 ;

PROBSDEL ; DELETE ENTRIES FROM FILE

 S ACDRIEN=0

 F  S ACDRIEN=$O(@(ACDGBL_ACDRIEN_")")) Q:ACDRIEN'=+ACDRIEN  D

 .  S ACDMIEN=0

 .  F  S ACDMIEN=$O(@(ACDGBL_ACDRIEN_","_ACDNODE_","_ACDMIEN_")")) Q:ACDMIEN'=+ACDMIEN  S Y=+^(ACDMIEN,0) D

 ..  Q:Y'=ACDPIEN  ;                   not previous treatment

 ..  S DIK=ACDGBL_ACDRIEN_","_ACDNODE_",",DA(1)=ACDRIEN,DA=ACDMIEN D ^DIK

 ..  Q

 .  Q

 Q

 ;

GBLKILL ; KILL GBLS TO BE RESTORED, INFORM OPERATOR

 W !!,"Selected file globals will now be killed.  You must now",!

 W "restore the globals from acd_0410.g",!!

 K ^ACDDRUG,^ACDLOT,^ACDSERV,^ACDPROB ; SAC EXEMPTION (2.3.2.3 Killing of unsubscripted globals is prohibited)

 Q

 ;

EOJ ;

 K ACDCIEN,ACDLIEN,ACDSIEN,ACDNODE,ACDPIEN,ACDRIEN,ACDY

 K ACDFP,ACDGBL,ACDHIT,ACDMIEN,ACDN11,ACDNODE0,ACDPGM,ACDTOB1,ACDTOB2

 Q

 ;

 ;

FILE200 ; CONVERT FILE 6 POINTERS TO FILE 200 POINTERS

 D ^ACD4P1PB

 Q

ACD4P1P   ;IHS/ADC/EDE/KML - POST-INIT CONVERSIONS FOR V4.1; 

 +1       ;;4.1;CHEMICAL DEPENDENCY MIS;;MAY 11, 1998

 +2       ;

START     ;

 +1        WRITE !!,"Beginning the post-init routine ",$TEXT(+0)

 +2        WRITE !!,"Installing Protocols..."

           DO ^ACDONIT

 +3        WRITE !!,"Installing List templates..."

           DO ^ACDL

 +4        IF $DATA(^TMP("ACD",$JOB,"VIRGIN INSTALL"))

               WRITE !!,"Virgin install so post-init not necessary.",!

               KILL ^TMP("ACD",$JOB)

               QUIT 

 +5        IF '$GET(DUZ)!($GET(DUZ(0))'["@")

               WRITE !!,"Either DUZ is not set or you do not have programmer access.  I don't",!,"know how you got here but I cannot run this post-int routine.",!!

               QUIT 

 +6       ;                      kill most program data

           DO PGMFIX

 +7       ;                      kill CDMIS VISIT xrefs

           DO VXREFS

 +8       ;                     convert CDMIS SERVICE file

           DO SERVICE

 +9       ;                    convert CDMIS LOCATION file

           DO LOCATION

 +10      ;                    convert CDMIS COMPONENT file

           DO COMPONEN

 +11      ;                     repoint data files

           DO REPOINT

 +12      ;                     fix tobacco debacle

           DO TOBACCO

 +13      ;                       delete problems

           DO PROBS

 +14      ;                     convert file 6 ptrs to file 200 ptrs

           DO FILE200

 +15      ;                     kill file gbls to be restored

           DO GBLKILL

 +16       DO EOJ

 +17       QUIT 

 +18      ;

PGMFIX    ; DELETE PROGRAM DATA

 +1        SET ACDPGM=0

 +2        FOR 

               SET ACDPGM=$ORDER(^ACDF5PI(ACDPGM))

               IF 'ACDPGM

                   QUIT 

               Begin DoDot:1

 +3                SET ACDN11=$GET(^ACDF5PI(ACDPGM,11))

 +4                SET DIK="^ACDF5PI("

                   SET DA=ACDPGM

 +5                DO DIK^ACDFMC

 +6                SET DIC="^ACDF5PI("

                   SET X="`"_ACDPGM

                   SET DIC(0)="LQ"

                   SET DLAYGO=9002173

 +7                DO DIC^ACDFMC

 +8                IF ACDN11=""

                       QUIT 

 +9                SET ^ACDF5PI(ACDPGM,11)=ACDN11

 +10               QUIT 

               End DoDot:1

 +11       QUIT 

 +12      ;

VXREFS    ; KILL CDMIS VISIT XREFS

 +1        KILL ^ACDVIS("E")

 +2        KILL ^ACDVIS("F")

 +3        KILL ^ACDVIS("G")

 +4        KILL ^ACDVIS("H")

 +5        QUIT 

 +6       ;

SERVICE   ; DELETE CDMIS SERVICE TP AND TPR

 +1        WRITE !!,"Now converting your CDMIS SERVICE file."

 +2        SET ACDSIEN("TP")=$ORDER(^ACDSERV("C","TP",0))

 +3        IF ACDSIEN("TP")

               SET DIK="^ACDSERV("

               SET DA=ACDSIEN("TP")

               DO DIK^ACDFMC

               WRITE "."

 +4        SET ACDSIEN("TPR")=$ORDER(^ACDSERV("C","TPR",0))

 +5        IF ACDSIEN("TPR")

               SET DIK="^ACDSERV("

               SET DA=ACDSIEN("TPR")

               DO DIK^ACDFMC

               WRITE "."

 +6        SET ACDSIEN("OTH")=$ORDER(^ACDSERV("C","OTH",0))

 +7        QUIT 

 +8       ;

LOCATION  ; DELETE CDMIS LOCATION SCHOOL-*

 +1        WRITE !!,"Now converting your CDMIS LOCATION file."

 +2       ; school-pre-headstart

 +3        SET ACDLIEN("11")=$ORDER(^ACDLOT("C","11",0))

 +4        IF ACDLIEN("11")

               SET DIK="^ACDLOT("

               SET DA=ACDLIEN("11")

               DO DIK^ACDFMC

               WRITE "."

 +5       ; school-primary

 +6        SET ACDLIEN("12")=$ORDER(^ACDLOT("C","12",0))

 +7        IF ACDLIEN("12")

               SET DIK="^ACDLOT("

               SET DA=ACDLIEN("12")

               DO DIK^ACDFMC

               WRITE "."

 +8       ; school-secondary

 +9        SET ACDLIEN("13")=$ORDER(^ACDLOT("C","13",0))

 +10       IF ACDLIEN("13")

               SET DIK="^ACDLOT("

               SET DA=ACDLIEN("13")

               DO DIK^ACDFMC

               WRITE "."

 +11      ; school-post secondary

 +12       SET ACDLIEN("14")=$ORDER(^ACDLOT("C","14",0))

 +13       IF ACDLIEN("14")

               SET DIK="^ACDLOT("

               SET DA=ACDLIEN("14")

               DO DIK^ACDFMC

               WRITE "."

 +14      ; school

 +15       SET ACDLIEN("1")=$ORDER(^ACDLOT("C","1",0))

 +16       QUIT 

 +17      ;

COMPONEN  ; DELETE CDMIS COMPONENETS LARGE, SMALL, & SPECL DROP IN

 +1        WRITE !!,"Now converting your CDMIS COMPONENT file."

 +2        SET ACDCIEN("LARGE DROP IN")=$ORDER(^ACDCOMP("B","LARGE DROP IN",0))

 +3        IF ACDCIEN("LARGE DROP IN")

               SET DIK="^ACDCOMP("

               SET DA=ACDCIEN("LARGE DROP IN")

               DO DIK^ACDFMC

               WRITE "."

 +4        SET ACDCIEN("SMALL DROP IN")=$ORDER(^ACDCOMP("B","SMALL DROP IN",0))

 +5        IF ACDCIEN("SMALL DROP IN")

               SET DIK="^ACDCOMP("

               SET DA=ACDCIEN("SMALL DROP IN")

               DO DIK^ACDFMC

               WRITE "."

 +6        SET ACDCIEN("SPECL DROP IN")=$ORDER(^ACDCOMP("B","SPECL DROP IN",0))

 +7        IF ACDCIEN("SPECL DROP IN")

               SET DIK="^ACDCOMP("

               SET DA=ACDCIEN("SPECL DROP IN")

               DO DIK^ACDFMC

               WRITE "."

 +8        SET ACDCIEN("DROP IN CENTER")=$ORDER(^ACDCOMP("B","DROP IN CENTER",0))

 +9        QUIT 

 +10      ;

REPOINT   ; REPOINT DATA FILES

 +1        WRITE !!,"Now repointing files that point to the CDMIS COMPONENT file."

 +2        SET ACDGBL="^ACDIIF("

           SET ACDFP="15;16,17;18,101;21"

 +3       ;                   repoint init/info/fu

           DO REPOINT2

 +4        SET ACDGBL="^ACDPD("

           SET ACDFP="1;2"

 +5       ;                   repoint prevention

           DO REPOINT2

 +6        SET ACDGBL="^ACDTDC("

           SET ACDFP="12;13,14;15"

 +7       ;                   repoint trans/disc/close

           DO REPOINT2

 +8        SET ACDGBL="^ACDVIS("

           SET ACDFP="1;2"

 +9       ;                   repoint visit

           DO REPOINT2

 +10       SET ACDGBL="^ACDPAT("

           SET ACDFP=".03;3"

 +11      ;                   repoint client category

           DO REPOINT2

 +12       SET ACDGBL="^ACDINTV("

           SET ACDFP="10;10,11;11"

 +13      ;                   repoint interventions

           DO REPOINT2

 +14       WRITE !!,"Now repointing files that point to the CDMIS SERVICE file."

 +15       SET ACDRIEN=0

 +16       FOR 

               SET ACDRIEN=$ORDER(^ACDCS(ACDRIEN))

               IF ACDRIEN'=+ACDRIEN

                   QUIT 

               SET X=$GET(^ACDCS(ACDRIEN,0))

               SET X=$PIECE(X,U,3)

               Begin DoDot:1

 +17               SET ACDHIT=0

 +18               IF X=ACDLIEN("11")

                       SET ACDHIT=1

                       QUIT 

 +19               IF X=ACDLIEN("12")

                       SET ACDHIT=1

                       QUIT 

 +20               IF X=ACDLIEN("13")

                       SET ACDHIT=1

                       QUIT 

 +21               IF X=ACDLIEN("14")

                       SET ACDHIT=1

                       QUIT 

 +22               QUIT 

               End DoDot:1

               IF ACDHIT

                   DO REPCS

 +23       QUIT 

 +24      ;

REPOINT2  ; REPOINT SPECIFIC FILE

 +1        SET ACDRIEN=0

 +2        FOR 

               SET ACDRIEN=$ORDER(@(ACDGBL_ACDRIEN_")"))

               IF ACDRIEN'=+ACDRIEN

                   QUIT 

               SET ACDNODE0=$GET(^(ACDRIEN,0))

               Begin DoDot:1

 +3                IF ACDNODE0=""

                       QUIT 

 +4                FOR ACDY=1:1

                       SET X=$PIECE(ACDFP,",",ACDY)

                       IF X=""

                           QUIT 

                       Begin DoDot:2

 +5                        SET F=$PIECE(X,";")

                           SET P=$PIECE(X,";",2)

 +6                        SET X=$PIECE(ACDNODE0,U,P)

                           Begin DoDot:3

 +7                            SET ACDHIT=0

 +8                            IF X=ACDCIEN("LARGE DROP IN")

                                   SET ACDHIT=1

                                   QUIT 

 +9                            IF X=ACDCIEN("SMALL DROP IN")

                                   SET ACDHIT=1

                                   QUIT 

 +10                           IF X=ACDCIEN("SPECL DROP IN")

                                   SET ACDHIT=1

                                   QUIT 

 +11                           QUIT 

                           End DoDot:3

                           IF ACDHIT

                               DO REPF

 +12                       QUIT 

                       End DoDot:2

 +13               QUIT 

               End DoDot:1

 +14       KILL F,P

 +15       QUIT 

 +16      ;

REPF      ; REPOINT FIELD

 +1        SET DIE=ACDGBL

           SET DA=ACDRIEN

           SET DR=F_"////"_ACDCIEN("DROP IN CENTER")

 +2        DO DIE^ACDFMC

 +3        WRITE "."

 +4        QUIT 

 +5       ;

REPCS     ; REPOINT CDMIS CLIENT SVCS

 +1        SET DIE="^ACDCS("

           SET DA=ACDRIEN

           SET DR="2////"_ACDLIEN("1")

 +2        DO DIE^ACDFMC

 +3        WRITE "."

 +4        QUIT 

 +5       ;

TOBACCO   ; DELETE TOBACCO FROM DRUGS USED AND SET NEW FIELD

 +1        WRITE !!,"Now converting tobacco use to new field."

 +2        SET ACDTOB1=$ORDER(^ACDDRUG("B","TOBACCO (SMOKING)",0))

 +3        SET ACDTOB2=$ORDER(^ACDDRUG("B","TOBACCO (SMOKELESS)",0))

 +4        IF 'ACDTOB1!('ACDTOB2)

               WRITE !!,"Cannot locate TOBACCO entries in CDMIS DRUG file.  No conversion necessary.",!

               QUIT 

 +5        SET ACDGBL="^ACDIIF("

 +6       ;                       fix init/info/fu

           DO TOBACCO2

 +7        SET ACDGBL="^ACDTDC("

 +8       ;                       fix trans/disc/close

           DO TOBACCO2

 +9        FOR Y=ACDTOB1,ACDTOB2

               SET DIK="^ACDDRUG("

               SET DA=Y

               DO ^DIK

 +10       QUIT 

 +11      ;

TOBACCO2  ; FIX ONE FILE

 +1        SET ACDRIEN=0

 +2        FOR 

               SET ACDRIEN=$ORDER(@(ACDGBL_ACDRIEN_")"))

               IF ACDRIEN'=+ACDRIEN

                   QUIT 

               SET ACDNODE0=$GET(^(ACDRIEN,0))

               Begin DoDot:1

 +3                IF ACDNODE0=""

                       QUIT 

 +4                KILL ACDTOB

 +5                SET ACDMIEN=0

 +6       ; drug multiple

 +7                FOR 

                       SET ACDMIEN=$ORDER(@(ACDGBL_ACDRIEN_",2,"_ACDMIEN_")"))

                       IF ACDMIEN'=+ACDMIEN

                           QUIT 

                       SET X=+^(ACDMIEN,0)

                       Begin DoDot:2

 +8       ;     quit if not tobacco

                           IF X'=ACDTOB1

                               IF X'=ACDTOB2

                                   QUIT 

 +9       ;                save type of tobacco

                           SET ACDTOB(X)=""

 +10                       SET DIK=ACDGBL_ACDRIEN_",2,"

                           SET DA(1)=ACDRIEN

                           SET DA=ACDMIEN

                           DO ^DIK

 +11                       QUIT 

                       End DoDot:2

 +12      ;                  no tobacco use for entry

                   IF '$DATA(ACDTOB)

                       QUIT 

 +13      ;               get type used

                   SET Y=$ORDER(ACDTOB(0))

 +14               SET ACDTOB=$SELECT(Y=ACDTOB1:1,1:2)

 +15               SET X=0

 +16               FOR Y=ACDTOB1,ACDTOB2

                       SET X=X+$DATA(ACDTOB(Y))

 +17      ;                  uses both kinds

                   IF X>1

                       SET ACDTOB=3

 +18               SET DIE=ACDGBL

                   SET DA=ACDRIEN

                   SET DR="30////"_ACDTOB

 +19               DO DIE^ACDFMC

 +20               WRITE "."

 +21               QUIT 

               End DoDot:1

 +22       QUIT 

 +23      ;

PROBS     ; DELETE SELECTED PROBLEMS FROM APPROPRIATE FILES

 +1        WRITE !!,"Now converting CDMIS PROBLEM file."

 +2        SET ACDPIEN=$ORDER(^ACDPROB("C",51,0))

 +3        IF 'ACDPIEN

               WRITE !!,"Cannot find PREVIOUS TREATMENT in CDMIS PROBLEM file.  No conversion necessary.",!

               QUIT 

 +4        SET ACDGBL="^ACDIIF("

           SET ACDNODE=3

 +5       ;                       fix init/info/fu

           DO PROBSDEL

 +6        SET ACDGBL="^ACDTDC("

           SET ACDNODE=3

 +7       ;                       fix trans/disc/close

           DO PROBSDEL

 +8        SET ACDGBL="^ACDINTV("

           SET ACDNODE=1

 +9       ;                       fix interventions

           DO PROBSDEL

 +10       SET DIK="^ACDPROB("

           SET DA=ACDPIEN

           DO ^DIK

 +11       QUIT 

 +12      ;

PROBSDEL  ; DELETE ENTRIES FROM FILE

 +1        SET ACDRIEN=0

 +2        FOR 

               SET ACDRIEN=$ORDER(@(ACDGBL_ACDRIEN_")"))

               IF ACDRIEN'=+ACDRIEN

                   QUIT 

               Begin DoDot:1

 +3                SET ACDMIEN=0

 +4                FOR 

                       SET ACDMIEN=$ORDER(@(ACDGBL_ACDRIEN_","_ACDNODE_","_ACDMIEN_")"))

                       IF ACDMIEN'=+ACDMIEN

                           QUIT 

                       SET Y=+^(ACDMIEN,0)

                       Begin DoDot:2

 +5       ;                   not previous treatment

                           IF Y'=ACDPIEN

                               QUIT 

 +6                        SET DIK=ACDGBL_ACDRIEN_","_ACDNODE_","

                           SET DA(1)=ACDRIEN

                           SET DA=ACDMIEN

                           DO ^DIK

 +7                        QUIT 

                       End DoDot:2

 +8                QUIT 

               End DoDot:1

 +9        QUIT 

 +10      ;

GBLKILL   ; KILL GBLS TO BE RESTORED, INFORM OPERATOR

 +1        WRITE !!,"Selected file globals will now be killed.  You must now",!

 +2        WRITE "restore the globals from acd_0410.g",!!

 +3       ; SAC EXEMPTION (2.3.2.3 Killing of unsubscripted globals is prohibited)

           KILL ^ACDDRUG,^ACDLOT,^ACDSERV,^ACDPROB

 +4        QUIT 

 +5       ;

EOJ       ;

 +1        KILL ACDCIEN,ACDLIEN,ACDSIEN,ACDNODE,ACDPIEN,ACDRIEN,ACDY

 +2        KILL ACDFP,ACDGBL,ACDHIT,ACDMIEN,ACDN11,ACDNODE0,ACDPGM,ACDTOB1,ACDTOB2

 +3        QUIT 

 +4       ;

 +5       ;

FILE200   ; CONVERT FILE 6 POINTERS TO FILE 200 POINTERS

 +1        DO ^ACD4P1PB

 +2        QUIT