Routine: APCHPOST

APCHPOST ; IHS/TUCSON/LAB - post-init routine ;  [ 06/24/97  2:42 PM ]

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

START ;start of routine

 W !?25,"* * * * * * * * * * * * *",!!

 W !!,"HEALTH SUMMARY POST-INIT"

 ; Loads taxonomy:  SURVEILLANCE PHYSICAL EXAM

 D ^APCHTX

 D ^XBFMK

 S APCHX=$O(^ATXAX("B","SURVEILLANCE PNEUMOCOCCAL RISK",0))

 S ATXX=APCHX D ZTM^ATXAX ;update these codes in icd9 file

 S ATXX=APCHX

 I '$D(^ATXPAT(ATXX,0)) S DIADD="",DIC="^ATXPAT(",DIC(0)="L",X="`"_ATXX,DIC("DR")=".02////"_DT_";.03////"_DUZ D ^DIC K DIADD,DIC,DR S ^ATXPAT(ATXX,11,0)="^9002227.01101PA^0^0"

 D TSKMN^ATXENP ;enter patients into patient taxonomy

 I '$D(^APCHTMP) W !!,$C(7),$C(7),"TMP global not restored!!" Q

MEASPAN ;install measurement panels

 S DIK="^AUTTMSR(",DIK(1)=".03^C" D ENALL^DIK ;reindex C on measurement type file

 I '$D(^APCHTMP) W !!,"Health Summary global APCHTMP not loaded!!!" D XIT Q

 W !,"Installing Measurement Panels"

 S APCHFG=0 F  S APCHFG=$O(^APCHTMP("MEASPAN",APCHFG)) Q:APCHFG'=+APCHFG  D

 .S DIFGLO="^APCHTMP(""MEASPAN"",APCHFG,"

 .S APCHN=$P(^APCHTMP("MEASPAN",APCHFG,2,0),"=",2)

 .W !,APCHN

 .S APCHDA=$O(^APCHSMPN("B",APCHN,0))

 .I APCHDA S DA=APCHDA,DIK="^APCHSMPN(" D ^DIK ;delete entry

 .K DA,DIK

 .S DIADD=1

 .I APCHDA S DINUM=APCHDA

 .D ^DIFG W "."

 .I $D(DIFGER) W "    *** FAILED INSTALL ***   ",DIFGER D DIFGX Q

 .S APCHDA=+DIFGY

 .S APCHY=$S(APCHN="ADULT STD":"AS",APCHN="ADULT STD METRIC":"ASM",APCHN="PEDIATRIC STD":"PS",APCHN="PEDIATRIC STD METRIC":"PSM",1:"")

 .Q:APCHY=""

 .F APCHJ=1:1 S APCHX=$T(@APCHY+APCHJ),APCHIEN=$P(APCHX,";;",2) Q:APCHIEN="QUIT"!(APCHIEN="")  D

 ..S APCHVAL=$P(APCHX,";;",3),^APCHSMPN(APCHDA,1,APCHIEN,1)=APCHVAL

 .D DIFGX

.Q

HSTYPE ;

 W !,"Installing Health Summary Types"

 S APCHFG=0 F  S APCHFG=$O(^APCHTMP("TYPE",APCHFG)) Q:APCHFG'=+APCHFG  D

 .S DIFGLO="^APCHTMP(""TYPE"",APCHFG,"

 .S APCHN=$P(^APCHTMP("TYPE",APCHFG,2,0),"=",2)

 .W !,APCHN

 .S APCHDA=$O(^APCHSCTL("B",APCHN,0))

 .I APCHDA S DA=APCHDA,DIK="^APCHSCTL(" D ^DIK ;delete entry

 .K DA,DIK

 .S DIADD=1

 .I APCHDA S DINUM=APCHDA

 .D ^DIFG W "."

 .I $D(DIFGER) W "    *** FAILED INSTALL ***   ",DIFGER D DIFGX Q

 .D DIFGX

.Q

 D XIT

DIFGX ;

 K APCHDA,APCHN,APCHJ,APCHY,APCHVAL,APCHIEN,APCHX

 K DIFG,DIFGER,DIC,DA,DIADD,DLAYGO,DIFGY,DINUM

XIT ;end of routine

 K ^APCHTMP ;unsubscripted temporary global to be used in install only

 D DIFGX

 W !!!!,"PCC Health Summary v2.0 has been successfully completed!!",!

 K APCHY,APCHX,APCHC,APCHFG,APCHTDFN

 ;=====================================================================

AS ;ADULT STD

 ;;20;;D BMI^APCHS2A1

 ;;25;;D RW^APCHS2A1

 ;;30;;S X=$S($G(APCHSVNM):APCHSVNM,1:20)_"/"_$P(X,"/",1)_"-"_$S($G(APCHSVNM):APCHSVNM,1:20)_"/"_$P(X,"/",2)

 ;;35;;S X=$S($G(APCHSVNM):APCHSVNM,1:20)_"/"_$P(X,"/",1)_"-"_$S($G(APCHSVNM):APCHSVNM,1:20)_"/"_$P(X,"/",2)

 ;;QUIT

PS ;PEDIATRIC STD

 ;;7;;D HTPER^APCHS2A1

 ;;12;;D WTPER^APCHS2A1

 ;;25;;S X=$S($G(APCHSVNM):APCHSVNM,1:20)_"/"_$P(X,"/",1)_"-"_$S($G(APCHSVNM):APCHSVNM,1:20)_"/"_$P(X,"/",2)

 ;;30;;S X=$S($G(APCHSVNM):APCHSVNM,1:20)_"/"_$P(X,"/",1)_"-"_$S($G(APCHSVNM):APCHSVNM,1:20)_"/"_$P(X,"/",2)

 ;;QUIT

ASM ;ADULT STD METRIC

 ;;5;;S X=X*2.54

 ;;10;;S X=X/2.2

 ;;20;;D BMI^APCHS2A1

 ;;25;;D RW^APCHS2A1

 ;;30;;S X=$S($G(APCHSVNM):APCHSVNM,1:20)_"/"_$P(X,"/",1)_"-"_$S($G(APCHSVNM):APCHSVNM,1:20)_"/"_$P(X,"/",2)

 ;;35;;S X=$S($G(APCHSVNM):APCHSVNM,1:20)_"/"_$P(X,"/",1)_"-"_$S($G(APCHSVNM):APCHSVNM,1:20)_"/"_$P(X,"/",2)

 ;;QUIT

PSM ;PEDIATRIC STD METRIC

 ;;5;;S X=X*2.54

 ;;7;;D HTPER^APCHS2A1

 ;;10;;S X=X/2.2

 ;;12;;D WTPER^APCHS2A1

 ;;20;;S X=X*2.54

 ;;25;;S X=$S($G(APCHSVNM):APCHSVNM,1:20)_"/"_$P(X,"/",1)_"-"_$S($G(APCHSVNM):APCHSVNM,1:20)_"/"_$P(X,"/",2)

 ;;30;;S X=$S($G(APCHSVNM):APCHSVNM,1:20)_"/"_$P(X,"/",1)_"-"_$S($G(APCHSVNM):APCHSVNM,1:20)_"/"_$P(X,"/",2)

APCHPOST  ; IHS/TUCSON/LAB - post-init routine ;  [ 06/24/97  2:42 PM ]

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

 +2       ;

START     ;start of routine

 +1        WRITE !?25,"* * * * * * * * * * * * *",!!

 +2        WRITE !!,"HEALTH SUMMARY POST-INIT"

 +3       ; Loads taxonomy:  SURVEILLANCE PHYSICAL EXAM

 +4        DO ^APCHTX

 +5        DO ^XBFMK

 +6        SET APCHX=$ORDER(^ATXAX("B","SURVEILLANCE PNEUMOCOCCAL RISK",0))

 +7       ;update these codes in icd9 file

           SET ATXX=APCHX

           DO ZTM^ATXAX

 +8        SET ATXX=APCHX

 +9        IF '$DATA(^ATXPAT(ATXX,0))

               SET DIADD=""

               SET DIC="^ATXPAT("

               SET DIC(0)="L"

               SET X="`"_ATXX

               SET DIC("DR")=".02////"_DT_";.03////"_DUZ

               DO ^DIC

               KILL DIADD,DIC,DR

               SET ^ATXPAT(ATXX,11,0)="^9002227.01101PA^0^0"

 +10      ;enter patients into patient taxonomy

           DO TSKMN^ATXENP

 +11       IF '$DATA(^APCHTMP)

               WRITE !!,$CHAR(7),$CHAR(7),"TMP global not restored!!"

               QUIT

MEASPAN   ;install measurement panels

 +1       ;reindex C on measurement type file

           SET DIK="^AUTTMSR("

           SET DIK(1)=".03^C"

           DO ENALL^DIK

 +2        IF '$DATA(^APCHTMP)

               WRITE !!,"Health Summary global APCHTMP not loaded!!!"

               DO XIT

               QUIT

 +3        WRITE !,"Installing Measurement Panels"

 +4        SET APCHFG=0

FOR

               SET APCHFG=$ORDER(^APCHTMP("MEASPAN",APCHFG))

               IF APCHFG'=+APCHFG

                   QUIT

               Begin DoDot:1

 +5                SET DIFGLO="^APCHTMP(""MEASPAN"",APCHFG,"

 +6                SET APCHN=$PIECE(^APCHTMP("MEASPAN",APCHFG,2,0),"=",2)

 +7                WRITE !,APCHN

 +8                SET APCHDA=$ORDER(^APCHSMPN("B",APCHN,0))

 +9       ;delete entry

                   IF APCHDA

                       SET DA=APCHDA

                       SET DIK="^APCHSMPN("

                       DO ^DIK

 +10               KILL DA,DIK

 +11               SET DIADD=1

 +12               IF APCHDA

                       SET DINUM=APCHDA

 +13               DO ^DIFG

                   WRITE "."

 +14               IF $DATA(DIFGER)

                       WRITE "    *** FAILED INSTALL ***   ",DIFGER

                       DO DIFGX

                       QUIT

 +15               SET APCHDA=+DIFGY

 +16               SET APCHY=$SELECT(APCHN="ADULT STD":"AS",APCHN="ADULT STD METRIC":"ASM",APCHN="PEDIATRIC STD":"PS",APCHN="PEDIATRIC STD METRIC":"PSM",1:"")

 +17               IF APCHY=""

                       QUIT

 +18               FOR APCHJ=1:1

                       SET APCHX=$TEXT(@APCHY+APCHJ)

                       SET APCHIEN=$PIECE(APCHX,";;",2)

                       IF APCHIEN="QUIT"!(APCHIEN="")

                           QUIT

                       Begin DoDot:2

 +19                       SET APCHVAL=$PIECE(APCHX,";;",3)

                           SET ^APCHSMPN(APCHDA,1,APCHIEN,1)=APCHVAL

                       End DoDot:2

 +20               DO DIFGX

 +21               QUIT

               End DoDot:1

HSTYPE    ;

 +1        WRITE !,"Installing Health Summary Types"

 +2        SET APCHFG=0

FOR

               SET APCHFG=$ORDER(^APCHTMP("TYPE",APCHFG))

               IF APCHFG'=+APCHFG

                   QUIT

               Begin DoDot:1

 +3                SET DIFGLO="^APCHTMP(""TYPE"",APCHFG,"

 +4                SET APCHN=$PIECE(^APCHTMP("TYPE",APCHFG,2,0),"=",2)

 +5                WRITE !,APCHN

 +6                SET APCHDA=$ORDER(^APCHSCTL("B",APCHN,0))

 +7       ;delete entry

                   IF APCHDA

                       SET DA=APCHDA

                       SET DIK="^APCHSCTL("

                       DO ^DIK

 +8                KILL DA,DIK

 +9                SET DIADD=1

 +10               IF APCHDA

                       SET DINUM=APCHDA

 +11               DO ^DIFG

                   WRITE "."

 +12               IF $DATA(DIFGER)

                       WRITE "    *** FAILED INSTALL ***   ",DIFGER

                       DO DIFGX

                       QUIT

 +13               DO DIFGX

 +14               QUIT

               End DoDot:1

 +15       DO XIT

 +16       QUIT

DIFGX     ;

 +1        KILL APCHDA,APCHN,APCHJ,APCHY,APCHVAL,APCHIEN,APCHX

 +2        KILL DIFG,DIFGER,DIC,DA,DIADD,DLAYGO,DIFGY,DINUM

 +3        QUIT

XIT       ;end of routine

 +1       ;unsubscripted temporary global to be used in install only

           KILL ^APCHTMP

 +2        DO DIFGX

 +3        WRITE !!!!,"PCC Health Summary v2.0 has been successfully completed!!",!

 +4        KILL APCHY,APCHX,APCHC,APCHFG,APCHTDFN

 +5        QUIT

 +6       ;=====================================================================

 +7       ;

 +8       ;

AS        ;ADULT STD

 +1       ;;20;;D BMI^APCHS2A1

 +2       ;;25;;D RW^APCHS2A1

 +3       ;;30;;S X=$S($G(APCHSVNM):APCHSVNM,1:20)_"/"_$P(X,"/",1)_"-"_$S($G(APCHSVNM):APCHSVNM,1:20)_"/"_$P(X,"/",2)

 +4       ;;35;;S X=$S($G(APCHSVNM):APCHSVNM,1:20)_"/"_$P(X,"/",1)_"-"_$S($G(APCHSVNM):APCHSVNM,1:20)_"/"_$P(X,"/",2)

 +5       ;;QUIT

PS        ;PEDIATRIC STD

 +1       ;;7;;D HTPER^APCHS2A1

 +2       ;;12;;D WTPER^APCHS2A1

 +3       ;;25;;S X=$S($G(APCHSVNM):APCHSVNM,1:20)_"/"_$P(X,"/",1)_"-"_$S($G(APCHSVNM):APCHSVNM,1:20)_"/"_$P(X,"/",2)

 +4       ;;30;;S X=$S($G(APCHSVNM):APCHSVNM,1:20)_"/"_$P(X,"/",1)_"-"_$S($G(APCHSVNM):APCHSVNM,1:20)_"/"_$P(X,"/",2)

 +5       ;;QUIT

ASM       ;ADULT STD METRIC

 +1       ;;5;;S X=X*2.54

 +2       ;;10;;S X=X/2.2

 +3       ;;20;;D BMI^APCHS2A1

 +4       ;;25;;D RW^APCHS2A1

 +5       ;;30;;S X=$S($G(APCHSVNM):APCHSVNM,1:20)_"/"_$P(X,"/",1)_"-"_$S($G(APCHSVNM):APCHSVNM,1:20)_"/"_$P(X,"/",2)

 +6       ;;35;;S X=$S($G(APCHSVNM):APCHSVNM,1:20)_"/"_$P(X,"/",1)_"-"_$S($G(APCHSVNM):APCHSVNM,1:20)_"/"_$P(X,"/",2)

 +7       ;;QUIT

PSM       ;PEDIATRIC STD METRIC

 +1       ;;5;;S X=X*2.54

 +2       ;;7;;D HTPER^APCHS2A1

 +3       ;;10;;S X=X/2.2

 +4       ;;12;;D WTPER^APCHS2A1

 +5       ;;20;;S X=X*2.54

 +6       ;;25;;S X=$S($G(APCHSVNM):APCHSVNM,1:20)_"/"_$P(X,"/",1)_"-"_$S($G(APCHSVNM):APCHSVNM,1:20)_"/"_$P(X,"/",2)

 +7       ;;30;;S X=$S($G(APCHSVNM):APCHSVNM,1:20)_"/"_$P(X,"/",1)_"-"_$S($G(APCHSVNM):APCHSVNM,1:20)_"/"_$P(X,"/",2)

APCHPOST.m