- 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 Feb 19, 2025@00:19:18 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