BEHORMCV.m

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