PXRMSEL2 ; SLC/PJH - PXRM Selection ;04/16/2000
;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
;
; Called from PXRMSEL
;
;Select Health factors requiring resolutions
;-------------------------------------------
START W IORESET
;Select to edit individual or reminder's Health Factors
D OPT(.ANS) Q:$D(DTOUT)!$D(DUOUT) Q:ANS="I"
;Select Reminder
S DIC("A")="SELECT REMINDER: "
S LIT1="You must select a reminder!"
D REM(.ARRAY) Q:$D(DTOUT)!$D(DUOUT)
;Scan health factors
D SKIP
;Rebuild listman screen
D INIT^PXRMSEL
Q
;
;Ask ADD/MODIFY or not
;---------------------
ASK(YESNO,TEXT) ;
N X,Y,DIR
K DIROUT,DIRUT,DTOUT,DUOUT
S DIR(0)="YA0"
S DIR("A")=TEXT
S DIR("B")="N"
S DIR("?")="Enter Y or N. For detailed help type ??"
S DIR("??")=U_"D ZHELP^PXRMSEL(2)"
D ^DIR K DIR
I $D(DIROUT) S DTOUT=1
I $D(DTOUT)!($D(DUOUT)) Q
S YESNO=$E(Y(0))
Q
;
;Select single HF or all HF's for the reminder
;---------------------------------------------
OPT(TYPE) ;
N X,Y
K DIROUT,DIRUT,DTOUT,DUOUT
S DIR(0)="S"_U_"I:Individual Health Factor;"
S DIR(0)=DIR(0)_"A:All Health Factors for a Selected Reminder;"
S DIR("A")="SELECTION OPTION"
S DIR("B")="I"
S DIR("?")="Select from the codes displayed. For detailed help type ??"
S DIR("??")=U_"D ZHELP^PXRMSEL(1)"
D ^DIR K DIR
I $D(DIROUT) S DTOUT=1
I $D(DTOUT)!($D(DUOUT)) Q
S TYPE=Y
Q
;
;Reminder selection
;------------------
REM(ARRAY) ;
N X,Y,CNT,FSUB,FHF,FIND,FNAM,FOUND,REM
K DIROUT,DIRUT,DTOUT,DUOUT
S FOUND=0
W !
F D Q:$D(DTOUT) Q:$D(DUOUT) Q:FOUND
.S DIC=811.9,DIC(0)="AEMQZ"
.D ^DIC K DIC S:X=(U_U) DTOUT=1 Q:$D(DTOUT)!$D(DUOUT)!(+Y=-1)
.;Reminder ien
.S REM=$P(Y,U) Q:'REM
.;Get health factor findings on this reminder
.S FSUB=0
.F S FSUB=$O(^PXD(811.9,REM,20,FSUB)) Q:'FSUB D
..S FIND=$P($G(^PXD(811.9,REM,20,FSUB,0)),U)
..Q:$P(FIND,";",2)'="AUTTHF("
..S FHF=$P(FIND,";") Q:'FHF
..S FNAM=$P($G(^AUTTHF(FHF,0)),U) Q:FNAM=""
..;Save array used by PXRMGEDT
..S FOUND=FOUND+1
..S ARRAY(FNAM)=FHF,ARRAYN(FHF)=""
.I 'FOUND W !!,"No health factor findings on this reminder",! Q
.S FNAM=""
.W !!,"HEALTH FACTORS:",!
.F S FNAM=$O(ARRAY(FNAM)) Q:FNAM="" D
..S FHF=$P(ARRAY(FNAM),U)
..W !,FNAM W:$D(^PXRMD(801.95,FHF,0)) " (Resolution defined)"
.W !
Q
;
;Dialog type selection
;---------------------
SEL(TYPE) ;
W IORESET
N X,Y,DIR
K DIROUT,DIRUT,DTOUT,DUOUT
S DIR(0)="S"_U_"D:Reminder Dialogs;"
S DIR(0)=DIR(0)_"E:Dialog Elements;"
S DIR(0)=DIR(0)_"F:Forced Values;"
S DIR(0)=DIR(0)_"G:Dialog Groups;"
S DIR(0)=DIR(0)_"P:Additional Prompts;"
S DIR(0)=DIR(0)_"R:Reminders;"
S DIR(0)=DIR(0)_"RG:Result Group (Mental Health);"
S DIR(0)=DIR(0)_"RE:Result Element (Mental Health);"
S DIR("A")="TYPE OF VIEW"
S DIR("B")="R"
S DIR("?")="Select from the codes displayed. For detailed help type ??"
S DIR("??")=U_"D HELP^PXRMSEL2(3)"
D ^DIR K DIR
I $D(DIROUT) S DTOUT=1
I $D(DTOUT)!($D(DUOUT)) Q
S TYPE=Y
;Change display type
S PXRMGTYP=$S(TYPE="D":"DLG",TYPE="R":"DLGR",1:"DLGE")
I TYPE'="R" D
.I TYPE="D" S PXRMDTYP="R" Q
.I TYPE="RG" S PXRMDTYP="S" Q
.I TYPE="RE" S PXRMDTYP="T" Q
.S PXRMDTYP=TYPE
Q
;
;Reminders Health Factors
;------------------------
SKIP N ANS,FNAM,FHF,EXISTS,TEXT
S FNAM=""
F S FNAM=$O(ARRAY(FNAM)) Q:FNAM="" D Q:$D(DUOUT)!$D(DTOUT)
.S FHF=ARRAY(FNAM),EXISTS=$D(^PXRMD(801.95,FHF,0))
.I 'EXISTS S TEXT="ADD resolution status for "_FNAM_": "
.I EXISTS S TEXT="MODIFY resolution status for "_FNAM_": "
.;Option to ADD/MODIFY
.D ASK(.ANS,TEXT) Q:$D(DTOUT)!$D(DUOUT) Q:(ANS'="Y")
.;Force entry of HF into 801.95
.I 'EXISTS D
..N DA,DIC,DIK,DR
..;Store the unique name
..S DR=".01///"_FNAM,DIE="^PXRMD(801.95,",DA=FHF
..D ^DIE
..;Reindex the cross-references.
..S DIK="^PXRMD(801.95,",DA=FHF
..D IX^DIK
.;Edit
.D EDIT^PXRMGEDT(PXRMGTYP,FHF,1)
Q
;
;General help text routine.
;--------------------------
HELP(CALL) ;
N HTEXT
N DIWF,DIWL,DIWR,IC
S DIWF="C75",DIWL=0,DIWR=75
;
I CALL=1 D
.S HTEXT(1)="Enter I to select an individual health factor. Enter A to"
.S HTEXT(2)="process all health factor findings on a selected reminder."
I CALL=2 D
.S HTEXT(1)="Enter Yes to enter resolution status for this health"
.S HTEXT(2)="factor. Enter No to continue to the next health factor."
I CALL=3 D
.S HTEXT(1)="Select the type of view to be displayed. You may view"
.S HTEXT(2)="either reminders or selected dialog types."
K ^UTILITY($J,"W")
S IC=""
F S IC=$O(HTEXT(IC)) Q:IC="" D
. S X=HTEXT(IC)
. D ^DIWP
W !
S IC=0
F S IC=$O(^UTILITY($J,"W",0,IC)) Q:IC="" D
. W !,^UTILITY($J,"W",0,IC,0)
K ^UTILITY($J,"W")
W !
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMSEL2 4777 printed Nov 22, 2024@16:59:18 Page 2
PXRMSEL2 ; SLC/PJH - PXRM Selection ;04/16/2000
+1 ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+2 ;
+3 ; Called from PXRMSEL
+4 ;
+5 ;Select Health factors requiring resolutions
+6 ;-------------------------------------------
START WRITE IORESET
+1 ;Select to edit individual or reminder's Health Factors
+2 DO OPT(.ANS)
if $DATA(DTOUT)!$DATA(DUOUT)
QUIT
if ANS="I"
QUIT
+3 ;Select Reminder
+4 SET DIC("A")="SELECT REMINDER: "
+5 SET LIT1="You must select a reminder!"
+6 DO REM(.ARRAY)
if $DATA(DTOUT)!$DATA(DUOUT)
QUIT
+7 ;Scan health factors
+8 DO SKIP
+9 ;Rebuild listman screen
+10 DO INIT^PXRMSEL
+11 QUIT
+12 ;
+13 ;Ask ADD/MODIFY or not
+14 ;---------------------
ASK(YESNO,TEXT) ;
+1 NEW X,Y,DIR
+2 KILL DIROUT,DIRUT,DTOUT,DUOUT
+3 SET DIR(0)="YA0"
+4 SET DIR("A")=TEXT
+5 SET DIR("B")="N"
+6 SET DIR("?")="Enter Y or N. For detailed help type ??"
+7 SET DIR("??")=U_"D ZHELP^PXRMSEL(2)"
+8 DO ^DIR
KILL DIR
+9 IF $DATA(DIROUT)
SET DTOUT=1
+10 IF $DATA(DTOUT)!($DATA(DUOUT))
QUIT
+11 SET YESNO=$EXTRACT(Y(0))
+12 QUIT
+13 ;
+14 ;Select single HF or all HF's for the reminder
+15 ;---------------------------------------------
OPT(TYPE) ;
+1 NEW X,Y
+2 KILL DIROUT,DIRUT,DTOUT,DUOUT
+3 SET DIR(0)="S"_U_"I:Individual Health Factor;"
+4 SET DIR(0)=DIR(0)_"A:All Health Factors for a Selected Reminder;"
+5 SET DIR("A")="SELECTION OPTION"
+6 SET DIR("B")="I"
+7 SET DIR("?")="Select from the codes displayed. For detailed help type ??"
+8 SET DIR("??")=U_"D ZHELP^PXRMSEL(1)"
+9 DO ^DIR
KILL DIR
+10 IF $DATA(DIROUT)
SET DTOUT=1
+11 IF $DATA(DTOUT)!($DATA(DUOUT))
QUIT
+12 SET TYPE=Y
+13 QUIT
+14 ;
+15 ;Reminder selection
+16 ;------------------
REM(ARRAY) ;
+1 NEW X,Y,CNT,FSUB,FHF,FIND,FNAM,FOUND,REM
+2 KILL DIROUT,DIRUT,DTOUT,DUOUT
+3 SET FOUND=0
+4 WRITE !
+5 FOR
Begin DoDot:1
+6 SET DIC=811.9
SET DIC(0)="AEMQZ"
+7 DO ^DIC
KILL DIC
if X=(U_U)
SET DTOUT=1
if $DATA(DTOUT)!$DATA(DUOUT)!(+Y=-1)
QUIT
+8 ;Reminder ien
+9 SET REM=$PIECE(Y,U)
if 'REM
QUIT
+10 ;Get health factor findings on this reminder
+11 SET FSUB=0
+12 FOR
SET FSUB=$ORDER(^PXD(811.9,REM,20,FSUB))
if 'FSUB
QUIT
Begin DoDot:2
+13 SET FIND=$PIECE($GET(^PXD(811.9,REM,20,FSUB,0)),U)
+14 if $PIECE(FIND,";",2)'="AUTTHF("
QUIT
+15 SET FHF=$PIECE(FIND,";")
if 'FHF
QUIT
+16 SET FNAM=$PIECE($GET(^AUTTHF(FHF,0)),U)
if FNAM=""
QUIT
+17 ;Save array used by PXRMGEDT
+18 SET FOUND=FOUND+1
+19 SET ARRAY(FNAM)=FHF
SET ARRAYN(FHF)=""
End DoDot:2
+20 IF 'FOUND
WRITE !!,"No health factor findings on this reminder",!
QUIT
+21 SET FNAM=""
+22 WRITE !!,"HEALTH FACTORS:",!
+23 FOR
SET FNAM=$ORDER(ARRAY(FNAM))
if FNAM=""
QUIT
Begin DoDot:2
+24 SET FHF=$PIECE(ARRAY(FNAM),U)
+25 WRITE !,FNAM
if $DATA(^PXRMD(801.95,FHF,0))
WRITE " (Resolution defined)"
End DoDot:2
+26 WRITE !
End DoDot:1
if $DATA(DTOUT)
QUIT
if $DATA(DUOUT)
QUIT
if FOUND
QUIT
+27 QUIT
+28 ;
+29 ;Dialog type selection
+30 ;---------------------
SEL(TYPE) ;
+1 WRITE IORESET
+2 NEW X,Y,DIR
+3 KILL DIROUT,DIRUT,DTOUT,DUOUT
+4 SET DIR(0)="S"_U_"D:Reminder Dialogs;"
+5 SET DIR(0)=DIR(0)_"E:Dialog Elements;"
+6 SET DIR(0)=DIR(0)_"F:Forced Values;"
+7 SET DIR(0)=DIR(0)_"G:Dialog Groups;"
+8 SET DIR(0)=DIR(0)_"P:Additional Prompts;"
+9 SET DIR(0)=DIR(0)_"R:Reminders;"
+10 SET DIR(0)=DIR(0)_"RG:Result Group (Mental Health);"
+11 SET DIR(0)=DIR(0)_"RE:Result Element (Mental Health);"
+12 SET DIR("A")="TYPE OF VIEW"
+13 SET DIR("B")="R"
+14 SET DIR("?")="Select from the codes displayed. For detailed help type ??"
+15 SET DIR("??")=U_"D HELP^PXRMSEL2(3)"
+16 DO ^DIR
KILL DIR
+17 IF $DATA(DIROUT)
SET DTOUT=1
+18 IF $DATA(DTOUT)!($DATA(DUOUT))
QUIT
+19 SET TYPE=Y
+20 ;Change display type
+21 SET PXRMGTYP=$SELECT(TYPE="D":"DLG",TYPE="R":"DLGR",1:"DLGE")
+22 IF TYPE'="R"
Begin DoDot:1
+23 IF TYPE="D"
SET PXRMDTYP="R"
QUIT
+24 IF TYPE="RG"
SET PXRMDTYP="S"
QUIT
+25 IF TYPE="RE"
SET PXRMDTYP="T"
QUIT
+26 SET PXRMDTYP=TYPE
End DoDot:1
+27 QUIT
+28 ;
+29 ;Reminders Health Factors
+30 ;------------------------
SKIP NEW ANS,FNAM,FHF,EXISTS,TEXT
+1 SET FNAM=""
+2 FOR
SET FNAM=$ORDER(ARRAY(FNAM))
if FNAM=""
QUIT
Begin DoDot:1
+3 SET FHF=ARRAY(FNAM)
SET EXISTS=$DATA(^PXRMD(801.95,FHF,0))
+4 IF 'EXISTS
SET TEXT="ADD resolution status for "_FNAM_": "
+5 IF EXISTS
SET TEXT="MODIFY resolution status for "_FNAM_": "
+6 ;Option to ADD/MODIFY
+7 DO ASK(.ANS,TEXT)
if $DATA(DTOUT)!$DATA(DUOUT)
QUIT
if (ANS'="Y")
QUIT
+8 ;Force entry of HF into 801.95
+9 IF 'EXISTS
Begin DoDot:2
+10 NEW DA,DIC,DIK,DR
+11 ;Store the unique name
+12 SET DR=".01///"_FNAM
SET DIE="^PXRMD(801.95,"
SET DA=FHF
+13 DO ^DIE
+14 ;Reindex the cross-references.
+15 SET DIK="^PXRMD(801.95,"
SET DA=FHF
+16 DO IX^DIK
End DoDot:2
+17 ;Edit
+18 DO EDIT^PXRMGEDT(PXRMGTYP,FHF,1)
End DoDot:1
if $DATA(DUOUT)!$DATA(DTOUT)
QUIT
+19 QUIT
+20 ;
+21 ;General help text routine.
+22 ;--------------------------
HELP(CALL) ;
+1 NEW HTEXT
+2 NEW DIWF,DIWL,DIWR,IC
+3 SET DIWF="C75"
SET DIWL=0
SET DIWR=75
+4 ;
+5 IF CALL=1
Begin DoDot:1
+6 SET HTEXT(1)="Enter I to select an individual health factor. Enter A to"
+7 SET HTEXT(2)="process all health factor findings on a selected reminder."
End DoDot:1
+8 IF CALL=2
Begin DoDot:1
+9 SET HTEXT(1)="Enter Yes to enter resolution status for this health"
+10 SET HTEXT(2)="factor. Enter No to continue to the next health factor."
End DoDot:1
+11 IF CALL=3
Begin DoDot:1
+12 SET HTEXT(1)="Select the type of view to be displayed. You may view"
+13 SET HTEXT(2)="either reminders or selected dialog types."
End DoDot:1
+14 KILL ^UTILITY($JOB,"W")
+15 SET IC=""
+16 FOR
SET IC=$ORDER(HTEXT(IC))
if IC=""
QUIT
Begin DoDot:1
+17 SET X=HTEXT(IC)
+18 DO ^DIWP
End DoDot:1
+19 WRITE !
+20 SET IC=0
+21 FOR
SET IC=$ORDER(^UTILITY($JOB,"W",0,IC))
if IC=""
QUIT
Begin DoDot:1
+22 WRITE !,^UTILITY($JOB,"W",0,IC,0)
End DoDot:1
+23 KILL ^UTILITY($JOB,"W")
+24 WRITE !
+25 QUIT
