APCH20P9.m

APCH20P9 ; IHS/TUCSON/LAB - PCC HEALTH SUMMARY POST INIT PATCH 9 ;  [ 08/31/02  4:53 PM ]

 ;;2.0;IHS RPMS/PCC Health Summary;**9**;JUN 24, 1997

 ;

 ;

 ; The following line prevents the "Disable Options..." and "Move

 ; Routines..." questions from being asked during the install.

 I $G(XPDENV)=1 S (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0

 ;

 Q

PRE ;EP - pre init

 S DA=$O(^APCHSCMP("B","REFERRED CARE",0)) I DA D

 .S $P(^APCHSCMP(DA,0),U,3)="Y"

 I '$O(^APCHSCMP("B","MICROBIOLOGY",0)) D

 .D ^XBFMK S DIC="^APCHSCMP(",X="MICROBIOLOGY",DIC("DR")="2////Y",DIC(0)="L" K DD,DO,D0 D FILE^DICN

 .I Y=-1 W !!,"adding health summary component MICROBIOLOGY failed." D ^XBFMK Q

 .S $P(^APCHSCMP(+Y,0),U,2)="MIC;APCHS3E"

 .S $P(^APCHSCMP(+Y,0),U,4)="MICROBIOLOGY - See Lab for History and Details"

 I '$O(^APCHSCMP("B","BLOOD BANK - MOST RECENT",0)) D

 .D ^XBFMK S DIC="^APCHSCMP(",X="BLOOD BANK - MOST RECENT",DIC("DR")="2////Y",DIC(0)="L" K DD,DO,D0 D FILE^DICN

 .I Y=-1 W !!,"adding health summary component BLOOD BANK failed." D ^XBFMK Q

 .S $P(^APCHSCMP(+Y,0),U,2)="MRL;APCHS3F"

 .S $P(^APCHSCMP(+Y,0),U,4)="BLOOD BANK (MOST RECENT) - See Lab for History and Details"

 I '$O(^APCHSCMP("B","PATIENT ED - MOST RECENT BY TOPIC",0)) D

 .D ^XBFMK S DIC="^APCHSCMP(",X="PATIENT ED - MOST RECENT BY TOPIC",DIC("DR")="2////Y",DIC(0)="L" K DD,DO,D0 D FILE^DICN

 .I Y=-1 W !!,"adding health summary component PATIENT ED - MOST RECENT BY TOPIC failed." D ^XBFMK Q

 .S $P(^APCHSCMP(+Y,0),U,2)="MRPE;APCHS10"

 I '$O(^APCHSCMP("B","MEDS - CHRONIC EXCLUDING D/C'ED MEDS",0)) D

 .D ^XBFMK S DIC="^APCHSCMP(",X="MEDS - CHRONIC EXCLUDING D/C'ED MEDS",DIC("DR")="2////Y",DIC(0)="L" K DD,DO,D0 D FILE^DICN

 .I Y=-1 W !!,"adding health summary component MEDS - CHRONIC EXCLUDING D/C'ED MEDS failed." D ^XBFMK Q

 .S $P(^APCHSCMP(+Y,0),U,2)="MEDSCHR1;APCHS7"

 .S $P(^APCHSCMP(+Y,0),U,4)="CHRONIC MEDS (AS INDICATED BY PHARMACIST)-EXCL D/C'ed MEDS"

 S DA=$O(^APCHSCTL("B","PATIENT MERGE (COMPLETE)",0))

 I DA K ^APCHSCTL(DA,1)

 Q

POST ;

DMADA ;

 S ATXFLG=1

 W !,"Updating APCH ADA Codes Taxonomy..."

 S APCHTX=0 S APCHTX=$O(^ATXAX("B","APCH DM ADA EXAMS",APCHTX))

 I APCHTX G TX1

 S X="APCH DM ADA EXAMS",DIC="^ATXAX(",DIC(0)="L",DIADD=1,DLAYGO=9002226 D ^DIC K DIC,DA,DIADD,DLAYGO,I I Y=-1 W !!,"ERROR IN CREATING APCH DM ADA EXAMS TAXONOMY" G BUL

 S APCHTX=+Y,$P(^ATXAX(APCHTX,0),U,2)="ADA CODES FOR DM EXAM",$P(^(0),U,5)=DUZ,$P(^(0),U,8)=0,$P(^(0),U,9)=DT,$P(^(0),U,12)=174,$P(^(0),U,13)=0,$P(^(0),U,15)=9999999.31,^ATXAX(APCHTX,21,0)="^9002226.02101A^0^0"

TX1 S APCHTEXT="ADA" F APCHX=1:1:5 S X=$P($T(@APCHTEXT+APCHX),";;",2),DIC="^AUTTADA(",DIC(0)="M" D ^DIC K DIC,DA,DR,DIADD,DLAYGO,DQ,DI,D1,D0 I $P(Y,U)>0 D

 .S Y=+Y Q:$D(^ATXAX(APCHTX,21,"B",Y))  ;this code is already there.

 .S APCHY=0 F  S APCHY=$O(^ATXAX(APCHTX,21,APCHY)) Q:APCHY'=+APCHY  S APCHL=APCHY

 .S APCHL=APCHL+1,^ATXAX(APCHTX,21,APCHL,0)=Y,$P(^ATXAX(APCHTX,21,APCHL,0),U,2)=Y,$P(^ATXAX(APCHTX,21,0),U,3)=APCHL,$P(^(0),U,4)=APCHL,^ATXAX(APCHTX,21,"AA",Y,Y)="",^ATXAX(APCHTX,21,"B",Y,APCHL)=""

 .Q

 S DA=APCHTX,DIK="^ATXAX(" D IX1^DIK

 K APCHTX,APCHDA,APCHTEXT,ATXFLG

 D ^XBFMK

BUL ;

 D ^APCHBUL9

 Q

 ;

ADA ;

 ;;0120

 ;;0150

 ;;0114

 ;;9320

 ;;9321

 ;;

APCH20P9  ; IHS/TUCSON/LAB - PCC HEALTH SUMMARY POST INIT PATCH 9 ;  [ 08/31/02  4:53 PM ]

 +1       ;;2.0;IHS RPMS/PCC Health Summary;**9**;JUN 24, 1997

 +2       ;

 +3       ;

 +4       ; The following line prevents the "Disable Options..." and "Move

 +5       ; Routines..." questions from being asked during the install.

 +6        IF $GET(XPDENV)=1

               SET (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0

 +7       ;

 +8        QUIT 

PRE       ;EP - pre init

 +1        SET DA=$ORDER(^APCHSCMP("B","REFERRED CARE",0))

           IF DA

               Begin DoDot:1

 +2                SET $PIECE(^APCHSCMP(DA,0),U,3)="Y"

               End DoDot:1

 +3        IF '$ORDER(^APCHSCMP("B","MICROBIOLOGY",0))

               Begin DoDot:1

 +4                DO ^XBFMK

                   SET DIC="^APCHSCMP("

                   SET X="MICROBIOLOGY"

                   SET DIC("DR")="2////Y"

                   SET DIC(0)="L"

                   KILL DD,DO,D0

                   DO FILE^DICN

 +5                IF Y=-1

                       WRITE !!,"adding health summary component MICROBIOLOGY failed."

                       DO ^XBFMK

                       QUIT 

 +6                SET $PIECE(^APCHSCMP(+Y,0),U,2)="MIC;APCHS3E"

 +7                SET $PIECE(^APCHSCMP(+Y,0),U,4)="MICROBIOLOGY - See Lab for History and Details"

               End DoDot:1

 +8        IF '$ORDER(^APCHSCMP("B","BLOOD BANK - MOST RECENT",0))

               Begin DoDot:1

 +9                DO ^XBFMK

                   SET DIC="^APCHSCMP("

                   SET X="BLOOD BANK - MOST RECENT"

                   SET DIC("DR")="2////Y"

                   SET DIC(0)="L"

                   KILL DD,DO,D0

                   DO FILE^DICN

 +10               IF Y=-1

                       WRITE !!,"adding health summary component BLOOD BANK failed."

                       DO ^XBFMK

                       QUIT 

 +11               SET $PIECE(^APCHSCMP(+Y,0),U,2)="MRL;APCHS3F"

 +12               SET $PIECE(^APCHSCMP(+Y,0),U,4)="BLOOD BANK (MOST RECENT) - See Lab for History and Details"

               End DoDot:1

 +13       IF '$ORDER(^APCHSCMP("B","PATIENT ED - MOST RECENT BY TOPIC",0))

               Begin DoDot:1

 +14               DO ^XBFMK

                   SET DIC="^APCHSCMP("

                   SET X="PATIENT ED - MOST RECENT BY TOPIC"

                   SET DIC("DR")="2////Y"

                   SET DIC(0)="L"

                   KILL DD,DO,D0

                   DO FILE^DICN

 +15               IF Y=-1

                       WRITE !!,"adding health summary component PATIENT ED - MOST RECENT BY TOPIC failed."

                       DO ^XBFMK

                       QUIT 

 +16               SET $PIECE(^APCHSCMP(+Y,0),U,2)="MRPE;APCHS10"

               End DoDot:1

 +17       IF '$ORDER(^APCHSCMP("B","MEDS - CHRONIC EXCLUDING D/C'ED MEDS",0))

               Begin DoDot:1

 +18               DO ^XBFMK

                   SET DIC="^APCHSCMP("

                   SET X="MEDS - CHRONIC EXCLUDING D/C'ED MEDS"

                   SET DIC("DR")="2////Y"

                   SET DIC(0)="L"

                   KILL DD,DO,D0

                   DO FILE^DICN

 +19               IF Y=-1

                       WRITE !!,"adding health summary component MEDS - CHRONIC EXCLUDING D/C'ED MEDS failed."

                       DO ^XBFMK

                       QUIT 

 +20               SET $PIECE(^APCHSCMP(+Y,0),U,2)="MEDSCHR1;APCHS7"

 +21               SET $PIECE(^APCHSCMP(+Y,0),U,4)="CHRONIC MEDS (AS INDICATED BY PHARMACIST)-EXCL D/C'ed MEDS"

               End DoDot:1

 +22       SET DA=$ORDER(^APCHSCTL("B","PATIENT MERGE (COMPLETE)",0))

 +23       IF DA

               KILL ^APCHSCTL(DA,1)

 +24       QUIT 

POST      ;

DMADA     ;

 +1        SET ATXFLG=1

 +2        WRITE !,"Updating APCH ADA Codes Taxonomy..."

 +3        SET APCHTX=0

           SET APCHTX=$ORDER(^ATXAX("B","APCH DM ADA EXAMS",APCHTX))

 +4        IF APCHTX

               GOTO TX1

 +5        SET X="APCH DM ADA EXAMS"

           SET DIC="^ATXAX("

           SET DIC(0)="L"

           SET DIADD=1

           SET DLAYGO=9002226

           DO ^DIC

           KILL DIC,DA,DIADD,DLAYGO,I

           IF Y=-1

               WRITE !!,"ERROR IN CREATING APCH DM ADA EXAMS TAXONOMY"

               GOTO BUL

 +6        SET APCHTX=+Y

           SET $PIECE(^ATXAX(APCHTX,0),U,2)="ADA CODES FOR DM EXAM"

           SET $PIECE(^(0),U,5)=DUZ

           SET $PIECE(^(0),U,8)=0

           SET $PIECE(^(0),U,9)=DT

           SET $PIECE(^(0),U,12)=174

           SET $PIECE(^(0),U,13)=0

           SET $PIECE(^(0),U,15)=9999999.31

           SET ^ATXAX(APCHTX,21,0)="^9002226.02101A^0^0"

TX1        SET APCHTEXT="ADA"

           FOR APCHX=1:1:5

               SET X=$PIECE($TEXT(@APCHTEXT+APCHX),";;",2)

               SET DIC="^AUTTADA("

               SET DIC(0)="M"

               DO ^DIC

               KILL DIC,DA,DR,DIADD,DLAYGO,DQ,DI,D1,D0

               IF $PIECE(Y,U)>0

                   Begin DoDot:1

 +1       ;this code is already there.

                       SET Y=+Y

                       IF $DATA(^ATXAX(APCHTX,21,"B",Y))

                           QUIT 

 +2                    SET APCHY=0

                       FOR 

                           SET APCHY=$ORDER(^ATXAX(APCHTX,21,APCHY))

                           IF APCHY'=+APCHY

                               QUIT 

                           SET APCHL=APCHY

 +3                    SET APCHL=APCHL+1

                       SET ^ATXAX(APCHTX,21,APCHL,0)=Y

                       SET $PIECE(^ATXAX(APCHTX,21,APCHL,0),U,2)=Y

                       SET $PIECE(^ATXAX(APCHTX,21,0),U,3)=APCHL

                       SET $PIECE(^(0),U,4)=APCHL

                       SET ^ATXAX(APCHTX,21,"AA",Y,Y)=""

                       SET ^ATXAX(APCHTX,21,"B",Y,APCHL)=""

 +4                    QUIT 

                   End DoDot:1

 +5        SET DA=APCHTX

           SET DIK="^ATXAX("

           DO IX1^DIK

 +6        KILL APCHTX,APCHDA,APCHTEXT,ATXFLG

 +7        DO ^XBFMK

BUL       ;

 +1        DO ^APCHBUL9

 +2        QUIT 

 +3       ;

ADA       ;

 +1       ;;0120

 +2       ;;0150

 +3       ;;0114

 +4       ;;9320

 +5       ;;9321

 +6       ;;