BEHORMCV ;MSC/IND/DKM - Cover Sheet: PCC Reminders ;20-Mar-2007 13:48;DKM
;;1.1;BEH COMPONENTS;*041001;Mar 20, 2007
;=================================================================
; Return pt's currently due PCC clinical reminders
; Format: ien (811.9)^reminder print name^date due^last occur
LIST(DATA,DFN,LOC,SRV) ;
N CNT,LP,LST,MIEN,NAM,DUE,LAST,X
S DATA=$$TMPGBL^CIAVMRPC,(CNT,LP)=0
Q:'DFN
S:'$G(LOC) LOC=+$G(^DIC(42,+$G(^DPT(DFN,.1)),44))
S:'$G(SRV) SRV=+$G(^VA(200,DUZ,5))
D REMLIST(.LST,LOC,SRV)
F S LP=$O(LST(LP)) Q:'LP D
.S MIEN=$P(LST(LP),U,2),NAM=""
.K ^TMP("PXRHM",$J)
.D MAIN^PXRM(DFN,MIEN,0)
.F S NAM=$O(^TMP("PXRHM",$J,MIEN,NAM)) Q:NAM="" D
..S X=^TMP("PXRHM",$J,MIEN,NAM),DUE=$P(X,U,2),LAST=$P(X,U,3),LAST=$S(LAST>0:LAST,1:"")
..D ADD(MIEN_U_NAM_U_DUE_U_LAST)
K ^TMP("PXRHM",$J)
Q
; Return detail for a pt's clinical reminder
DETAIL(DATA,DFN,IEN) ;
N CNT,LP,NAM
S DATA=$$TMPGBL^CIAVMRPC,CNT=0,NAM=""
K ^TMP("PXRHM",$J)
D MAIN^PXRM(DFN,IEN,5) ; 5 returns all reminder info
F S NAM=$O(^TMP("PXRHM",$J,IEN,NAM)),LP=0 Q:NAM="" D
.F S LP=$O(^TMP("PXRHM",$J,IEN,NAM,"TXT",LP)) Q:LP="" D ADD(^(LP))
K ^TMP("PXRHM",$J)
Q
; Add data to output global
ADD(X) S CNT=CNT+1,@DATA@(CNT)=$G(X)
Q
; Returns true if new cover sheet parameters are in effect
NEWCVOK() ;
N SRV,TMP
S SRV=$P($G(^VA(200,DUZ,5)),U)
D GETLST^XPAR(.TMP,"USR^SRV.`"_SRV_"^DIV^SYS^PKG","ORQQPX NEW REMINDER PARAMS","Q")
Q $S(TMP:$P($G(TMP(1)),U,2),1:0)
; Returns a list of all cover sheet reminders
REMLIST(DATA,LOC,SRV) ;
N LP,LST,CODE,IDX,IEN
I '$$NEWCVOK D Q
.D GETLST^XPAR(.DATA,"USR^LOC.`"_LOC_"^SRV.`"_SRV_"^DIV^SYS^PKG","ORQQPX SEARCH ITEMS","Q")
D REMACCUM(.LST,"PKG",1000)
D REMACCUM(.LST,"SYS",2000)
D REMACCUM(.LST,"DIV",3000)
D:SRV REMACCUM(.LST,"SRV.`"_SRV,4000)
D:LOC REMACCUM(.LST,"LOC.`"_LOC,5000)
D REMACCUM(.LST,"CLASS",6000)
D REMACCUM(.LST,"USR",7000)
S LP=0
F S LP=$O(LST(LP)) Q:'LP D
.S IDX=$P(LST(LP),U)
.F Q:'$D(DATA(IDX)) S IDX=IDX+1
.S CODE=$E($P(LST(LP),U,2),2)
.S IEN=$E($P(LST(LP),U,2),3,999)
.D:CODE="R" ADDREM(.DATA,IDX,IEN)
.D:CODE="C" ADDCAT(.DATA,IDX,IEN)
K DATA("B")
Q
; Accumulates TMP into DATA
; Format of entries in ORQQPX COVER SHEET REMINDERS:
; L:Lock;R:Remove;N:Normal / C:Category;R:Reminder / Cat or Rem IEN
REMACCUM(DATA,LVL,SORT,CLASS) ;
N IDX,LP,J,K,M,FOUND,ERR,TMP,FLAG,IEN
N FFLAG,FIEN,OUT,P2,ADD,DOADD,CODE
I LVL="CLASS" D
.N LST,CLS,CLSPRM,WP
.S CLSPRM="ORQQPX COVER SHEET REM CLASSES"
.D GETLST^XPAR(.LST,"SYS",CLSPRM,"Q",.ERR)
.S LP=0,M=0,CLASS=$G(CLASS)
.F S LP=$O(LST(LP)) Q:'LP D
..S CLS=$P(LST(LP),U)
..I +CLASS S ADD=CLS=+CLASS
..E S ADD=$$ISA^USRLM(DUZ,CLS,.ERR)
..I +ADD D
...D GETWP^XPAR(.WP,"SYS",CLSPRM,CLS,.ERR)
...S K=0
...F S K=$O(WP(K)) Q:'K D
....S M=M+1
....S J=$P(WP(K,0),";")
....S TMP(M)=J_U_$P(WP(K,0),";",2)
E D GETLST^XPAR(.TMP,LVL,"ORQQPX COVER SHEET REMINDERS","Q",.ERR)
S LP=0,IDX=$O(DATA(999999),-1)+1,ADD=SORT=""
F S LP=$O(TMP(LP)) Q:'LP D
.S (FOUND,J)=0,P2=$P(TMP(LP),U,2)
.S FLAG=$E(P2),IEN=$E(P2,2,999)
.I ADD S DOADD=1
.E D
..S DOADD=0
..F S J=$O(DATA(J)) Q:'J D Q:FOUND
...S P2=$P(DATA(J),U,2)
...S FIEN=$E(P2,2,999)
...I FIEN=IEN S FOUND=J,FFLAG=$E(P2)
..I FOUND D
...I FLAG="R",FFLAG'="L" K DATA(FOUND)
...I FLAG'=FFLAG,(FLAG_FFLAG)["L" S $E(P2)="L",$P(DATA(FOUND),U,2)=P2
..E S:FLAG'="R" DOADD=1
.I DOADD D
..S OUT(IDX)=TMP(LP)
..S $P(OUT(IDX),U)=$P(OUT(IDX),U)_SORT
..S:SORT="" OUT(IDX)=$$ADDNAME(OUT(IDX))
..S IDX=IDX+1
M DATA=OUT
Q
; Add Reminder or Category Name as 3rd piece
ADDNAME(NAM) ;
N CAT,IEN
S CAT=$E($P(NAM,U,2),2)
S IEN=$E($P(NAM,U,2),3,99)
I +IEN D
.S:CAT="R" $P(NAM,U,3)=$P($G(^PXD(811.9,IEN,0)),U,3)
.S:CAT="C" $P(NAM,U,3)=$P($G(^PXRMD(811.7,IEN,0)),U)
Q NAM
; Add Reminder to DATA list
ADDREM(DATA,IDX,IEN) ;
I $D(DATA("B",IEN)) Q ; See if it's in the list
I '$D(^PXD(811.9,IEN)) Q ; Check if Exists
I $P(^PXD(811.9,IEN,0),U,6)'="" Q ; Check if Active
S DATA(IDX)=IDX_U_IEN
S DATA("B",IEN)=""
Q
; Add Category Reminders to DATA list
ADDCAT(DATA,IDX,IEN) ;
N REM,I,IDX2,NREM
D CATREM^PXRMAPI0(IEN,.REM)
S I=0
F S I=$O(REM(I)) Q:'I D
.S IDX2="00000"_I
.S IDX2=$E(IDX2,$L(IDX2)-5,99)
.D ADDREM(.DATA,+(IDX_"."_IDX2),$P(REM(I),U))
Q
; XPAR value screen for ORQQPX SEARCH ITEMS
ACT(REM) Q:'REM 0
Q:$G(^PXD(811.9,REM,0))="" 0
I $L($T(INACTIVE^PXRM)),$$INACTIVE^PXRM(REM) Q 0
Q 1
BEHORMCV ;MSC/IND/DKM - Cover Sheet: PCC Reminders ;20-Mar-2007 13:48;DKM
+1 ;;1.1;BEH COMPONENTS;*041001;Mar 20, 2007
+2 ;=================================================================
+3 ; Return pt's currently due PCC clinical reminders
+4 ; Format: ien (811.9)^reminder print name^date due^last occur
LIST(DATA,DFN,LOC,SRV) ;
+1 NEW CNT,LP,LST,MIEN,NAM,DUE,LAST,X
+2 SET DATA=$$TMPGBL^CIAVMRPC
SET (CNT,LP)=0
+3 IF 'DFN
QUIT
+4 IF '$GET(LOC)
SET LOC=+$GET(^DIC(42,+$GET(^DPT(DFN,.1)),44))
+5 IF '$GET(SRV)
SET SRV=+$GET(^VA(200,DUZ,5))
+6 DO REMLIST(.LST,LOC,SRV)
+7 FOR
SET LP=$ORDER(LST(LP))
IF 'LP
QUIT
Begin DoDot:1
+8 SET MIEN=$PIECE(LST(LP),U,2)
SET NAM=""
+9 KILL ^TMP("PXRHM",$JOB)
+10 DO MAIN^PXRM(DFN,MIEN,0)
+11 FOR
SET NAM=$ORDER(^TMP("PXRHM",$JOB,MIEN,NAM))
IF NAM=""
QUIT
Begin DoDot:2
+12 SET X=^TMP("PXRHM",$JOB,MIEN,NAM)
SET DUE=$PIECE(X,U,2)
SET LAST=$PIECE(X,U,3)
SET LAST=$SELECT(LAST>0:LAST,1:"")
+13 DO ADD(MIEN_U_NAM_U_DUE_U_LAST)
End DoDot:2
End DoDot:1
+14 KILL ^TMP("PXRHM",$JOB)
+15 QUIT
+16 ; Return detail for a pt's clinical reminder
DETAIL(DATA,DFN,IEN) ;
+1 NEW CNT,LP,NAM
+2 SET DATA=$$TMPGBL^CIAVMRPC
SET CNT=0
SET NAM=""
+3 KILL ^TMP("PXRHM",$JOB)
+4 ; 5 returns all reminder info
DO MAIN^PXRM(DFN,IEN,5)
+5 FOR
SET NAM=$ORDER(^TMP("PXRHM",$JOB,IEN,NAM))
SET LP=0
IF NAM=""
QUIT
Begin DoDot:1
+6 FOR
SET LP=$ORDER(^TMP("PXRHM",$JOB,IEN,NAM,"TXT",LP))
IF LP=""
QUIT
DO ADD(^(LP))
End DoDot:1
+7 KILL ^TMP("PXRHM",$JOB)
+8 QUIT
+9 ; Add data to output global
ADD(X) SET CNT=CNT+1
SET @DATA@(CNT)=$GET(X)
+1 QUIT
+2 ; Returns true if new cover sheet parameters are in effect
NEWCVOK() ;
+1 NEW SRV,TMP
+2 SET SRV=$PIECE($GET(^VA(200,DUZ,5)),U)
+3 DO GETLST^XPAR(.TMP,"USR^SRV.`"_SRV_"^DIV^SYS^PKG","ORQQPX NEW REMINDER PARAMS","Q")
+4 QUIT $SELECT(TMP:$PIECE($GET(TMP(1)),U,2),1:0)
+5 ; Returns a list of all cover sheet reminders
REMLIST(DATA,LOC,SRV) ;
+1 NEW LP,LST,CODE,IDX,IEN
+2 IF '$$NEWCVOK
Begin DoDot:1
+3 DO GETLST^XPAR(.DATA,"USR^LOC.`"_LOC_"^SRV.`"_SRV_"^DIV^SYS^PKG","ORQQPX SEARCH ITEMS","Q")
End DoDot:1
QUIT
+4 DO REMACCUM(.LST,"PKG",1000)
+5 DO REMACCUM(.LST,"SYS",2000)
+6 DO REMACCUM(.LST,"DIV",3000)
+7 IF SRV
DO REMACCUM(.LST,"SRV.`"_SRV,4000)
+8 IF LOC
DO REMACCUM(.LST,"LOC.`"_LOC,5000)
+9 DO REMACCUM(.LST,"CLASS",6000)
+10 DO REMACCUM(.LST,"USR",7000)
+11 SET LP=0
+12 FOR
SET LP=$ORDER(LST(LP))
IF 'LP
QUIT
Begin DoDot:1
+13 SET IDX=$PIECE(LST(LP),U)
+14 FOR
IF '$DATA(DATA(IDX))
QUIT
SET IDX=IDX+1
+15 SET CODE=$EXTRACT($PIECE(LST(LP),U,2),2)
+16 SET IEN=$EXTRACT($PIECE(LST(LP),U,2),3,999)
+17 IF CODE="R"
DO ADDREM(.DATA,IDX,IEN)
+18 IF CODE="C"
DO ADDCAT(.DATA,IDX,IEN)
End DoDot:1
+19 KILL DATA("B")
+20 QUIT
+21 ; Accumulates TMP into DATA
+22 ; Format of entries in ORQQPX COVER SHEET REMINDERS:
+23 ; L:Lock;R:Remove;N:Normal / C:Category;R:Reminder / Cat or Rem IEN
REMACCUM(DATA,LVL,SORT,CLASS) ;
+1 NEW IDX,LP,J,K,M,FOUND,ERR,TMP,FLAG,IEN
+2 NEW FFLAG,FIEN,OUT,P2,ADD,DOADD,CODE
+3 IF LVL="CLASS"
Begin DoDot:1
+4 NEW LST,CLS,CLSPRM,WP
+5 SET CLSPRM="ORQQPX COVER SHEET REM CLASSES"
+6 DO GETLST^XPAR(.LST,"SYS",CLSPRM,"Q",.ERR)
+7 SET LP=0
SET M=0
SET CLASS=$GET(CLASS)
+8 FOR
SET LP=$ORDER(LST(LP))
IF 'LP
QUIT
Begin DoDot:2
+9 SET CLS=$PIECE(LST(LP),U)
+10 IF +CLASS
SET ADD=CLS=+CLASS
+11 IF '$TEST
SET ADD=$$ISA^USRLM(DUZ,CLS,.ERR)
+12 IF +ADD
Begin DoDot:3
+13 DO GETWP^XPAR(.WP,"SYS",CLSPRM,CLS,.ERR)
+14 SET K=0
+15 FOR
SET K=$ORDER(WP(K))
IF 'K
QUIT
Begin DoDot:4
+16 SET M=M+1
+17 SET J=$PIECE(WP(K,0),";")
+18 SET TMP(M)=J_U_$PIECE(WP(K,0),";",2)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+19 IF '$TEST
DO GETLST^XPAR(.TMP,LVL,"ORQQPX COVER SHEET REMINDERS","Q",.ERR)
+20 SET LP=0
SET IDX=$ORDER(DATA(999999),-1)+1
SET ADD=SORT=""
+21 FOR
SET LP=$ORDER(TMP(LP))
IF 'LP
QUIT
Begin DoDot:1
+22 SET (FOUND,J)=0
SET P2=$PIECE(TMP(LP),U,2)
+23 SET FLAG=$EXTRACT(P2)
SET IEN=$EXTRACT(P2,2,999)
+24 IF ADD
SET DOADD=1
+25 IF '$TEST
Begin DoDot:2
+26 SET DOADD=0
+27 FOR
SET J=$ORDER(DATA(J))
IF 'J
QUIT
Begin DoDot:3
+28 SET P2=$PIECE(DATA(J),U,2)
+29 SET FIEN=$EXTRACT(P2,2,999)
+30 IF FIEN=IEN
SET FOUND=J
SET FFLAG=$EXTRACT(P2)
End DoDot:3
IF FOUND
QUIT
+31 IF FOUND
Begin DoDot:3
+32 IF FLAG="R"
IF FFLAG'="L"
KILL DATA(FOUND)
+33 IF FLAG'=FFLAG
IF (FLAG_FFLAG)["L"
SET $EXTRACT(P2)="L"
SET $PIECE(DATA(FOUND),U,2)=P2
End DoDot:3
+34 IF '$TEST
IF FLAG'="R"
SET DOADD=1
End DoDot:2
+35 IF DOADD
Begin DoDot:2
+36 SET OUT(IDX)=TMP(LP)
+37 SET $PIECE(OUT(IDX),U)=$PIECE(OUT(IDX),U)_SORT
+38 IF SORT=""
SET OUT(IDX)=$$ADDNAME(OUT(IDX))
+39 SET IDX=IDX+1
End DoDot:2
End DoDot:1
+40 MERGE DATA=OUT
+41 QUIT
+42 ; Add Reminder or Category Name as 3rd piece
ADDNAME(NAM) ;
+1 NEW CAT,IEN
+2 SET CAT=$EXTRACT($PIECE(NAM,U,2),2)
+3 SET IEN=$EXTRACT($PIECE(NAM,U,2),3,99)
+4 IF +IEN
Begin DoDot:1
+5 IF CAT="R"
SET $PIECE(NAM,U,3)=$PIECE($GET(^PXD(811.9,IEN,0)),U,3)
+6 IF CAT="C"
SET $PIECE(NAM,U,3)=$PIECE($GET(^PXRMD(811.7,IEN,0)),U)
End DoDot:1
+7 QUIT NAM
+8 ; Add Reminder to DATA list
ADDREM(DATA,IDX,IEN) ;
+1 ; See if it's in the list
IF $DATA(DATA("B",IEN))
QUIT
+2 ; Check if Exists
IF '$DATA(^PXD(811.9,IEN))
QUIT
+3 ; Check if Active
IF $PIECE(^PXD(811.9,IEN,0),U,6)'=""
QUIT
+4 SET DATA(IDX)=IDX_U_IEN
+5 SET DATA("B",IEN)=""
+6 QUIT
+7 ; Add Category Reminders to DATA list
ADDCAT(DATA,IDX,IEN) ;
+1 NEW REM,I,IDX2,NREM
+2 DO CATREM^PXRMAPI0(IEN,.REM)
+3 SET I=0
+4 FOR
SET I=$ORDER(REM(I))
IF 'I
QUIT
Begin DoDot:1
+5 SET IDX2="00000"_I
+6 SET IDX2=$EXTRACT(IDX2,$LENGTH(IDX2)-5,99)
+7 DO ADDREM(.DATA,+(IDX_"."_IDX2),$PIECE(REM(I),U))
End DoDot:1
+8 QUIT
+9 ; XPAR value screen for ORQQPX SEARCH ITEMS
ACT(REM) IF 'REM
QUIT 0
+1 IF $GET(^PXD(811.9,REM,0))=""
QUIT 0
+2 IF $LENGTH($TEXT(INACTIVE^PXRM))
IF $$INACTIVE^PXRM(REM)
QUIT 0
+3 QUIT 1
