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
Q
DIFGX ;
K APCHDA,APCHN,APCHJ,APCHY,APCHVAL,APCHIEN,APCHX
K DIFG,DIFGER,DIC,DA,DIADD,DLAYGO,DIFGY,DINUM
Q
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
Q
;=====================================================================
;
;
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)
