- VPSPTCR ;BPIFO/KG - Patient DUE NOW Reminders RPC;07/03/14 15:30
- ;;1.0;VA POINT OF SERVICE (KIOSKS);**4**;Jul 3,2014;Build 27
- ;;Per VHA Directive 2004-038, this routine should not be modified.
- ;
- ; External Reference DBIA#
- ; ------------------------
- ; #2051 - FIND1^DIC (Supported)
- ; #2056 - GET1^DIQ (Supported)
- ; #2263 - GETWP^XPAR (Supported)
- ; #2263 - GETLST^XPAR (Supported)
- ; #2182 - MAIN^PXRM (Controlled Subs)
- ; #3333 - CATREM^PXRMAPI0 (Controlled Subs)
- ; #3960 - READ ACCESS TO File #811.7, Items .01 (Controlled Subs)
- ; #6113 - READ ACCESS TO File #811.9, Items 1.2, 1.6, 1.91, 103 (Controlled Subs)
- ; #10060 - READ ACCESS TO File #200, Items 16,29 (Supported)
- ; #1518 - READ ACCESS TO File #8989.3, Items 217 (Controlled Subs)
- Q
- ;
- REMIND(RESULT,DFN,DIV,SRV,LOC,USRCL) ;RPC: VPS GET CLINICAL REMINDERS
- ;Returns a list of patient's currently due PCE clinical reminders
- ;Input Parameter(s):
- ; DFN - Patient Identifier (File #2)
- ; DIV - Division Identifier (File #4)
- ; SRV - Service Identifier (File #49)
- ; LOC - Location Identifier (File #44)
- ; USRCL - List of User Classes separated by "^" (File #8930)
- ;Output Parameter(s):
- ; RESULT - Passed by reference, list of due now reminders
- ; Success : RESULT(0)=0, RESULT(1..n)= file 811.9 ien^reminder print name^date due^last occur.
- ; Error : RESULT(0)=-1^Error Message
- ;
- N VPSLST,VPSI,VPSJ,VPSIEN,VPSTXT,VPSX,VPSLSTDT,VPSDUEDT,VPSPRI,VPSDUE,VPSSTA
- ;
- ; -- validate patient ID
- I $G(DFN)="" S RESULT(0)="-1^PATIENT ID NOT SENT" Q
- I '$D(^DPT(DFN)) S RESULT(0)="-1^PATIENT "_DFN_" NOT FOUND" Q
- ;
- ; -- get all cover sheer reminder list
- D REMLIST(.VPSLST,$G(DIV),$G(SRV),$G(LOC),$G(USRCL))
- ;
- ; -- get clinical reminder for patient
- S VPSI=0,VPSJ=0
- F S VPSI=$O(VPSLST(VPSI)) Q:'VPSI D
- . S VPSIEN=$P(VPSLST(VPSI),U,2)
- . K ^TMP("PXRHM",$J)
- . D MAIN^PXRM(DFN,VPSIEN,0)
- . S VPSTXT="",VPSTXT=$O(^TMP("PXRHM",$J,VPSIEN,VPSTXT)) Q:VPSTXT="" D
- . . S VPSX=^TMP("PXRHM",$J,VPSIEN,VPSTXT)
- . . S VPSSTA=$P(VPSX,U,1),VPSDUEDT=$P(VPSX,U,2),VPSLSTDT=$P(VPSX,U,3)
- . . S VPSLSTDT=$S(+$G(VPSLSTDT)>0:VPSLSTDT,1:"") ;null if not a date
- . . S VPSJ=VPSJ+1
- . . S VPSDUE=$S(VPSSTA["DUE":1,VPSSTA["ERROR":3,VPSSTA["CNBD":4,1:2)
- . . I VPSDUE'=2 D I 1
- . . . S VPSPRI=$$GET1^DIQ(811.9,VPSIEN_",",1.91,"I") ;Priority
- . . . I VPSPRI="" S VPSPRI=2
- . . E S VPSDUEDT="",VPSLSTDT="",VPSPRI=""
- . . S RESULT(VPSJ)=VPSIEN_U_VPSTXT_U_VPSDUEDT_U_VPSLSTDT_U_VPSPRI_U_VPSDUE ;_U_$$DLG^PXRMRPCA(VPSIEN)_U_U_U_U_$$DLGWIPE^PXRMRPCA(VPSIEN)
- . K ^TMP("PXRHM",$J)
- ;
- I '$D(RESULT) S RESULT(0)="-1^NO CLINICAL REMINDERS FOUND FOR PATIENT "_DFN Q
- S RESULT(0)=1
- Q
- ;
- REMACCUM(RESULT,LVL,TYP,SORT,CLASS) ;Gets Reminder data for each Parameter Entity
- ;Input Parameter(s):
- ; LVL - Parameter Entity
- ; TYP - Format of returned data
- ; SORT - Sort order for Reminders
- ; CLASS - User classes
- ;Output Parameter(s):
- ; RESULT - Sorted list of Reminders
- ;
- ; Format of entries in ORQQPX COVER SHEET REMINDERS:
- ; L:Lock;R:Remove;N:Normal / C:Category;R:Reminder / Cat or Rem IEN
- N IDX,I,J,K,M,FOUND,VPSERR,VPSTMP,FLAG,IEN
- N FFLAG,FIEN,OUT,P2,ADD,DOADD,CODE
- I LVL="CLASS" D I 1
- . N VPSLST,VPSCLS,VPSCLSPM,VPSWP
- . S VPSCLSPM="ORQQPX COVER SHEET REM CLASSES"
- . D GETLST^XPAR(.VPSLST,"SYS",VPSCLSPM,"Q",.VPSERR)
- . S I=0,M=0,CLASS=$G(CLASS)
- . F S I=$O(VPSLST(I)) Q:'I D
- . . S VPSCLS=$P(VPSLST(I),U,1)
- . . S ADD=0
- . . I CLASS]"" S ADD=(U_CLASS_U)[(U_VPSCLS_U)
- . . I +ADD D
- . . . D GETWP^XPAR(.VPSWP,"SYS",VPSCLSPM,VPSCLS,.VPSERR)
- . . . S K=0
- . . . F S K=$O(VPSWP(K)) Q:'K D
- . . . . S M=M+1
- . . . . S J=$P(VPSWP(K,0),";",1)
- . . . . S VPSTMP(M)=J_U_$P(VPSWP(K,0),";",2)
- E D GETLST^XPAR(.VPSTMP,LVL,"ORQQPX COVER SHEET REMINDERS",TYP,.VPSERR)
- S I=0,IDX=$O(RESULT(999999),-1)+1,ADD=(SORT="")
- F S I=$O(VPSTMP(I)) Q:'I D
- . S (FOUND,J)=0,P2=$P(VPSTMP(I),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(RESULT(J)) Q:'J D Q:FOUND
- . . . S P2=$P(RESULT(J),U,2)
- . . . S FIEN=$E(P2,2,999)
- . . . I FIEN=IEN S FOUND=J,FFLAG=$E(P2)
- . . I FOUND D I 1
- . . . I FLAG="R",FFLAG'="L" K RESULT(FOUND)
- . . . I FLAG'=FFLAG,(FLAG_FFLAG)["L" S $E(P2)="L",$P(RESULT(FOUND),U,2)=P2
- . . E I (FLAG'="R") S DOADD=1
- . I DOADD D
- . . S OUT(IDX)=VPSTMP(I)
- . . S $P(OUT(IDX),U)=$P(OUT(IDX),U)_SORT
- . . I SORT="" S OUT(IDX)=$$ADDNAME(OUT(IDX))
- . . S IDX=IDX+1
- M RESULT=OUT
- Q
- ;
- REMLIST(RESULT,DIV,SRV,LOC,UCL) ;Returns a list of all cover sheet reminders
- ;Input Parameter(s):
- ; DIV - Division Identifier
- ; SRV - Service Identifier
- ; LOC - Location Identifier
- ; UCL - List of User Classes separated by "^"
- ;Output Parameter(s):
- ; RESULT - Passed by reference, list of cover sheet reminders
- ;
- N I,J,VPSLST,CODE,IDX,IEN,NEWP,VPSERR
- ;
- D NEWCVOK(.NEWP,DIV,SRV)
- I 'NEWP D GETLST^XPAR(.RESULT,"LOC.`"_+LOC_"^SRV.`"_+SRV_"^DIV.`"_+DIV_"^SYS^PKG","ORQQPX SEARCH ITEMS","Q",.VPSERR) Q
- D REMACCUM(.VPSLST,"PKG","Q",1000)
- D REMACCUM(.VPSLST,"SYS","Q",2000)
- I +DIV D REMACCUM(.VPSLST,"DIV.`"_+DIV,"Q",3000)
- I +SRV D REMACCUM(.VPSLST,"SRV.`"_+SRV,"Q",4000)
- I +LOC D REMACCUM(.VPSLST,"LOC.`"_+LOC,"Q",5000)
- I (UCL]"") D REMACCUM(.VPSLST,"CLASS","Q",6000,UCL)
- S I=0
- F S I=$O(VPSLST(I)) Q:'I D
- . S IDX=$P(VPSLST(I),U,1)
- . F Q:'$D(RESULT(IDX)) S IDX=IDX+1
- . S CODE=$E($P(VPSLST(I),U,2),2)
- . S IEN=$E($P(VPSLST(I),U,2),3,999)
- . I CODE="R" D ADDREM(.RESULT,IDX,IEN)
- . I CODE="C" D ADDCAT(.RESULT,IDX,IEN)
- K RESULT("B")
- Q
- ;
- ADDNAME(VPSX) ;Add Reminder or Category Name
- ;Input Parameter(s):
- ; VPSX - Reminder Info
- ;Output Parameter(s):
- ; VPSX - Add name as 3rd piece
- ;
- N CAT,IEN
- S CAT=$E($P(VPSX,U,2),2)
- S IEN=$E($P(VPSX,U,2),3,99)
- I +IEN D
- . I CAT="R" S $P(VPSX,U,3)=$$GET1^DIQ(811.9,IEN_",",1.2,"I") ;Print Name
- . I CAT="C" S $P(VPSX,U,3)=$$GET1^DIQ(811.7,IEN_",",.01,"I") ;Name
- Q VPSX
- ;
- ADDREM(RESULT,IDX,IEN) ;Add Reminder to RESULT list, if applicable
- ;Input Parameter(s):
- ; IDX - External Reminder ID
- ; IEN - Internal Reminder ID
- ;Output Parameter(s):
- ; RESULT - Pass by reference, list of reminders
- ;
- Q:$G(IDX)=""
- Q:$G(IEN)=""
- N USAGE
- I $D(RESULT("B",IEN)) Q ; See if it's in the list
- I '$$FIND1^DIC(811.9,,,"`"_IEN) Q ; Check if Exists
- I $$GET1^DIQ(811.9,IEN_",",1.6,"I")'="" Q ; Check if Active
- ;check to see if the reminder is assigned to CPRS
- S USAGE=$$GET1^DIQ(811.9,IEN_",",103,"I") ;Usage
- I USAGE["L" Q
- I USAGE'["C",USAGE'="*" Q
- S RESULT(IDX)=IDX_U_IEN
- S RESULT("B",IEN)=""
- Q
- ;
- ADDCAT(RESULT,IDX,IEN) ;Add Reminders in a Category Reminder to RESULT list individually
- ;Input Parameter(s):
- ; IDX - External Category Reminder ID
- ; IEN - Internal Category Reminder ID
- ;Output Parameter(s):
- ; RESULT - Pass by reference, list of reminders
- ;
- Q:$G(IDX)=""
- Q:$G(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(.RESULT,+(IDX_"."_IDX2),$P(REM(I),U,1))
- Q
- ;
- NEWCVOK(RESULT,DIV,SRV) ; Checks if New or Old style Reminders are used
- ;Input Parameter(s):
- ; DIV - Division Identifier
- ; SRV - Service Identifier
- ;Output Parameter(s):
- ; RESULT - Passed by reference
- ; RESULT = 1 - if new style reminders
- ; RESULT = 0 - if old style reminders
- ;
- N VPSERR,VPSTMP
- S RESULT=0
- D GETLST^XPAR(.VPSTMP,"SRV.`"_+$G(SRV)_"^DIV.`"_+$G(DIV)_"^SYS^PKG","ORQQPX NEW REMINDER PARAMS","Q",.VPSERR)
- I +VPSTMP S RESULT=$P($G(VPSTMP(1)),U,2)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPSPTCR 7782 printed Feb 19, 2025@00:09:48 Page 2
- VPSPTCR ;BPIFO/KG - Patient DUE NOW Reminders RPC;07/03/14 15:30
- +1 ;;1.0;VA POINT OF SERVICE (KIOSKS);**4**;Jul 3,2014;Build 27
- +2 ;;Per VHA Directive 2004-038, this routine should not be modified.
- +3 ;
- +4 ; External Reference DBIA#
- +5 ; ------------------------
- +6 ; #2051 - FIND1^DIC (Supported)
- +7 ; #2056 - GET1^DIQ (Supported)
- +8 ; #2263 - GETWP^XPAR (Supported)
- +9 ; #2263 - GETLST^XPAR (Supported)
- +10 ; #2182 - MAIN^PXRM (Controlled Subs)
- +11 ; #3333 - CATREM^PXRMAPI0 (Controlled Subs)
- +12 ; #3960 - READ ACCESS TO File #811.7, Items .01 (Controlled Subs)
- +13 ; #6113 - READ ACCESS TO File #811.9, Items 1.2, 1.6, 1.91, 103 (Controlled Subs)
- +14 ; #10060 - READ ACCESS TO File #200, Items 16,29 (Supported)
- +15 ; #1518 - READ ACCESS TO File #8989.3, Items 217 (Controlled Subs)
- +16 QUIT
- +17 ;
- REMIND(RESULT,DFN,DIV,SRV,LOC,USRCL) ;RPC: VPS GET CLINICAL REMINDERS
- +1 ;Returns a list of patient's currently due PCE clinical reminders
- +2 ;Input Parameter(s):
- +3 ; DFN - Patient Identifier (File #2)
- +4 ; DIV - Division Identifier (File #4)
- +5 ; SRV - Service Identifier (File #49)
- +6 ; LOC - Location Identifier (File #44)
- +7 ; USRCL - List of User Classes separated by "^" (File #8930)
- +8 ;Output Parameter(s):
- +9 ; RESULT - Passed by reference, list of due now reminders
- +10 ; Success : RESULT(0)=0, RESULT(1..n)= file 811.9 ien^reminder print name^date due^last occur.
- +11 ; Error : RESULT(0)=-1^Error Message
- +12 ;
- +13 NEW VPSLST,VPSI,VPSJ,VPSIEN,VPSTXT,VPSX,VPSLSTDT,VPSDUEDT,VPSPRI,VPSDUE,VPSSTA
- +14 ;
- +15 ; -- validate patient ID
- +16 IF $GET(DFN)=""
- SET RESULT(0)="-1^PATIENT ID NOT SENT"
- QUIT
- +17 IF '$DATA(^DPT(DFN))
- SET RESULT(0)="-1^PATIENT "_DFN_" NOT FOUND"
- QUIT
- +18 ;
- +19 ; -- get all cover sheer reminder list
- +20 DO REMLIST(.VPSLST,$GET(DIV),$GET(SRV),$GET(LOC),$GET(USRCL))
- +21 ;
- +22 ; -- get clinical reminder for patient
- +23 SET VPSI=0
- SET VPSJ=0
- +24 FOR
- SET VPSI=$ORDER(VPSLST(VPSI))
- if 'VPSI
- QUIT
- Begin DoDot:1
- +25 SET VPSIEN=$PIECE(VPSLST(VPSI),U,2)
- +26 KILL ^TMP("PXRHM",$JOB)
- +27 DO MAIN^PXRM(DFN,VPSIEN,0)
- +28 SET VPSTXT=""
- SET VPSTXT=$ORDER(^TMP("PXRHM",$JOB,VPSIEN,VPSTXT))
- if VPSTXT=""
- QUIT
- Begin DoDot:2
- +29 SET VPSX=^TMP("PXRHM",$JOB,VPSIEN,VPSTXT)
- +30 SET VPSSTA=$PIECE(VPSX,U,1)
- SET VPSDUEDT=$PIECE(VPSX,U,2)
- SET VPSLSTDT=$PIECE(VPSX,U,3)
- +31 ;null if not a date
- SET VPSLSTDT=$SELECT(+$GET(VPSLSTDT)>0:VPSLSTDT,1:"")
- +32 SET VPSJ=VPSJ+1
- +33 SET VPSDUE=$SELECT(VPSSTA["DUE":1,VPSSTA["ERROR":3,VPSSTA["CNBD":4,1:2)
- +34 IF VPSDUE'=2
- Begin DoDot:3
- +35 ;Priority
- SET VPSPRI=$$GET1^DIQ(811.9,VPSIEN_",",1.91,"I")
- +36 IF VPSPRI=""
- SET VPSPRI=2
- End DoDot:3
- IF 1
- +37 IF '$TEST
- SET VPSDUEDT=""
- SET VPSLSTDT=""
- SET VPSPRI=""
- +38 ;_U_$$DLG^PXRMRPCA(VPSIEN)_U_U_U_U_$$DLGWIPE^PXRMRPCA(VPSIEN)
- SET RESULT(VPSJ)=VPSIEN_U_VPSTXT_U_VPSDUEDT_U_VPSLSTDT_U_VPSPRI_U_VPSDUE
- End DoDot:2
- +39 KILL ^TMP("PXRHM",$JOB)
- End DoDot:1
- +40 ;
- +41 IF '$DATA(RESULT)
- SET RESULT(0)="-1^NO CLINICAL REMINDERS FOUND FOR PATIENT "_DFN
- QUIT
- +42 SET RESULT(0)=1
- +43 QUIT
- +44 ;
- REMACCUM(RESULT,LVL,TYP,SORT,CLASS) ;Gets Reminder data for each Parameter Entity
- +1 ;Input Parameter(s):
- +2 ; LVL - Parameter Entity
- +3 ; TYP - Format of returned data
- +4 ; SORT - Sort order for Reminders
- +5 ; CLASS - User classes
- +6 ;Output Parameter(s):
- +7 ; RESULT - Sorted list of Reminders
- +8 ;
- +9 ; Format of entries in ORQQPX COVER SHEET REMINDERS:
- +10 ; L:Lock;R:Remove;N:Normal / C:Category;R:Reminder / Cat or Rem IEN
- +11 NEW IDX,I,J,K,M,FOUND,VPSERR,VPSTMP,FLAG,IEN
- +12 NEW FFLAG,FIEN,OUT,P2,ADD,DOADD,CODE
- +13 IF LVL="CLASS"
- Begin DoDot:1
- +14 NEW VPSLST,VPSCLS,VPSCLSPM,VPSWP
- +15 SET VPSCLSPM="ORQQPX COVER SHEET REM CLASSES"
- +16 DO GETLST^XPAR(.VPSLST,"SYS",VPSCLSPM,"Q",.VPSERR)
- +17 SET I=0
- SET M=0
- SET CLASS=$GET(CLASS)
- +18 FOR
- SET I=$ORDER(VPSLST(I))
- if 'I
- QUIT
- Begin DoDot:2
- +19 SET VPSCLS=$PIECE(VPSLST(I),U,1)
- +20 SET ADD=0
- +21 IF CLASS]""
- SET ADD=(U_CLASS_U)[(U_VPSCLS_U)
- +22 IF +ADD
- Begin DoDot:3
- +23 DO GETWP^XPAR(.VPSWP,"SYS",VPSCLSPM,VPSCLS,.VPSERR)
- +24 SET K=0
- +25 FOR
- SET K=$ORDER(VPSWP(K))
- if 'K
- QUIT
- Begin DoDot:4
- +26 SET M=M+1
- +27 SET J=$PIECE(VPSWP(K,0),";",1)
- +28 SET VPSTMP(M)=J_U_$PIECE(VPSWP(K,0),";",2)
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- IF 1
- +29 IF '$TEST
- DO GETLST^XPAR(.VPSTMP,LVL,"ORQQPX COVER SHEET REMINDERS",TYP,.VPSERR)
- +30 SET I=0
- SET IDX=$ORDER(RESULT(999999),-1)+1
- SET ADD=(SORT="")
- +31 FOR
- SET I=$ORDER(VPSTMP(I))
- if 'I
- QUIT
- Begin DoDot:1
- +32 SET (FOUND,J)=0
- SET P2=$PIECE(VPSTMP(I),U,2)
- +33 SET FLAG=$EXTRACT(P2)
- SET IEN=$EXTRACT(P2,2,999)
- +34 IF ADD
- SET DOADD=1
- +35 IF '$TEST
- Begin DoDot:2
- +36 SET DOADD=0
- +37 FOR
- SET J=$ORDER(RESULT(J))
- if 'J
- QUIT
- Begin DoDot:3
- +38 SET P2=$PIECE(RESULT(J),U,2)
- +39 SET FIEN=$EXTRACT(P2,2,999)
- +40 IF FIEN=IEN
- SET FOUND=J
- SET FFLAG=$EXTRACT(P2)
- End DoDot:3
- if FOUND
- QUIT
- +41 IF FOUND
- Begin DoDot:3
- +42 IF FLAG="R"
- IF FFLAG'="L"
- KILL RESULT(FOUND)
- +43 IF FLAG'=FFLAG
- IF (FLAG_FFLAG)["L"
- SET $EXTRACT(P2)="L"
- SET $PIECE(RESULT(FOUND),U,2)=P2
- End DoDot:3
- IF 1
- +44 IF '$TEST
- IF (FLAG'="R")
- SET DOADD=1
- End DoDot:2
- +45 IF DOADD
- Begin DoDot:2
- +46 SET OUT(IDX)=VPSTMP(I)
- +47 SET $PIECE(OUT(IDX),U)=$PIECE(OUT(IDX),U)_SORT
- +48 IF SORT=""
- SET OUT(IDX)=$$ADDNAME(OUT(IDX))
- +49 SET IDX=IDX+1
- End DoDot:2
- End DoDot:1
- +50 MERGE RESULT=OUT
- +51 QUIT
- +52 ;
- REMLIST(RESULT,DIV,SRV,LOC,UCL) ;Returns a list of all cover sheet reminders
- +1 ;Input Parameter(s):
- +2 ; DIV - Division Identifier
- +3 ; SRV - Service Identifier
- +4 ; LOC - Location Identifier
- +5 ; UCL - List of User Classes separated by "^"
- +6 ;Output Parameter(s):
- +7 ; RESULT - Passed by reference, list of cover sheet reminders
- +8 ;
- +9 NEW I,J,VPSLST,CODE,IDX,IEN,NEWP,VPSERR
- +10 ;
- +11 DO NEWCVOK(.NEWP,DIV,SRV)
- +12 IF 'NEWP
- DO GETLST^XPAR(.RESULT,"LOC.`"_+LOC_"^SRV.`"_+SRV_"^DIV.`"_+DIV_"^SYS^PKG","ORQQPX SEARCH ITEMS","Q",.VPSERR)
- QUIT
- +13 DO REMACCUM(.VPSLST,"PKG","Q",1000)
- +14 DO REMACCUM(.VPSLST,"SYS","Q",2000)
- +15 IF +DIV
- DO REMACCUM(.VPSLST,"DIV.`"_+DIV,"Q",3000)
- +16 IF +SRV
- DO REMACCUM(.VPSLST,"SRV.`"_+SRV,"Q",4000)
- +17 IF +LOC
- DO REMACCUM(.VPSLST,"LOC.`"_+LOC,"Q",5000)
- +18 IF (UCL]"")
- DO REMACCUM(.VPSLST,"CLASS","Q",6000,UCL)
- +19 SET I=0
- +20 FOR
- SET I=$ORDER(VPSLST(I))
- if 'I
- QUIT
- Begin DoDot:1
- +21 SET IDX=$PIECE(VPSLST(I),U,1)
- +22 FOR
- if '$DATA(RESULT(IDX))
- QUIT
- SET IDX=IDX+1
- +23 SET CODE=$EXTRACT($PIECE(VPSLST(I),U,2),2)
- +24 SET IEN=$EXTRACT($PIECE(VPSLST(I),U,2),3,999)
- +25 IF CODE="R"
- DO ADDREM(.RESULT,IDX,IEN)
- +26 IF CODE="C"
- DO ADDCAT(.RESULT,IDX,IEN)
- End DoDot:1
- +27 KILL RESULT("B")
- +28 QUIT
- +29 ;
- ADDNAME(VPSX) ;Add Reminder or Category Name
- +1 ;Input Parameter(s):
- +2 ; VPSX - Reminder Info
- +3 ;Output Parameter(s):
- +4 ; VPSX - Add name as 3rd piece
- +5 ;
- +6 NEW CAT,IEN
- +7 SET CAT=$EXTRACT($PIECE(VPSX,U,2),2)
- +8 SET IEN=$EXTRACT($PIECE(VPSX,U,2),3,99)
- +9 IF +IEN
- Begin DoDot:1
- +10 ;Print Name
- IF CAT="R"
- SET $PIECE(VPSX,U,3)=$$GET1^DIQ(811.9,IEN_",",1.2,"I")
- +11 ;Name
- IF CAT="C"
- SET $PIECE(VPSX,U,3)=$$GET1^DIQ(811.7,IEN_",",.01,"I")
- End DoDot:1
- +12 QUIT VPSX
- +13 ;
- ADDREM(RESULT,IDX,IEN) ;Add Reminder to RESULT list, if applicable
- +1 ;Input Parameter(s):
- +2 ; IDX - External Reminder ID
- +3 ; IEN - Internal Reminder ID
- +4 ;Output Parameter(s):
- +5 ; RESULT - Pass by reference, list of reminders
- +6 ;
- +7 if $GET(IDX)=""
- QUIT
- +8 if $GET(IEN)=""
- QUIT
- +9 NEW USAGE
- +10 ; See if it's in the list
- IF $DATA(RESULT("B",IEN))
- QUIT
- +11 ; Check if Exists
- IF '$$FIND1^DIC(811.9,,,"`"_IEN)
- QUIT
- +12 ; Check if Active
- IF $$GET1^DIQ(811.9,IEN_",",1.6,"I")'=""
- QUIT
- +13 ;check to see if the reminder is assigned to CPRS
- +14 ;Usage
- SET USAGE=$$GET1^DIQ(811.9,IEN_",",103,"I")
- +15 IF USAGE["L"
- QUIT
- +16 IF USAGE'["C"
- IF USAGE'="*"
- QUIT
- +17 SET RESULT(IDX)=IDX_U_IEN
- +18 SET RESULT("B",IEN)=""
- +19 QUIT
- +20 ;
- ADDCAT(RESULT,IDX,IEN) ;Add Reminders in a Category Reminder to RESULT list individually
- +1 ;Input Parameter(s):
- +2 ; IDX - External Category Reminder ID
- +3 ; IEN - Internal Category Reminder ID
- +4 ;Output Parameter(s):
- +5 ; RESULT - Pass by reference, list of reminders
- +6 ;
- +7 if $GET(IDX)=""
- QUIT
- +8 if $GET(IEN)=""
- QUIT
- +9 NEW REM,I,IDX2,NREM
- +10 DO CATREM^PXRMAPI0(IEN,.REM)
- +11 SET I=0
- +12 FOR
- SET I=$ORDER(REM(I))
- if 'I
- QUIT
- Begin DoDot:1
- +13 SET IDX2="00000"_I
- +14 SET IDX2=$EXTRACT(IDX2,$LENGTH(IDX2)-5,99)
- +15 DO ADDREM(.RESULT,+(IDX_"."_IDX2),$PIECE(REM(I),U,1))
- End DoDot:1
- +16 QUIT
- +17 ;
- NEWCVOK(RESULT,DIV,SRV) ; Checks if New or Old style Reminders are used
- +1 ;Input Parameter(s):
- +2 ; DIV - Division Identifier
- +3 ; SRV - Service Identifier
- +4 ;Output Parameter(s):
- +5 ; RESULT - Passed by reference
- +6 ; RESULT = 1 - if new style reminders
- +7 ; RESULT = 0 - if old style reminders
- +8 ;
- +9 NEW VPSERR,VPSTMP
- +10 SET RESULT=0
- +11 DO GETLST^XPAR(.VPSTMP,"SRV.`"_+$GET(SRV)_"^DIV.`"_+$GET(DIV)_"^SYS^PKG","ORQQPX NEW REMINDER PARAMS","Q",.VPSERR)
- +12 IF +VPSTMP
- SET RESULT=$PIECE($GET(VPSTMP(1)),U,2)
- +13 QUIT