PXRMFLST ; SLC/PJH - List Resolution Statuses ;07/25/2018
;;2.0;CLINICAL REMINDERS;**65**;Feb 04, 2005;Build 438
;
;List selected finding type parameter
;------------------------------------
START N BY,DC,DHD,DIC,FLDS,FR,L,LOGIC,MODE,NOW,TO,Y
;Get lists of finding types for display
N DEF,DEF1,DEF2 D DEF^PXRMRUTL("811.902",.DEF,.DEF1,.DEF2)
;
SELECT S MODE=""
S DIC="^PXRMD(801.45,"
S DIC(0)="AEMQ"
S DIC("A")="Select Finding Type: "
D ^DIC
I Y'=-1 D G SELECT
.D SET
.D DISP
END Q
;
;List all statuses
;-----------------
ALL N BY,DC,DHD,DIC,FLDS,FR,L,LOGIC,MODE,NOW,TO,Y
S Y=1,MODE="GENERAL"
;Get lists of finding types for display
N DEF,DEF1,DEF2 D DEF^PXRMRUTL("811.902",.DEF,.DEF1,.DEF2)
; Set Date for Header
S NOW=$$NOW^XLFDT
S NOW=$$FMTE^XLFDT(NOW,"1P")
D SET
S DIC="^PXRMD(801.45,"
S BY=".01"
S FR="",TO=""
S DHD="W ?0 D HED^PXRMFLST"
D DISP
Q
;
;Inquire/Print Option (for protocol PXRM GENERAL INQUIRE/PRINT)
;--------------------
INQ(Y) N BY,DC,DHD,DIC,FLDS,FR,L,LOGIC,MODE,NOW,TO
;Get lists of finding types for display
N DEF,DEF1,DEF2 D DEF^PXRMRUTL("811.902",.DEF,.DEF1,.DEF2)
S MODE=""
S DIC="^PXRMD(801.45,"
S DIC(0)="AEMQ"
D SET
D DISP
Q
;
HED ; Display Header (see DHD variable)
N TEMP,TEXTLEN,TEXTHED,TEXTUND
S TEXTHED="RESOLUTION STATUS LIST"
S TEXTUND=$TR($J("",IOM)," ","-")
S TEMP=NOW_" Page "_DC
S TEXTLEN=$L(TEMP)
W TEXTHED
W ?(IOM-TEXTLEN),TEMP
W !,TEXTUND,!!
Q
;
DISP ;DISPLAY (Display from FLDS array)
S L=0,FLDS="[PXRM FINDING TYPE PARAMETERS]"
D EN1^DIP
Q
;
SET ;Setup all the variables
;
; Set Date for Header
S NOW=$$NOW^XLFDT
S NOW=$$FMTE^XLFDT(NOW,"1P")
;
;These variables need to be setup every time because DIP kills them.
S BY="NUMBER"
S (FR,TO)=+$P(Y,U,1)
S DHD="W ?0 D HED^PXRMFLST"
;
Q
;
FDES N X S X=$P($G(^PXRMD(801.45,D0,0)),U) Q:X=""
I X="POV" W "(DIAGNOSIS)" Q
I X="CPT" W "(PROCEDURE)" Q
W "("_$G(DEF2(X))_")"
Q
;
DEF(RESULT,IEN) ;
N FIEN,GBL,GBLARR,TYPE
D BLDRLIST^PXRMVPTR(811.902,.01,.GBLARR)
S GBL="" F S GBL=$O(^PXD(811.9,IEN,20,"B",GBL)) Q:GBL="" D
.S FIEN=$P(GBL,";")
.S NODE=$G(GBLARR($P(GBL,";",2)))
.S TYPE=$P(NODE,U,4)
.I TYPE="RT" D TERM(.RESULT,FIEN) Q
.S RESULT(TYPE,$P(GBL,";"))=""
Q
;
TERM(RESULT,IEN) ;
N FIEN,GBL,GBLARR,TYPE
D BLDRLIST^PXRMVPTR(811.52,.01,.GBLARR)
S GBL="" F S GBL=$O(^PXRMD(811.5,IEN,20,"B",GBL)) Q:GBL="" D
.S FIEN=$P(GBL,";")
.S NODE=$G(GBLARR($P(GBL,";",2)))
.S TYPE=$P(NODE,U,4)
.S RESULT(TYPE,$P(GBL,";"))=""
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMFLST 2602 printed Oct 16, 2024@17:46:20 Page 2
PXRMFLST ; SLC/PJH - List Resolution Statuses ;07/25/2018
+1 ;;2.0;CLINICAL REMINDERS;**65**;Feb 04, 2005;Build 438
+2 ;
+3 ;List selected finding type parameter
+4 ;------------------------------------
START NEW BY,DC,DHD,DIC,FLDS,FR,L,LOGIC,MODE,NOW,TO,Y
+1 ;Get lists of finding types for display
+2 NEW DEF,DEF1,DEF2
DO DEF^PXRMRUTL("811.902",.DEF,.DEF1,.DEF2)
+3 ;
SELECT SET MODE=""
+1 SET DIC="^PXRMD(801.45,"
+2 SET DIC(0)="AEMQ"
+3 SET DIC("A")="Select Finding Type: "
+4 DO ^DIC
+5 IF Y'=-1
Begin DoDot:1
+6 DO SET
+7 DO DISP
End DoDot:1
GOTO SELECT
END QUIT
+1 ;
+2 ;List all statuses
+3 ;-----------------
ALL NEW BY,DC,DHD,DIC,FLDS,FR,L,LOGIC,MODE,NOW,TO,Y
+1 SET Y=1
SET MODE="GENERAL"
+2 ;Get lists of finding types for display
+3 NEW DEF,DEF1,DEF2
DO DEF^PXRMRUTL("811.902",.DEF,.DEF1,.DEF2)
+4 ; Set Date for Header
+5 SET NOW=$$NOW^XLFDT
+6 SET NOW=$$FMTE^XLFDT(NOW,"1P")
+7 DO SET
+8 SET DIC="^PXRMD(801.45,"
+9 SET BY=".01"
+10 SET FR=""
SET TO=""
+11 SET DHD="W ?0 D HED^PXRMFLST"
+12 DO DISP
+13 QUIT
+14 ;
+15 ;Inquire/Print Option (for protocol PXRM GENERAL INQUIRE/PRINT)
+16 ;--------------------
INQ(Y) NEW BY,DC,DHD,DIC,FLDS,FR,L,LOGIC,MODE,NOW,TO
+1 ;Get lists of finding types for display
+2 NEW DEF,DEF1,DEF2
DO DEF^PXRMRUTL("811.902",.DEF,.DEF1,.DEF2)
+3 SET MODE=""
+4 SET DIC="^PXRMD(801.45,"
+5 SET DIC(0)="AEMQ"
+6 DO SET
+7 DO DISP
+8 QUIT
+9 ;
HED ; Display Header (see DHD variable)
+1 NEW TEMP,TEXTLEN,TEXTHED,TEXTUND
+2 SET TEXTHED="RESOLUTION STATUS LIST"
+3 SET TEXTUND=$TRANSLATE($JUSTIFY("",IOM)," ","-")
+4 SET TEMP=NOW_" Page "_DC
+5 SET TEXTLEN=$LENGTH(TEMP)
+6 WRITE TEXTHED
+7 WRITE ?(IOM-TEXTLEN),TEMP
+8 WRITE !,TEXTUND,!!
+9 QUIT
+10 ;
DISP ;DISPLAY (Display from FLDS array)
+1 SET L=0
SET FLDS="[PXRM FINDING TYPE PARAMETERS]"
+2 DO EN1^DIP
+3 QUIT
+4 ;
SET ;Setup all the variables
+1 ;
+2 ; Set Date for Header
+3 SET NOW=$$NOW^XLFDT
+4 SET NOW=$$FMTE^XLFDT(NOW,"1P")
+5 ;
+6 ;These variables need to be setup every time because DIP kills them.
+7 SET BY="NUMBER"
+8 SET (FR,TO)=+$PIECE(Y,U,1)
+9 SET DHD="W ?0 D HED^PXRMFLST"
+10 ;
+11 QUIT
+12 ;
FDES NEW X
SET X=$PIECE($GET(^PXRMD(801.45,D0,0)),U)
if X=""
QUIT
+1 IF X="POV"
WRITE "(DIAGNOSIS)"
QUIT
+2 IF X="CPT"
WRITE "(PROCEDURE)"
QUIT
+3 WRITE "("_$GET(DEF2(X))_")"
+4 QUIT
+5 ;
DEF(RESULT,IEN) ;
+1 NEW FIEN,GBL,GBLARR,TYPE
+2 DO BLDRLIST^PXRMVPTR(811.902,.01,.GBLARR)
+3 SET GBL=""
FOR
SET GBL=$ORDER(^PXD(811.9,IEN,20,"B",GBL))
if GBL=""
QUIT
Begin DoDot:1
+4 SET FIEN=$PIECE(GBL,";")
+5 SET NODE=$GET(GBLARR($PIECE(GBL,";",2)))
+6 SET TYPE=$PIECE(NODE,U,4)
+7 IF TYPE="RT"
DO TERM(.RESULT,FIEN)
QUIT
+8 SET RESULT(TYPE,$PIECE(GBL,";"))=""
End DoDot:1
+9 QUIT
+10 ;
TERM(RESULT,IEN) ;
+1 NEW FIEN,GBL,GBLARR,TYPE
+2 DO BLDRLIST^PXRMVPTR(811.52,.01,.GBLARR)
+3 SET GBL=""
FOR
SET GBL=$ORDER(^PXRMD(811.5,IEN,20,"B",GBL))
if GBL=""
QUIT
Begin DoDot:1
+4 SET FIEN=$PIECE(GBL,";")
+5 SET NODE=$GET(GBLARR($PIECE(GBL,";",2)))
+6 SET TYPE=$PIECE(NODE,U,4)
+7 SET RESULT(TYPE,$PIECE(GBL,";"))=""
End DoDot:1
+8 QUIT
+9 ;
