IBDFN15 ;ALB/CMR - ENCOUNTER FORM - OUTPUTS;JAN 4, 1996
;;3.0;AUTOMATED INFO COLLECTION SYS;**15**;APR 24, 1997
;
; -- clinical reminders interface
;
SELRM ; -- Select reminders using old structures
N DIC
K @IBARY
W !
S QUIT=0
S DIC("S")="I '$P(^(0),U,6)"
S DIC=811.9,DIC(0)="AEMQZ"
D ^DIC K DIC
I +Y>0 S @IBARY=+Y_"^"_$P(Y(0),"^",3)_"^DUE NOW^LAST ACTIVITY^DUE DATE^COMBO"
Q
;
DISP ; -- display reminders on encounter form, treat like a dynamic
; selection list
;
N I,L,X,Y,Z,ORD,SEL,LAST,IBDCLRM,IBDX,CNT,TEXT,IBCLRMNM,CLRMTYP,COMBO,INVISIBL,NODE,GRPORD,GRP,CLRMCNT
I $G(IBLIST("EDITING CLRM")) G SELRM
;
I +$G(IBLIST("CLRMLIST"))<1 S IBLIST("CLRMLIST")=2
S CLRMTYP=+$G(IBLIST("CLRMLIST"))-1
K ^TMP("PXRHM",$J),^TMP("PXRM",$J)
K ^TMP("IB",$J,"INTERFACES","PX CLINICAL REMINDERS PRINT")
Q:'$G(DFN)!('$G(IBLIST))
;
; -- determine which reminders are due now
; loop through groups and then selections
S GRPORD=""
F S GRPORD=$O(^IBE(357.4,"APO",+IBLIST,GRPORD)) Q:GRPORD="" S GRP=0 F S GRP=$O(^IBE(357.4,"APO",+IBLIST,GRPORD,GRP)) Q:'GRP D
.S NODE=$G(^IBE(357.4,+GRP,0))
.I $P(NODE,"^")="BLANK"!($P(NODE,"^",4)) S INVISIBL=1
.I '$G(INVISIBL) S CNT=$G(CNT)+1,^TMP("IB",$J,"INTERFACES","PX CLINICAL REMINDERS PRINT",CNT)="0^ "_$P(NODE,"^")
.D ONEGRP
;
K RTNLIST(RTN("RTN")),^TMP("PXRM",$J),^TMP("PXHRM",$J)
I $G(CLRMCNT)<1 S ^TMP("IB",$J,"INTERFACES","PX CLINICAL REMINDERS PRINT",1)="0^No Reminders in List"
I $G(CLRMCNT),'$D(^TMP("IB",$J,"INTERFACES","PX CLINICAL REMINDERS PRINT")) D
.S ^TMP("IB",$J,"INTERFACES","PX CLINICAL REMINDERS PRINT",1)="0^No. Reminders Evaluated: "_CLRMCNT
.I CLRMTYP S ^TMP("IB",$J,"INTERFACES","PX CLINICAL REMINDERS PRINT",2)="0^None Applicable this patient"
.I 'CLRMTYP S ^TMP("IB",$J,"INTERFACES","PX CLINICAL REMINDERS PRINT",2)="0^None Due Now"
Q
;
ONEGRP ; -- loop through entries of one group in order
S ORD="" F S ORD=$O(^IBE(357.3,"APO",+IBLIST,GRP,ORD)) Q:ORD="" S SEL=0 F S SEL=$O(^IBE(357.3,"APO",+IBLIST,+GRP,ORD,SEL)) Q:'SEL D
.S IBDCLRM=$G(^IBE(357.3,SEL,0))
.I +IBDCLRM,'$P(IBDCLRM,"^",2) D
..S CLRMCNT=$G(CLRMCNT)+1
..D MAIN^PXRM(DFN,+IBDCLRM,CLRMTYP)
..S TEXT=$O(^TMP("PXRHM",$J,+IBDCLRM,""))
..Q:TEXT=""
..S NODE=$G(^TMP("PXRHM",$J,+IBDCLRM,TEXT))
..K ^TMP("PXRHM",$J),^TMP("PXRM",$J)
..I $P(NODE,"^")="N/A" Q ;don't display not applicables
..I CLRMTYP=0,$P(NODE,"^")'="DUE NOW" Q ;type of list DUE NOW only
..S LAST=$P(NODE,"^",3) I +LAST,$L($P(LAST,"."))=7 S LAST=$$FMTE^XLFDT(LAST)
..I $P(NODE,"^",5)="E" S LAST=LAST_" (E)" ;last activity was historical encounter, see px*1*38
..S CNT=$G(CNT)+1
..S COMBO=$S($P(NODE,"^")="DUE NOW":"DUE NOW",1:$$FMTE^XLFDT($P(NODE,"^",2)))
..S ^TMP("IB",$J,"INTERFACES","PX CLINICAL REMINDERS PRINT",CNT)="0^"_TEXT_"^"_$P(NODE,"^")_"^"_$$FMTE^XLFDT($P(NODE,"^",2))_"^"_LAST_"^"_COMBO
.;
.I $P(IBDCLRM,"^",2) S CNT=$G(CNT)+1,^TMP("IB",$J,"INTERFACES","PX CLINICAL REMINDERS PRINT",CNT)="0^ "_$P(IBDCLRM,"^",6)
Q
;
TEST ;
N DFN,IBLIST,RTN,X
K ^TMP("IB",$J,"INTERFACES","PX CLINICAL REMINDERS PRINT")
S DFN=7169761 ;mnt,vbb-male
;S DFN=7170189 ;mnt,vbb-female
;S DFN=712 ;dev,den-male
S IBLIST("CLRMLIST")=2
S IBLIST=489 ;dev,den
S IBLIST=430 ;mnt,vbb
S RTN("RTN")="IBDFN15"
D DISP
T1 S X="" F S X=$O(^TMP("IB",$J,"INTERFACES","PX CLINICAL REMINDERS PRINT",X)) Q:'X W !,^(X)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDFN15 3429 printed Apr 09, 2024@20:55:53 Page 2
IBDFN15 ;ALB/CMR - ENCOUNTER FORM - OUTPUTS;JAN 4, 1996
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;**15**;APR 24, 1997
+2 ;
+3 ; -- clinical reminders interface
+4 ;
SELRM ; -- Select reminders using old structures
+1 NEW DIC
+2 KILL @IBARY
+3 WRITE !
+4 SET QUIT=0
+5 SET DIC("S")="I '$P(^(0),U,6)"
+6 SET DIC=811.9
SET DIC(0)="AEMQZ"
+7 DO ^DIC
KILL DIC
+8 IF +Y>0
SET @IBARY=+Y_"^"_$PIECE(Y(0),"^",3)_"^DUE NOW^LAST ACTIVITY^DUE DATE^COMBO"
+9 QUIT
+10 ;
DISP ; -- display reminders on encounter form, treat like a dynamic
+1 ; selection list
+2 ;
+3 NEW I,L,X,Y,Z,ORD,SEL,LAST,IBDCLRM,IBDX,CNT,TEXT,IBCLRMNM,CLRMTYP,COMBO,INVISIBL,NODE,GRPORD,GRP,CLRMCNT
+4 IF $GET(IBLIST("EDITING CLRM"))
GOTO SELRM
+5 ;
+6 IF +$GET(IBLIST("CLRMLIST"))<1
SET IBLIST("CLRMLIST")=2
+7 SET CLRMTYP=+$GET(IBLIST("CLRMLIST"))-1
+8 KILL ^TMP("PXRHM",$JOB),^TMP("PXRM",$JOB)
+9 KILL ^TMP("IB",$JOB,"INTERFACES","PX CLINICAL REMINDERS PRINT")
+10 if '$GET(DFN)!('$GET(IBLIST))
QUIT
+11 ;
+12 ; -- determine which reminders are due now
+13 ; loop through groups and then selections
+14 SET GRPORD=""
+15 FOR
SET GRPORD=$ORDER(^IBE(357.4,"APO",+IBLIST,GRPORD))
if GRPORD=""
QUIT
SET GRP=0
FOR
SET GRP=$ORDER(^IBE(357.4,"APO",+IBLIST,GRPORD,GRP))
if 'GRP
QUIT
Begin DoDot:1
+16 SET NODE=$GET(^IBE(357.4,+GRP,0))
+17 IF $PIECE(NODE,"^")="BLANK"!($PIECE(NODE,"^",4))
SET INVISIBL=1
+18 IF '$GET(INVISIBL)
SET CNT=$GET(CNT)+1
SET ^TMP("IB",$JOB,"INTERFACES","PX CLINICAL REMINDERS PRINT",CNT)="0^ "_$PIECE(NODE,"^")
+19 DO ONEGRP
End DoDot:1
+20 ;
+21 KILL RTNLIST(RTN("RTN")),^TMP("PXRM",$JOB),^TMP("PXHRM",$JOB)
+22 IF $GET(CLRMCNT)<1
SET ^TMP("IB",$JOB,"INTERFACES","PX CLINICAL REMINDERS PRINT",1)="0^No Reminders in List"
+23 IF $GET(CLRMCNT)
IF '$DATA(^TMP("IB",$JOB,"INTERFACES","PX CLINICAL REMINDERS PRINT"))
Begin DoDot:1
+24 SET ^TMP("IB",$JOB,"INTERFACES","PX CLINICAL REMINDERS PRINT",1)="0^No. Reminders Evaluated: "_CLRMCNT
+25 IF CLRMTYP
SET ^TMP("IB",$JOB,"INTERFACES","PX CLINICAL REMINDERS PRINT",2)="0^None Applicable this patient"
+26 IF 'CLRMTYP
SET ^TMP("IB",$JOB,"INTERFACES","PX CLINICAL REMINDERS PRINT",2)="0^None Due Now"
End DoDot:1
+27 QUIT
+28 ;
ONEGRP ; -- loop through entries of one group in order
+1 SET ORD=""
FOR
SET ORD=$ORDER(^IBE(357.3,"APO",+IBLIST,GRP,ORD))
if ORD=""
QUIT
SET SEL=0
FOR
SET SEL=$ORDER(^IBE(357.3,"APO",+IBLIST,+GRP,ORD,SEL))
if 'SEL
QUIT
Begin DoDot:1
+2 SET IBDCLRM=$GET(^IBE(357.3,SEL,0))
+3 IF +IBDCLRM
IF '$PIECE(IBDCLRM,"^",2)
Begin DoDot:2
+4 SET CLRMCNT=$GET(CLRMCNT)+1
+5 DO MAIN^PXRM(DFN,+IBDCLRM,CLRMTYP)
+6 SET TEXT=$ORDER(^TMP("PXRHM",$JOB,+IBDCLRM,""))
+7 if TEXT=""
QUIT
+8 SET NODE=$GET(^TMP("PXRHM",$JOB,+IBDCLRM,TEXT))
+9 KILL ^TMP("PXRHM",$JOB),^TMP("PXRM",$JOB)
+10 ;don't display not applicables
IF $PIECE(NODE,"^")="N/A"
QUIT
+11 ;type of list DUE NOW only
IF CLRMTYP=0
IF $PIECE(NODE,"^")'="DUE NOW"
QUIT
+12 SET LAST=$PIECE(NODE,"^",3)
IF +LAST
IF $LENGTH($PIECE(LAST,"."))=7
SET LAST=$$FMTE^XLFDT(LAST)
+13 ;last activity was historical encounter, see px*1*38
IF $PIECE(NODE,"^",5)="E"
SET LAST=LAST_" (E)"
+14 SET CNT=$GET(CNT)+1
+15 SET COMBO=$SELECT($PIECE(NODE,"^")="DUE NOW":"DUE NOW",1:$$FMTE^XLFDT($PIECE(NODE,"^",2)))
+16 SET ^TMP("IB",$JOB,"INTERFACES","PX CLINICAL REMINDERS PRINT",CNT)="0^"_TEXT_"^"_$PIECE(NODE,"^")_"^"_$$FMTE^XLFDT($PIECE(NODE,"^",2))_"^"_LAST_"^"_COMBO
End DoDot:2
+17 ;
+18 IF $PIECE(IBDCLRM,"^",2)
SET CNT=$GET(CNT)+1
SET ^TMP("IB",$JOB,"INTERFACES","PX CLINICAL REMINDERS PRINT",CNT)="0^ "_$PIECE(IBDCLRM,"^",6)
End DoDot:1
+19 QUIT
+20 ;
TEST ;
+1 NEW DFN,IBLIST,RTN,X
+2 KILL ^TMP("IB",$JOB,"INTERFACES","PX CLINICAL REMINDERS PRINT")
+3 ;mnt,vbb-male
SET DFN=7169761
+4 ;S DFN=7170189 ;mnt,vbb-female
+5 ;S DFN=712 ;dev,den-male
+6 SET IBLIST("CLRMLIST")=2
+7 ;dev,den
SET IBLIST=489
+8 ;mnt,vbb
SET IBLIST=430
+9 SET RTN("RTN")="IBDFN15"
+10 DO DISP
T1 SET X=""
FOR
SET X=$ORDER(^TMP("IB",$JOB,"INTERFACES","PX CLINICAL REMINDERS PRINT",X))
if 'X
QUIT
WRITE !,^(X)
+1 QUIT
