PXRMSEL ; SLC/PJH - PXRM Selection ;09/07/2012
;;2.0;CLINICAL REMINDERS;**26**;Feb 04, 2005;Build 404
;
;Selection screen for all dialog files
;
START(HEADER,PXRMGTYP,PXRMNAM) ;
N PXRMREAD,PXRMSHD,PXRMSRC,PXRMVARM
N VALM,VALMAR,VALMBCK,VALMBG,VALMCNT,VALMHDR,VALMSG,X,XMZ
S X="IORESET"
D ENDR^%ZISS,EN^VALM("PXRM SELECTION")
W IORESET
D KILL^%ZISS
Q
;
;Labels called from list 'PXRM SELECTION'
;
;Add new entry
ADD ;
N ANS,ARRAY,ARRAYN,DIROUT,DIRUT,DTOUT,DUOUT
;Health factor resolutions
I PXRMGTYP="SHFR" D Q:$D(DTOUT)!$D(DUOUT) Q:ANS="A"
.D ^PXRMSEL2 S:$D(DUOUT) VALMBCK="R"
;Add entry
D ADD^PXRMGEDT(PXRMGTYP),INIT
Q
;
;Copy any dialog
COPY D ANY^PXRMDCPY
D:PXRMGTYP="DLGE" INIT
Q
;
;Copy selected reminder dialog
COPYS N DIC,DUOUT,DTOUT,DIROUT,DIRUT,X,Y
D SEL^PXRMDCPY(PXRMDIEN,"")
Q
;
;Change dialog view
CHNG K PXRMBG D SEL^PXRMSEL2(.PXRMDTYP),INIT
Q
;
;Change reminder view
CHNGR(VIEW) ;
S $E(PXRMVIEW)=VIEW K PXRMBG
D INIT
Q
;
;Toggle view name/print name
CHNGV N VIEW
S VIEW=$E(PXRMVIEW,2)
I VIEW="P" S $E(PXRMVIEW,2)="N"
I VIEW="N" S $E(PXRMVIEW,2)="P"
D INIT
Q
;
;Change between dialog view and reminder view
DIDL(VIEW) ;
K PXRMBG S PXRMGTYP=VIEW
D INIT
Q
;
EXIT ;Exit code
D CLEAN^VALM10,FULL^VALM1
S VALMBCK="Q"
K ^TMP("PXRMSEL",$J)
Q
;
HDR ; Header code
S VALMSG="+ Next Screen - Prev Screen ?? More Actions"
;Non-Dialog options
I PXRMGTYP'["DLG" S VALMHDR(1)=HEADER Q
;Dialog Options
S VALM("TITLE")=PXRMHD,VALMHDR(1)=PXRMSHD
Q
;
HELP ;Help code
N ORU,ORUPRMT,XQORM,PXRMTAG S PXRMTAG=PXRMGTYP
D EN^VALM("PXRM DIALOG MAIN HELP")
S VALMBCK="R"
Q
;
INIT ;Init
D CLEAN^VALM10
S VALMCNT=0
D BUILD
D XQORM
;
;Set header and title for dialog options
I PXRMGTYP["DLG" D
.S PXRMHD="Dialog List",PXRMSHD="DIALOG VIEW ("
.I PXRMGTYP="DLGE" D
..I PXRMDTYP="E" S PXRMSHD=PXRMSHD_"DIALOG ELEMENTS)"
..I PXRMDTYP="F" S PXRMSHD=PXRMSHD_"FORCED VALUES)"
..I PXRMDTYP="G" S PXRMSHD=PXRMSHD_"DIALOG GROUPS)"
..I PXRMDTYP="P" S PXRMSHD=PXRMSHD_"ADDITIONAL PROMPTS)"
..I PXRMDTYP="S" S PXRMSHD=PXRMSHD_"RESULT GROUPS)"
..I PXRMDTYP="T" S PXRMSHD=PXRMSHD_"RESULT ELEMENT)"
.I PXRMGTYP="DLG" D
..S PXRMSHD=PXRMSHD_"REMINDER DIALOGS - "
..I $E(PXRMVIEW,2)="N" S PXRMSHD=PXRMSHD_"SOURCE REMINDER NAME)"
..I $E(PXRMVIEW,2)="P" S PXRMSHD=PXRMSHD_"SOURCE REMINDER PRINT NAME)"
.I PXRMGTYP="DLGR" D
..S PXRMSHD="REMINDER VIEW ("
..I PXRMVIEW="AN" S PXRMSHD=PXRMSHD_"ALL REMINDERS BY NAME)"
..I PXRMVIEW="AP" S PXRMSHD=PXRMSHD_"ALL REMINDERS BY PRINT NAME)"
..I PXRMVIEW="LN" S PXRMSHD=PXRMSHD_"LINKED REMINDERS BY NAME)"
..I PXRMVIEW="LP" S PXRMSHD=PXRMSHD_"LINKED REMINDERS BY PRINT NAME)"
.;Restore original place
.S:$G(PXRMBG) VALMBG=PXRMBG
.S VALMHDR(1)=PXRMSHD,VALM("TITLE")=PXRMHD
;
S VALMBCK="R"
Q
;
;
BUILD ;Build selection list
;
D ^PXRMSEL1
Q
;
LIST ;List All option
W IORESET
I PXRMGTYP["DLG" D ALL^PXRMDLST
;I PXRMGTYP="DTAX" D ALL^PXRMTDLG
I PXRMGTYP="FIP" D ALL^PXRMFIP
I PXRMGTYP="FPAR" D ALL^PXRMFLST
I PXRMGTYP="RCAT" D ALL^PXRMCLST
I PXRMGTYP="RESN" D ALL^PXRMSLST
I PXRMGTYP="SHFR" D ALL^PXRMSHF
;
N DIR S DIR(0)="E" D ^DIR
;
D XQORM
S VALMBCK="R"
Q
;
PEXIT ;PXRM SELECTION MENU protocol exit code
S VALMSG="+ Next Screen - Prev Screen ?? More Actions"
;Reset after page up/down etc
D XQORM
Q
;
SEL ;PXRM SELECT ITEM validation
N ERR,IEN,SEL
S VALMBCK="",SEL=+$P(XQORNOD(0),"=",2)
;Invalid selection
I ('SEL)!(SEL>VALMCNT)!('$D(@VALMAR@("IDX",SEL))) D Q
.W $C(7),!,SEL_" is not a valid item number." H 2
.S VALMBCK="R"
;Valid selection
S IEN=$O(@VALMAR@("IDX",SEL,"")) Q:'IEN
S VALMBCK="Q",@PXRMNAM=IEN
;Save place - reminder link only
I PXRMGTYP["DLG" S PXRMBG=VALMBG
Q
;
XQORM S XQORM("#")=$O(^ORD(101,"B","PXRM SELECTION ITEM",0))_U_"1:"_VALMCNT
S XQORM("A")="Select Item: "
;For finding type parameters dissallow add option
I ((PXRMGTYP="FPAR")&(+$G(PXRMINST)=0))!(PXRMGTYP="DTAX") D
.N FMENU
.S FMENU=$O(^ORD(101,"B","PXRM FINDING SELECTION MENU",0))_";ORD(101,"
.I FMENU S XQORM("HIJACK")=FMENU
;For dialog edit allow extra options
I PXRMGTYP="DLGE" D
.N FMENU
.S FMENU=$O(^ORD(101,"B","PXRM DIALOG SELECTION MENU (DLGE)",0))_";ORD(101,"
.I FMENU S XQORM("HIJACK")=FMENU
;For reminder dialog edit allow change view
I PXRMGTYP="DLG" D
.N FMENU
.S FMENU=$O(^ORD(101,"B","PXRM DIALOG SELECTION MENU (DLG)",0))_";ORD(101,"
.I FMENU S XQORM("HIJACK")=FMENU
;Reminder to dialog link
I PXRMGTYP="DLGR" D
.N FMENU
.S FMENU=$O(^ORD(101,"B","PXRM DIALOG/REMINDER MENU",0))_";ORD(101,"
.I FMENU S XQORM("HIJACK")=FMENU
Q
;
;Select single HF or all HF's for the reminder
;---------------------------------------------
ZOPT(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
;------------------
ZREM(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
;
;Reminders Health Factors
;------------------------
ZSKIP 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 ZASK(.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
;
;Ask ADD/MODIFY or not
;---------------------
ZASK(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
;
;General help text routine.
;--------------------------
ZHELP(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."
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[HPXRMSEL 7963 printed Dec 13, 2024@01:49:05 Page 2
PXRMSEL ; SLC/PJH - PXRM Selection ;09/07/2012
+1 ;;2.0;CLINICAL REMINDERS;**26**;Feb 04, 2005;Build 404
+2 ;
+3 ;Selection screen for all dialog files
+4 ;
START(HEADER,PXRMGTYP,PXRMNAM) ;
+1 NEW PXRMREAD,PXRMSHD,PXRMSRC,PXRMVARM
+2 NEW VALM,VALMAR,VALMBCK,VALMBG,VALMCNT,VALMHDR,VALMSG,X,XMZ
+3 SET X="IORESET"
+4 DO ENDR^%ZISS
DO EN^VALM("PXRM SELECTION")
+5 WRITE IORESET
+6 DO KILL^%ZISS
+7 QUIT
+8 ;
+9 ;Labels called from list 'PXRM SELECTION'
+10 ;
+11 ;Add new entry
ADD ;
+1 NEW ANS,ARRAY,ARRAYN,DIROUT,DIRUT,DTOUT,DUOUT
+2 ;Health factor resolutions
+3 IF PXRMGTYP="SHFR"
Begin DoDot:1
+4 DO ^PXRMSEL2
if $DATA(DUOUT)
SET VALMBCK="R"
End DoDot:1
if $DATA(DTOUT)!$DATA(DUOUT)
QUIT
if ANS="A"
QUIT
+5 ;Add entry
+6 DO ADD^PXRMGEDT(PXRMGTYP)
DO INIT
+7 QUIT
+8 ;
+9 ;Copy any dialog
COPY DO ANY^PXRMDCPY
+1 if PXRMGTYP="DLGE"
DO INIT
+2 QUIT
+3 ;
+4 ;Copy selected reminder dialog
COPYS NEW DIC,DUOUT,DTOUT,DIROUT,DIRUT,X,Y
+1 DO SEL^PXRMDCPY(PXRMDIEN,"")
+2 QUIT
+3 ;
+4 ;Change dialog view
CHNG KILL PXRMBG
DO SEL^PXRMSEL2(.PXRMDTYP)
DO INIT
+1 QUIT
+2 ;
+3 ;Change reminder view
CHNGR(VIEW) ;
+1 SET $EXTRACT(PXRMVIEW)=VIEW
KILL PXRMBG
+2 DO INIT
+3 QUIT
+4 ;
+5 ;Toggle view name/print name
CHNGV NEW VIEW
+1 SET VIEW=$EXTRACT(PXRMVIEW,2)
+2 IF VIEW="P"
SET $EXTRACT(PXRMVIEW,2)="N"
+3 IF VIEW="N"
SET $EXTRACT(PXRMVIEW,2)="P"
+4 DO INIT
+5 QUIT
+6 ;
+7 ;Change between dialog view and reminder view
DIDL(VIEW) ;
+1 KILL PXRMBG
SET PXRMGTYP=VIEW
+2 DO INIT
+3 QUIT
+4 ;
EXIT ;Exit code
+1 DO CLEAN^VALM10
DO FULL^VALM1
+2 SET VALMBCK="Q"
+3 KILL ^TMP("PXRMSEL",$JOB)
+4 QUIT
+5 ;
HDR ; Header code
+1 SET VALMSG="+ Next Screen - Prev Screen ?? More Actions"
+2 ;Non-Dialog options
+3 IF PXRMGTYP'["DLG"
SET VALMHDR(1)=HEADER
QUIT
+4 ;Dialog Options
+5 SET VALM("TITLE")=PXRMHD
SET VALMHDR(1)=PXRMSHD
+6 QUIT
+7 ;
HELP ;Help code
+1 NEW ORU,ORUPRMT,XQORM,PXRMTAG
SET PXRMTAG=PXRMGTYP
+2 DO EN^VALM("PXRM DIALOG MAIN HELP")
+3 SET VALMBCK="R"
+4 QUIT
+5 ;
INIT ;Init
+1 DO CLEAN^VALM10
+2 SET VALMCNT=0
+3 DO BUILD
+4 DO XQORM
+5 ;
+6 ;Set header and title for dialog options
+7 IF PXRMGTYP["DLG"
Begin DoDot:1
+8 SET PXRMHD="Dialog List"
SET PXRMSHD="DIALOG VIEW ("
+9 IF PXRMGTYP="DLGE"
Begin DoDot:2
+10 IF PXRMDTYP="E"
SET PXRMSHD=PXRMSHD_"DIALOG ELEMENTS)"
+11 IF PXRMDTYP="F"
SET PXRMSHD=PXRMSHD_"FORCED VALUES)"
+12 IF PXRMDTYP="G"
SET PXRMSHD=PXRMSHD_"DIALOG GROUPS)"
+13 IF PXRMDTYP="P"
SET PXRMSHD=PXRMSHD_"ADDITIONAL PROMPTS)"
+14 IF PXRMDTYP="S"
SET PXRMSHD=PXRMSHD_"RESULT GROUPS)"
+15 IF PXRMDTYP="T"
SET PXRMSHD=PXRMSHD_"RESULT ELEMENT)"
End DoDot:2
+16 IF PXRMGTYP="DLG"
Begin DoDot:2
+17 SET PXRMSHD=PXRMSHD_"REMINDER DIALOGS - "
+18 IF $EXTRACT(PXRMVIEW,2)="N"
SET PXRMSHD=PXRMSHD_"SOURCE REMINDER NAME)"
+19 IF $EXTRACT(PXRMVIEW,2)="P"
SET PXRMSHD=PXRMSHD_"SOURCE REMINDER PRINT NAME)"
End DoDot:2
+20 IF PXRMGTYP="DLGR"
Begin DoDot:2
+21 SET PXRMSHD="REMINDER VIEW ("
+22 IF PXRMVIEW="AN"
SET PXRMSHD=PXRMSHD_"ALL REMINDERS BY NAME)"
+23 IF PXRMVIEW="AP"
SET PXRMSHD=PXRMSHD_"ALL REMINDERS BY PRINT NAME)"
+24 IF PXRMVIEW="LN"
SET PXRMSHD=PXRMSHD_"LINKED REMINDERS BY NAME)"
+25 IF PXRMVIEW="LP"
SET PXRMSHD=PXRMSHD_"LINKED REMINDERS BY PRINT NAME)"
End DoDot:2
+26 ;Restore original place
+27 if $GET(PXRMBG)
SET VALMBG=PXRMBG
+28 SET VALMHDR(1)=PXRMSHD
SET VALM("TITLE")=PXRMHD
End DoDot:1
+29 ;
+30 SET VALMBCK="R"
+31 QUIT
+32 ;
+33 ;
BUILD ;Build selection list
+1 ;
+2 DO ^PXRMSEL1
+3 QUIT
+4 ;
LIST ;List All option
+1 WRITE IORESET
+2 IF PXRMGTYP["DLG"
DO ALL^PXRMDLST
+3 ;I PXRMGTYP="DTAX" D ALL^PXRMTDLG
+4 IF PXRMGTYP="FIP"
DO ALL^PXRMFIP
+5 IF PXRMGTYP="FPAR"
DO ALL^PXRMFLST
+6 IF PXRMGTYP="RCAT"
DO ALL^PXRMCLST
+7 IF PXRMGTYP="RESN"
DO ALL^PXRMSLST
+8 IF PXRMGTYP="SHFR"
DO ALL^PXRMSHF
+9 ;
+10 NEW DIR
SET DIR(0)="E"
DO ^DIR
+11 ;
+12 DO XQORM
+13 SET VALMBCK="R"
+14 QUIT
+15 ;
PEXIT ;PXRM SELECTION MENU protocol exit code
+1 SET VALMSG="+ Next Screen - Prev Screen ?? More Actions"
+2 ;Reset after page up/down etc
+3 DO XQORM
+4 QUIT
+5 ;
SEL ;PXRM SELECT ITEM validation
+1 NEW ERR,IEN,SEL
+2 SET VALMBCK=""
SET SEL=+$PIECE(XQORNOD(0),"=",2)
+3 ;Invalid selection
+4 IF ('SEL)!(SEL>VALMCNT)!('$DATA(@VALMAR@("IDX",SEL)))
Begin DoDot:1
+5 WRITE $CHAR(7),!,SEL_" is not a valid item number."
HANG 2
+6 SET VALMBCK="R"
End DoDot:1
QUIT
+7 ;Valid selection
+8 SET IEN=$ORDER(@VALMAR@("IDX",SEL,""))
if 'IEN
QUIT
+9 SET VALMBCK="Q"
SET @PXRMNAM=IEN
+10 ;Save place - reminder link only
+11 IF PXRMGTYP["DLG"
SET PXRMBG=VALMBG
+12 QUIT
+13 ;
XQORM SET XQORM("#")=$ORDER(^ORD(101,"B","PXRM SELECTION ITEM",0))_U_"1:"_VALMCNT
+1 SET XQORM("A")="Select Item: "
+2 ;For finding type parameters dissallow add option
+3 IF ((PXRMGTYP="FPAR")&(+$GET(PXRMINST)=0))!(PXRMGTYP="DTAX")
Begin DoDot:1
+4 NEW FMENU
+5 SET FMENU=$ORDER(^ORD(101,"B","PXRM FINDING SELECTION MENU",0))_";ORD(101,"
+6 IF FMENU
SET XQORM("HIJACK")=FMENU
End DoDot:1
+7 ;For dialog edit allow extra options
+8 IF PXRMGTYP="DLGE"
Begin DoDot:1
+9 NEW FMENU
+10 SET FMENU=$ORDER(^ORD(101,"B","PXRM DIALOG SELECTION MENU (DLGE)",0))_";ORD(101,"
+11 IF FMENU
SET XQORM("HIJACK")=FMENU
End DoDot:1
+12 ;For reminder dialog edit allow change view
+13 IF PXRMGTYP="DLG"
Begin DoDot:1
+14 NEW FMENU
+15 SET FMENU=$ORDER(^ORD(101,"B","PXRM DIALOG SELECTION MENU (DLG)",0))_";ORD(101,"
+16 IF FMENU
SET XQORM("HIJACK")=FMENU
End DoDot:1
+17 ;Reminder to dialog link
+18 IF PXRMGTYP="DLGR"
Begin DoDot:1
+19 NEW FMENU
+20 SET FMENU=$ORDER(^ORD(101,"B","PXRM DIALOG/REMINDER MENU",0))_";ORD(101,"
+21 IF FMENU
SET XQORM("HIJACK")=FMENU
End DoDot:1
+22 QUIT
+23 ;
+24 ;Select single HF or all HF's for the reminder
+25 ;---------------------------------------------
ZOPT(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 ;------------------
ZREM(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 ;Reminders Health Factors
+30 ;------------------------
ZSKIP 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 ZASK(.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 ;Ask ADD/MODIFY or not
+22 ;---------------------
ZASK(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 ;General help text routine.
+15 ;--------------------------
ZHELP(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 KILL ^UTILITY($JOB,"W")
+12 SET IC=""
+13 FOR
SET IC=$ORDER(HTEXT(IC))
if IC=""
QUIT
Begin DoDot:1
+14 SET X=HTEXT(IC)
+15 DO ^DIWP
End DoDot:1
+16 WRITE !
+17 SET IC=0
+18 FOR
SET IC=$ORDER(^UTILITY($JOB,"W",0,IC))
if IC=""
QUIT
Begin DoDot:1
+19 WRITE !,^UTILITY($JOB,"W",0,IC,0)
End DoDot:1
+20 KILL ^UTILITY($JOB,"W")
+21 WRITE !
+22 QUIT
