- 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 Jan 18, 2025@02:50:18 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