APCHMT ; IHS/CMI/LAB -- create/modify health summary type ;
;;2.0;IHS PCC SUITE;**7**;MAY 14, 2009
;; ;
;routine to create/modify a health summary type
EP ;EP - called from option
W !!!,"This option will allow you to create a new or modify an existing"
W !,"health summary type.",!!
D ^XBFMK S DIC="^APCHSCTL(",DIC(0)="AEMQL" D ^DIC K DIC,DA,DR,DD,DO
I Y=-1 W !!,"Goodbye",! D EOJ Q
S %=$P(^APCHSCTL(+Y,0),U,2) I %]"",$D(^XUSEC(%,DUZ))[0 W !,"This summary type is currently locked to prevent alteration.",! G EP
S APCHDA=+Y
S DIE="^APCHSCTL(",DA=APCHDA,DR=".01;.05" D ^DIE D ^XBFMK
D EN
EOJ ;
D EN^XBVK("APCH")
D ^XBFMK
Q
EN ; -- main entry point for APCH CREATE/MODIFY TYPE
D EN^VALM("APCH CREATE/MODIFY TYPE")
D CLEAR^VALM1
D FULL^VALM1
W:$D(IOF) @IOF
D EOJ
Q
;
HDR ;EP -- header code
S VALMHDR(1)="Health Summary: " I $G(APCHDA),$D(^APCHSCTL(APCHDA)) S VALMHDR(1)=VALMHDR(1)_$P(^APCHSCTL(APCHDA,0),U)
Q
;
INIT ;EP -- init variables and list array
K ^TMP($J,"APCHTYPE")
S APCHC=0
NEW X,Y,O,C,M,T,A
S X="STRUCTURE: " D S(X)
S X="Order",$E(X,7)="Component",$E(X,49)="Max occ",$E(X,57)="Time",$E(X,62)="Alternate Title" D S(X)
S Y=0 F S Y=$O(^APCHSCTL(APCHDA,1,Y)) Q:Y'=+Y D
.S O=$P(^APCHSCTL(APCHDA,1,Y,0),U),C=$P(^APCHSCTL(APCHDA,1,Y,0),U,2),C=$P($G(^APCHSCMP(+C,0)),U,1)
.S M=$P(^APCHSCTL(APCHDA,1,Y,0),U,3),T=$P(^APCHSCTL(APCHDA,1,Y,0),U,4),A=$P(^APCHSCTL(APCHDA,1,Y,0),U,5)
.S X=O,$E(X,7)=C,$E(X,49)=M,$E(X,57)=T,$E(X,62)=A D S(X)
S X="GENERAL:" D S(X,1)
S X="Clinic Displayed on outpatient components: "_$$VAL^XBDIQ1(9001015,APCHDA,1.5) D S(X)
S X="ICD Text Display: "_$$VAL^XBDIQ1(9001015,APCHDA,2) D S(X)
S X="Provider Narrative Displayed: "_$$VAL^XBDIQ1(9001015,APCHDA,3) D S(X)
S X="Display Provider Initials in Outpatient components: "_$$VAL^XBDIQ1(9001015,APCHDA,3.6) D S(X)
S X="Provider Initials displayed on Medication components: "_$$VAL^XBDIQ1(9001015,APCHDA,3.7) D S(X)
S X="Lab Comments displayed in LAB component: "_$$VAL^XBDIQ1(9001015,APCHDA,3.8)
S X="Comments displayed with Reasons Service not done: "_$$VAL^XBDIQ1(9001015,APCHDA,3.9)
S X="MEASUREMENT PANELS: " D S(X,1) I '$O(^APCHSCTL(APCHDA,3,0)) D S("<none>") G LP
S X="Order",$E(X,7)="Panel" D S(X)
S Y=0 F S Y=$O(^APCHSCTL(APCHDA,3,Y)) Q:Y'=+Y D
.S O=$P(^APCHSCTL(APCHDA,3,Y,0),U),C=$P(^APCHSCTL(APCHDA,3,Y,0),U,2),C=$P($G(^APCHSMPN(+C,0)),U,1)
.S X=O,$E(X,7)=C D S(X)
LP ;
S X="LAB TEST PANELS: " D S(X,1) I '$O(^APCHSCTL(APCHDA,4,0)) D S("<none>") G HMR
S X="Order",$E(X,7)="Panel" D S(X)
S Y=0 F S Y=$O(^APCHSCTL(APCHDA,4,Y)) Q:Y'=+Y D
.S O=$P(^APCHSCTL(APCHDA,4,Y,0),U),C=$P(^APCHSCTL(APCHDA,4,Y,0),U,2),C=$P($G(^LAB(60,+C,0)),U,1)
.S X=O,$E(X,7)=C D S(X)
HMR ;
S X="HEALTH MAINTENANCE REMINDERS: " D S(X,1) I '$O(^APCHSCTL(APCHDA,5,0)) D S("<none>") G TP
S X="Order",$E(X,7)="Health Maintenance Reminder" D S(X)
S Y=0 F S Y=$O(^APCHSCTL(APCHDA,5,Y)) Q:Y'=+Y D
.S O=$P(^APCHSCTL(APCHDA,5,Y,0),U),C=$P(^APCHSCTL(APCHDA,5,Y,0),U,2),C=$P($G(^APCHSURV(+C,0)),U,1)
.S X=O,$E(X,7)=C D S(X)
TP ;
S X="BEST PRACTICE PROMPTS: " D S(X,1) I '$O(^APCHSCTL(APCHDA,13,0)) D S("<none>") G FS
S X="Order",$E(X,7)="Best Practice Prompt" D S(X)
S Y=0 F S Y=$O(^APCHSCTL(APCHDA,13,Y)) Q:Y'=+Y D
.S O=$P(^APCHSCTL(APCHDA,13,Y,0),U),C=$P(^APCHSCTL(APCHDA,13,Y,0),U,2),C=$P($G(^APCHSURV(+C,0)),U,1)
.S X=O,$E(X,7)=C D S(X)
FS ;
S X="FLOWSHEET: " D S(X,1) I '$O(^APCHSCTL(APCHDA,6,0)) D S("<none>") G HF
S X="Order",$E(X,7)="Flowsheet" D S(X)
S Y=0 F S Y=$O(^APCHSCTL(APCHDA,6,Y)) Q:Y'=+Y D
.S O=$P(^APCHSCTL(APCHDA,6,Y,0),U),C=$P(^APCHSCTL(APCHDA,6,Y,0),U,2),C=$P($G(^APCHSFLC(+C,0)),U,1)
.S X=O,$E(X,7)=C D S(X)
HF ;
S X="HEALTH FACTORS: " D S(X,1) I '$O(^APCHSCTL(APCHDA,7,0)) D S("<none>") G SP
S X="Order",$E(X,7)="Health Factor",$E(X,49)="Title",$E(X,70)="Most Recent" D S(X)
S Y=0 F S Y=$O(^APCHSCTL(APCHDA,7,Y)) Q:Y'=+Y D
.S O=$P(^APCHSCTL(APCHDA,7,Y,0),U),C=$P(^APCHSCTL(APCHDA,7,Y,0),U,2),C=$P($G(^AUTTHF(+C,0)),U,1),T=$P(^APCHSCTL(APCHDA,7,Y,0),U,3),M=$P(^APCHSCTL(APCHDA,7,Y,0),U,4),M=$$EXTSET^XBFUNC(9001015.08,3,M)
.S X=O,$E(X,7)=C,$E(X,49)=$E(T,1,20),$E(X,70)=M D S(X)
SP ;
S X="SUPPLEMENTS: " D S(X,1) I '$O(^APCHSCTL(APCHDA,12,0)) D S("<none>") G PCS
S X="Order",$E(X,7)="Supplement" D S(X)
S Y=0 F S Y=$O(^APCHSCTL(APCHDA,12,Y)) Q:Y'=+Y D
.S O=$P(^APCHSCTL(APCHDA,12,Y,0),U),C=$P(^APCHSCTL(APCHDA,12,Y,0),U,2),C=$P($G(^APCHSUP(+C,0)),U,1)
.S X=O,$E(X,7)=C_" "_$P(^APCHSCTL(APCHDA,12,Y,0),U,3) D S(X)
PCS ;
S X="Provider Class Screen for OUTPATIENT VISITS (SCREENED) component (IF USED): " D S(X,1)
I $O(^APCHSCTL(APCHDA,9,0)) S X="Provider Classes to be EXCLUDED" D S(X)
S Y=0 F S Y=$O(^APCHSCTL(APCHDA,9,Y)) Q:Y'=+Y D
.S C=$P(^APCHSCTL(APCHDA,9,Y,0),U),C=$P($G(^DIC(7,+C,0)),U,1)
.S X=C D S(X)
S X="CLINIC Screen for OUTPATIENT VISITS (SCREENED) component (IF USED): " D S(X,1)
I $O(^APCHSCTL(APCHDA,11,0)) S X="Clinics to be EXCLUDED" D S(X)
S Y=0 F S Y=$O(^APCHSCTL(APCHDA,11,Y)) Q:Y'=+Y D
.S C=$P(^APCHSCTL(APCHDA,11,Y,0),U),C=$P($G(^DIC(40.7,+C,0)),U,1)
.S X=C D S(X)
S VALMCNT=$O(^TMP($J,"APCHTYPE",""),-1)
Q
S(Y,F,C,T) ;EP - set up array
I '$G(F) S F=0
I '$G(T) S T=0
;blank lines
F F=1:1:F S X="" D S1
S X=Y
I $G(C) S L=$L(Y),T=(80-L)/2 D D S1 Q
.F %=1:1:(T-1) S X=" "_X
F %=1:1:T S X=" "_Y
D S1
Q
S1 ;
S APCHC=APCHC+1
S ^TMP($J,"APCHTYPE",APCHC,0)=X
Q
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- EXIT code
Q
;
EXPND ; -- expand code
Q
;
APCHMT ; IHS/CMI/LAB -- create/modify health summary type ;
+1 ;;2.0;IHS PCC SUITE;**7**;MAY 14, 2009
+2 ;; ;
+3 ;routine to create/modify a health summary type
EP ;EP - called from option
+1 WRITE !!!,"This option will allow you to create a new or modify an existing"
+2 WRITE !,"health summary type.",!!
+3 DO ^XBFMK
SET DIC="^APCHSCTL("
SET DIC(0)="AEMQL"
DO ^DIC
KILL DIC,DA,DR,DD,DO
+4 IF Y=-1
WRITE !!,"Goodbye",!
DO EOJ
QUIT
+5 SET %=$PIECE(^APCHSCTL(+Y,0),U,2)
IF %]""
IF $DATA(^XUSEC(%,DUZ))[0
WRITE !,"This summary type is currently locked to prevent alteration.",!
GOTO EP
+6 SET APCHDA=+Y
+7 SET DIE="^APCHSCTL("
SET DA=APCHDA
SET DR=".01;.05"
DO ^DIE
DO ^XBFMK
+8 DO EN
EOJ ;
+1 DO EN^XBVK("APCH")
+2 DO ^XBFMK
+3 QUIT
EN ; -- main entry point for APCH CREATE/MODIFY TYPE
+1 DO EN^VALM("APCH CREATE/MODIFY TYPE")
+2 DO CLEAR^VALM1
+3 DO FULL^VALM1
+4 IF $DATA(IOF)
WRITE @IOF
+5 DO EOJ
+6 QUIT
+7 ;
HDR ;EP -- header code
+1 SET VALMHDR(1)="Health Summary: "
IF $GET(APCHDA)
IF $DATA(^APCHSCTL(APCHDA))
SET VALMHDR(1)=VALMHDR(1)_$PIECE(^APCHSCTL(APCHDA,0),U)
+2 QUIT
+3 ;
INIT ;EP -- init variables and list array
+1 KILL ^TMP($JOB,"APCHTYPE")
+2 SET APCHC=0
+3 NEW X,Y,O,C,M,T,A
+4 SET X="STRUCTURE: "
DO S(X)
+5 SET X="Order"
SET $EXTRACT(X,7)="Component"
SET $EXTRACT(X,49)="Max occ"
SET $EXTRACT(X,57)="Time"
SET $EXTRACT(X,62)="Alternate Title"
DO S(X)
+6 SET Y=0
FOR
SET Y=$ORDER(^APCHSCTL(APCHDA,1,Y))
IF Y'=+Y
QUIT
Begin DoDot:1
+7 SET O=$PIECE(^APCHSCTL(APCHDA,1,Y,0),U)
SET C=$PIECE(^APCHSCTL(APCHDA,1,Y,0),U,2)
SET C=$PIECE($GET(^APCHSCMP(+C,0)),U,1)
+8 SET M=$PIECE(^APCHSCTL(APCHDA,1,Y,0),U,3)
SET T=$PIECE(^APCHSCTL(APCHDA,1,Y,0),U,4)
SET A=$PIECE(^APCHSCTL(APCHDA,1,Y,0),U,5)
+9 SET X=O
SET $EXTRACT(X,7)=C
SET $EXTRACT(X,49)=M
SET $EXTRACT(X,57)=T
SET $EXTRACT(X,62)=A
DO S(X)
End DoDot:1
+10 SET X="GENERAL:"
DO S(X,1)
+11 SET X="Clinic Displayed on outpatient components: "_$$VAL^XBDIQ1(9001015,APCHDA,1.5)
DO S(X)
+12 SET X="ICD Text Display: "_$$VAL^XBDIQ1(9001015,APCHDA,2)
DO S(X)
+13 SET X="Provider Narrative Displayed: "_$$VAL^XBDIQ1(9001015,APCHDA,3)
DO S(X)
+14 SET X="Display Provider Initials in Outpatient components: "_$$VAL^XBDIQ1(9001015,APCHDA,3.6)
DO S(X)
+15 SET X="Provider Initials displayed on Medication components: "_$$VAL^XBDIQ1(9001015,APCHDA,3.7)
DO S(X)
+16 SET X="Lab Comments displayed in LAB component: "_$$VAL^XBDIQ1(9001015,APCHDA,3.8)
+17 SET X="Comments displayed with Reasons Service not done: "_$$VAL^XBDIQ1(9001015,APCHDA,3.9)
+18 SET X="MEASUREMENT PANELS: "
DO S(X,1)
IF '$ORDER(^APCHSCTL(APCHDA,3,0))
DO S("<none>")
GOTO LP
+19 SET X="Order"
SET $EXTRACT(X,7)="Panel"
DO S(X)
+20 SET Y=0
FOR
SET Y=$ORDER(^APCHSCTL(APCHDA,3,Y))
IF Y'=+Y
QUIT
Begin DoDot:1
+21 SET O=$PIECE(^APCHSCTL(APCHDA,3,Y,0),U)
SET C=$PIECE(^APCHSCTL(APCHDA,3,Y,0),U,2)
SET C=$PIECE($GET(^APCHSMPN(+C,0)),U,1)
+22 SET X=O
SET $EXTRACT(X,7)=C
DO S(X)
End DoDot:1
LP ;
+1 SET X="LAB TEST PANELS: "
DO S(X,1)
IF '$ORDER(^APCHSCTL(APCHDA,4,0))
DO S("<none>")
GOTO HMR
+2 SET X="Order"
SET $EXTRACT(X,7)="Panel"
DO S(X)
+3 SET Y=0
FOR
SET Y=$ORDER(^APCHSCTL(APCHDA,4,Y))
IF Y'=+Y
QUIT
Begin DoDot:1
+4 SET O=$PIECE(^APCHSCTL(APCHDA,4,Y,0),U)
SET C=$PIECE(^APCHSCTL(APCHDA,4,Y,0),U,2)
SET C=$PIECE($GET(^LAB(60,+C,0)),U,1)
+5 SET X=O
SET $EXTRACT(X,7)=C
DO S(X)
End DoDot:1
HMR ;
+1 SET X="HEALTH MAINTENANCE REMINDERS: "
DO S(X,1)
IF '$ORDER(^APCHSCTL(APCHDA,5,0))
DO S("<none>")
GOTO TP
+2 SET X="Order"
SET $EXTRACT(X,7)="Health Maintenance Reminder"
DO S(X)
+3 SET Y=0
FOR
SET Y=$ORDER(^APCHSCTL(APCHDA,5,Y))
IF Y'=+Y
QUIT
Begin DoDot:1
+4 SET O=$PIECE(^APCHSCTL(APCHDA,5,Y,0),U)
SET C=$PIECE(^APCHSCTL(APCHDA,5,Y,0),U,2)
SET C=$PIECE($GET(^APCHSURV(+C,0)),U,1)
+5 SET X=O
SET $EXTRACT(X,7)=C
DO S(X)
End DoDot:1
TP ;
+1 SET X="BEST PRACTICE PROMPTS: "
DO S(X,1)
IF '$ORDER(^APCHSCTL(APCHDA,13,0))
DO S("<none>")
GOTO FS
+2 SET X="Order"
SET $EXTRACT(X,7)="Best Practice Prompt"
DO S(X)
+3 SET Y=0
FOR
SET Y=$ORDER(^APCHSCTL(APCHDA,13,Y))
IF Y'=+Y
QUIT
Begin DoDot:1
+4 SET O=$PIECE(^APCHSCTL(APCHDA,13,Y,0),U)
SET C=$PIECE(^APCHSCTL(APCHDA,13,Y,0),U,2)
SET C=$PIECE($GET(^APCHSURV(+C,0)),U,1)
+5 SET X=O
SET $EXTRACT(X,7)=C
DO S(X)
End DoDot:1
FS ;
+1 SET X="FLOWSHEET: "
DO S(X,1)
IF '$ORDER(^APCHSCTL(APCHDA,6,0))
DO S("<none>")
GOTO HF
+2 SET X="Order"
SET $EXTRACT(X,7)="Flowsheet"
DO S(X)
+3 SET Y=0
FOR
SET Y=$ORDER(^APCHSCTL(APCHDA,6,Y))
IF Y'=+Y
QUIT
Begin DoDot:1
+4 SET O=$PIECE(^APCHSCTL(APCHDA,6,Y,0),U)
SET C=$PIECE(^APCHSCTL(APCHDA,6,Y,0),U,2)
SET C=$PIECE($GET(^APCHSFLC(+C,0)),U,1)
+5 SET X=O
SET $EXTRACT(X,7)=C
DO S(X)
End DoDot:1
HF ;
+1 SET X="HEALTH FACTORS: "
DO S(X,1)
IF '$ORDER(^APCHSCTL(APCHDA,7,0))
DO S("<none>")
GOTO SP
+2 SET X="Order"
SET $EXTRACT(X,7)="Health Factor"
SET $EXTRACT(X,49)="Title"
SET $EXTRACT(X,70)="Most Recent"
DO S(X)
+3 SET Y=0
FOR
SET Y=$ORDER(^APCHSCTL(APCHDA,7,Y))
IF Y'=+Y
QUIT
Begin DoDot:1
+4 SET O=$PIECE(^APCHSCTL(APCHDA,7,Y,0),U)
SET C=$PIECE(^APCHSCTL(APCHDA,7,Y,0),U,2)
SET C=$PIECE($GET(^AUTTHF(+C,0)),U,1)
SET T=$PIECE(^APCHSCTL(APCHDA,7,Y,0),U,3)
SET M=$PIECE(^APCHSCTL(APCHDA,7,Y,0),U,4)
SET M=$$EXTSET^XBFUNC(9001015.08,3,M)
+5 SET X=O
SET $EXTRACT(X,7)=C
SET $EXTRACT(X,49)=$EXTRACT(T,1,20)
SET $EXTRACT(X,70)=M
DO S(X)
End DoDot:1
SP ;
+1 SET X="SUPPLEMENTS: "
DO S(X,1)
IF '$ORDER(^APCHSCTL(APCHDA,12,0))
DO S("<none>")
GOTO PCS
+2 SET X="Order"
SET $EXTRACT(X,7)="Supplement"
DO S(X)
+3 SET Y=0
FOR
SET Y=$ORDER(^APCHSCTL(APCHDA,12,Y))
IF Y'=+Y
QUIT
Begin DoDot:1
+4 SET O=$PIECE(^APCHSCTL(APCHDA,12,Y,0),U)
SET C=$PIECE(^APCHSCTL(APCHDA,12,Y,0),U,2)
SET C=$PIECE($GET(^APCHSUP(+C,0)),U,1)
+5 SET X=O
SET $EXTRACT(X,7)=C_" "_$PIECE(^APCHSCTL(APCHDA,12,Y,0),U,3)
DO S(X)
End DoDot:1
PCS ;
+1 SET X="Provider Class Screen for OUTPATIENT VISITS (SCREENED) component (IF USED): "
DO S(X,1)
+2 IF $ORDER(^APCHSCTL(APCHDA,9,0))
SET X="Provider Classes to be EXCLUDED"
DO S(X)
+3 SET Y=0
FOR
SET Y=$ORDER(^APCHSCTL(APCHDA,9,Y))
IF Y'=+Y
QUIT
Begin DoDot:1
+4 SET C=$PIECE(^APCHSCTL(APCHDA,9,Y,0),U)
SET C=$PIECE($GET(^DIC(7,+C,0)),U,1)
+5 SET X=C
DO S(X)
End DoDot:1
+6 SET X="CLINIC Screen for OUTPATIENT VISITS (SCREENED) component (IF USED): "
DO S(X,1)
+7 IF $ORDER(^APCHSCTL(APCHDA,11,0))
SET X="Clinics to be EXCLUDED"
DO S(X)
+8 SET Y=0
FOR
SET Y=$ORDER(^APCHSCTL(APCHDA,11,Y))
IF Y'=+Y
QUIT
Begin DoDot:1
+9 SET C=$PIECE(^APCHSCTL(APCHDA,11,Y,0),U)
SET C=$PIECE($GET(^DIC(40.7,+C,0)),U,1)
+10 SET X=C
DO S(X)
End DoDot:1
+11 SET VALMCNT=$ORDER(^TMP($JOB,"APCHTYPE",""),-1)
+12 QUIT
S(Y,F,C,T) ;EP - set up array
+1 IF '$GET(F)
SET F=0
+2 IF '$GET(T)
SET T=0
+3 ;blank lines
+4 FOR F=1:1:F
SET X=""
DO S1
+5 SET X=Y
+6 IF $GET(C)
SET L=$LENGTH(Y)
SET T=(80-L)/2
Begin DoDot:1
+7 FOR %=1:1:(T-1)
SET X=" "_X
End DoDot:1
DO S1
QUIT
+8 FOR %=1:1:T
SET X=" "_Y
+9 DO S1
+10 QUIT
S1 ;
+1 SET APCHC=APCHC+1
+2 SET ^TMP($JOB,"APCHTYPE",APCHC,0)=X
+3 QUIT
+4 ;
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- EXIT code
+1 QUIT
+2 ;
EXPND ; -- expand code
+1 QUIT
+2 ;
