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