PXRMRESN ; SLC/PJH - Edit/Inquire resolution statuses ;03/17/2000
;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
;
START N DIC,PXRMGTYP,PXRMHD,PXRMRESN,Y
;Select reminder category for display
SELECT ;General selection
S PXRMHD="Reminder Resolution Status",PXRMGTYP="RESN",PXRMRESN=""
D START^PXRMSEL(PXRMHD,PXRMGTYP,"PXRMRESN")
;Should return a value
I PXRMRESN D G SELECT
.S PXRMHD="REMINDER RESOLUTION STATUS NAME:"
.;Listman option
.D START^PXRMGEN(PXRMHD,PXRMGTYP,PXRMRESN)
;
END Q
;
;REMINDER RESOLUTION STATUSES #801.9
;-----------------------------------
;Temporary list of STATUSES
DISP N CNT,CODE,DES,SUB,TXT
W #,"REMINDER RESOLUTION STATUS SELECTION",!
S CODE="",CNT=0
F S CODE=$O(^PXRMD(801.9,"B",CODE)) Q:CODE="" D
.S CNT=CNT+1
.W !,CODE
W !
Q
;
;Build display for selected status - Called from PXRMGEN
;---------------------------------------------------------
RESN(PXRMRESN) ;
N DATA,DARRAY,SUB
S VALMCNT=0 K ^TMP("PXRMGENS",$J),^TMP("PXRMGEN",$J)
;
;Format headings to include resolution name
S HEADER=PXRMHD_" "_$P(^PXRMD(801.9,PXRMRESN,0),U)
;
;Build Reminder Resolution Status Display
D BUILD(.DARRAY,PXRMRESN) M ^TMP("PXRMGENS",$J)=DARRAY
;
;Put the list into the array List Manager is using.
S SUB=""
S VALMCNT=0
F S SUB=$O(^TMP("PXRMGENS",$J,SUB)) Q:SUB="" D
.S DATA=$G(^TMP("PXRMGENS",$J,SUB))
.S VALMCNT=VALMCNT+1
.S ^TMP("PXRMGEN",$J,VALMCNT,0)=DATA
S ^TMP("PXRMGEN",$J,"VALMCNT")=VALMCNT
K ^TMP("PXRMGENS",$J)
;Create headings
D CHGCAP^VALM("HEADER1","")
D CHGCAP^VALM("HEADER2","")
D CHGCAP^VALM("HEADER3","")
Q
;
;Build Resolution Status Inquiry array
;-------------------------------------
BUILD(ARRAY,D0) ;
N DIWF,DIWL,DIWR,IC,SUB,TAB,TXT,X
N ABBR,COL,CREA,DATA,DESC,FOUND,INACT,REST
S DIWF="C70",DIWL=0,DIWR=70,IC=0
K ^UTILITY($J,"W")
;Get Resolution status details
S DATA=$G(^PXRMD(801.9,D0,0))
S DESC=$P(DATA,U),ABBR=$P(DATA,U,2),COL=$P(DATA,U,3),INACT=$P(DATA,U,4)
S CREA=$P(DATA,U,5),REST=$P(DATA,U,6)
;
;Resolution Status
S TXT="Resolution Status: "_DESC
;Restricted edit is same as National
S:REST TXT="National "_TXT D SET(0,TXT,1)
;
S TXT="Resolution Status Description" D SET(0,TXT,0)
;Get Resolution Status description
S SUB=0,TAB=0,FOUND=0
F S SUB=$O(^PXRMD(801.9,D0,1,SUB)) Q:SUB="" D
.S X=$G(^PXRMD(801.9,D0,1,SUB,0))
.D ^DIWP
F S SUB=$O(^UTILITY($J,"W",0,SUB)) Q:SUB="" D
.D SET(5,^UTILITY($J,"W",0,SUB,0),0) S FOUND=1
K ^UTILITY($J,"W")
;Display no description message
I 'FOUND S TXT="*NONE*" D SET(5,TXT,0)
D SET(0,"",1)
;
;Related National Status from cross reference
I 'REST D
.;Get national code from cross reference
.N IEN S IEN=$O(^PXRMD(801.9,"AC",D0,""))
.;If none allocated say so
.I 'IEN S TXT="***UNDEFINED***"
.;Get name of national status and display
.I IEN S TXT=$P($G(^PXRMD(801.9,IEN,0)),U)
.S TXT="Related National Status: "_TXT D SET(3,TXT,0)
;
;Abbreviated Name
S TXT="Abbreviated name: "_ABBR D SET(10,TXT,0)
;Report Column Headings
S TXT="Report Column Headings: "_ABBR D SET(4,TXT,0)
;Inactive flag
S TXT="Inactive Flag: "_$S(INACT:"INACTIVE",1:"") D SET(13,TXT,0)
;Creator for local codes
I CREA,'REST D
.S TXT="Creator: "_$$GET1^DIQ(200,CREA,.01) D SET(19,TXT,0)
;Local Resolution Statuses
I REST D
.N LARRAY,LIEN S SUB=0,FOUND=0
.F S SUB=$O(^PXRMD(801.9,D0,10,SUB)) Q:'SUB D
..S LIEN=$P($G(^PXRMD(801.9,D0,10,SUB,0)),U)
..I LIEN S LARRAY(LIEN)="",FOUND=1
.S TXT="Local Resolution Statuses:" D SET(0,"",1),SET(0,TXT,0)
.I 'FOUND S TXT="*NONE*" D SET(5,TXT,0) Q
.S LIEN="" F S LIEN=$O(LARRAY(LIEN)) Q:'LIEN D
..S TXT=$P($G(^PXRMD(801.9,LIEN,0)),U) D SET(4,TXT,0)
Q
;
;Save local array
;----------------
SET(TAB,TXT,LF) ;
;Save main line
S IC=IC+1,ARRAY(IC)=$J("",TAB)_TXT
;Additional line feeds
I LF D
.N CNT F CNT=1:1:LF S IC=IC+1,ARRAY(IC)=$J("",79)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMRESN 3976 printed Apr 09, 2024@20:54:55 Page 2
PXRMRESN ; SLC/PJH - Edit/Inquire resolution statuses ;03/17/2000
+1 ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+2 ;
START NEW DIC,PXRMGTYP,PXRMHD,PXRMRESN,Y
+1 ;Select reminder category for display
SELECT ;General selection
+1 SET PXRMHD="Reminder Resolution Status"
SET PXRMGTYP="RESN"
SET PXRMRESN=""
+2 DO START^PXRMSEL(PXRMHD,PXRMGTYP,"PXRMRESN")
+3 ;Should return a value
+4 IF PXRMRESN
Begin DoDot:1
+5 SET PXRMHD="REMINDER RESOLUTION STATUS NAME:"
+6 ;Listman option
+7 DO START^PXRMGEN(PXRMHD,PXRMGTYP,PXRMRESN)
End DoDot:1
GOTO SELECT
+8 ;
END QUIT
+1 ;
+2 ;REMINDER RESOLUTION STATUSES #801.9
+3 ;-----------------------------------
+4 ;Temporary list of STATUSES
DISP NEW CNT,CODE,DES,SUB,TXT
+1 WRITE #,"REMINDER RESOLUTION STATUS SELECTION",!
+2 SET CODE=""
SET CNT=0
+3 FOR
SET CODE=$ORDER(^PXRMD(801.9,"B",CODE))
if CODE=""
QUIT
Begin DoDot:1
+4 SET CNT=CNT+1
+5 WRITE !,CODE
End DoDot:1
+6 WRITE !
+7 QUIT
+8 ;
+9 ;Build display for selected status - Called from PXRMGEN
+10 ;---------------------------------------------------------
RESN(PXRMRESN) ;
+1 NEW DATA,DARRAY,SUB
+2 SET VALMCNT=0
KILL ^TMP("PXRMGENS",$JOB),^TMP("PXRMGEN",$JOB)
+3 ;
+4 ;Format headings to include resolution name
+5 SET HEADER=PXRMHD_" "_$PIECE(^PXRMD(801.9,PXRMRESN,0),U)
+6 ;
+7 ;Build Reminder Resolution Status Display
+8 DO BUILD(.DARRAY,PXRMRESN)
MERGE ^TMP("PXRMGENS",$JOB)=DARRAY
+9 ;
+10 ;Put the list into the array List Manager is using.
+11 SET SUB=""
+12 SET VALMCNT=0
+13 FOR
SET SUB=$ORDER(^TMP("PXRMGENS",$JOB,SUB))
if SUB=""
QUIT
Begin DoDot:1
+14 SET DATA=$GET(^TMP("PXRMGENS",$JOB,SUB))
+15 SET VALMCNT=VALMCNT+1
+16 SET ^TMP("PXRMGEN",$JOB,VALMCNT,0)=DATA
End DoDot:1
+17 SET ^TMP("PXRMGEN",$JOB,"VALMCNT")=VALMCNT
+18 KILL ^TMP("PXRMGENS",$JOB)
+19 ;Create headings
+20 DO CHGCAP^VALM("HEADER1","")
+21 DO CHGCAP^VALM("HEADER2","")
+22 DO CHGCAP^VALM("HEADER3","")
+23 QUIT
+24 ;
+25 ;Build Resolution Status Inquiry array
+26 ;-------------------------------------
BUILD(ARRAY,D0) ;
+1 NEW DIWF,DIWL,DIWR,IC,SUB,TAB,TXT,X
+2 NEW ABBR,COL,CREA,DATA,DESC,FOUND,INACT,REST
+3 SET DIWF="C70"
SET DIWL=0
SET DIWR=70
SET IC=0
+4 KILL ^UTILITY($JOB,"W")
+5 ;Get Resolution status details
+6 SET DATA=$GET(^PXRMD(801.9,D0,0))
+7 SET DESC=$PIECE(DATA,U)
SET ABBR=$PIECE(DATA,U,2)
SET COL=$PIECE(DATA,U,3)
SET INACT=$PIECE(DATA,U,4)
+8 SET CREA=$PIECE(DATA,U,5)
SET REST=$PIECE(DATA,U,6)
+9 ;
+10 ;Resolution Status
+11 SET TXT="Resolution Status: "_DESC
+12 ;Restricted edit is same as National
+13 if REST
SET TXT="National "_TXT
DO SET(0,TXT,1)
+14 ;
+15 SET TXT="Resolution Status Description"
DO SET(0,TXT,0)
+16 ;Get Resolution Status description
+17 SET SUB=0
SET TAB=0
SET FOUND=0
+18 FOR
SET SUB=$ORDER(^PXRMD(801.9,D0,1,SUB))
if SUB=""
QUIT
Begin DoDot:1
+19 SET X=$GET(^PXRMD(801.9,D0,1,SUB,0))
+20 DO ^DIWP
End DoDot:1
+21 FOR
SET SUB=$ORDER(^UTILITY($JOB,"W",0,SUB))
if SUB=""
QUIT
Begin DoDot:1
+22 DO SET(5,^UTILITY($JOB,"W",0,SUB,0),0)
SET FOUND=1
End DoDot:1
+23 KILL ^UTILITY($JOB,"W")
+24 ;Display no description message
+25 IF 'FOUND
SET TXT="*NONE*"
DO SET(5,TXT,0)
+26 DO SET(0,"",1)
+27 ;
+28 ;Related National Status from cross reference
+29 IF 'REST
Begin DoDot:1
+30 ;Get national code from cross reference
+31 NEW IEN
SET IEN=$ORDER(^PXRMD(801.9,"AC",D0,""))
+32 ;If none allocated say so
+33 IF 'IEN
SET TXT="***UNDEFINED***"
+34 ;Get name of national status and display
+35 IF IEN
SET TXT=$PIECE($GET(^PXRMD(801.9,IEN,0)),U)
+36 SET TXT="Related National Status: "_TXT
DO SET(3,TXT,0)
End DoDot:1
+37 ;
+38 ;Abbreviated Name
+39 SET TXT="Abbreviated name: "_ABBR
DO SET(10,TXT,0)
+40 ;Report Column Headings
+41 SET TXT="Report Column Headings: "_ABBR
DO SET(4,TXT,0)
+42 ;Inactive flag
+43 SET TXT="Inactive Flag: "_$SELECT(INACT:"INACTIVE",1:"")
DO SET(13,TXT,0)
+44 ;Creator for local codes
+45 IF CREA
IF 'REST
Begin DoDot:1
+46 SET TXT="Creator: "_$$GET1^DIQ(200,CREA,.01)
DO SET(19,TXT,0)
End DoDot:1
+47 ;Local Resolution Statuses
+48 IF REST
Begin DoDot:1
+49 NEW LARRAY,LIEN
SET SUB=0
SET FOUND=0
+50 FOR
SET SUB=$ORDER(^PXRMD(801.9,D0,10,SUB))
if 'SUB
QUIT
Begin DoDot:2
+51 SET LIEN=$PIECE($GET(^PXRMD(801.9,D0,10,SUB,0)),U)
+52 IF LIEN
SET LARRAY(LIEN)=""
SET FOUND=1
End DoDot:2
+53 SET TXT="Local Resolution Statuses:"
DO SET(0,"",1)
DO SET(0,TXT,0)
+54 IF 'FOUND
SET TXT="*NONE*"
DO SET(5,TXT,0)
QUIT
+55 SET LIEN=""
FOR
SET LIEN=$ORDER(LARRAY(LIEN))
if 'LIEN
QUIT
Begin DoDot:2
+56 SET TXT=$PIECE($GET(^PXRMD(801.9,LIEN,0)),U)
DO SET(4,TXT,0)
End DoDot:2
End DoDot:1
+57 QUIT
+58 ;
+59 ;Save local array
+60 ;----------------
SET(TAB,TXT,LF) ;
+1 ;Save main line
+2 SET IC=IC+1
SET ARRAY(IC)=$JUSTIFY("",TAB)_TXT
+3 ;Additional line feeds
+4 IF LF
Begin DoDot:1
+5 NEW CNT
FOR CNT=1:1:LF
SET IC=IC+1
SET ARRAY(IC)=$JUSTIFY("",79)
End DoDot:1
+6 QUIT
