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 ;;
