Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: VPSPTCR

VPSPTCR.m

Go to the documentation of this file.
  1. 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
  1. ;;Per VHA Directive 2004-038, this routine should not be modified.
  1. ;
  1. ; External Reference DBIA#
  1. ; ------------------------
  1. ; #2051 - FIND1^DIC (Supported)
  1. ; #2056 - GET1^DIQ (Supported)
  1. ; #2263 - GETWP^XPAR (Supported)
  1. ; #2263 - GETLST^XPAR (Supported)
  1. ; #2182 - MAIN^PXRM (Controlled Subs)
  1. ; #3333 - CATREM^PXRMAPI0 (Controlled Subs)
  1. ; #3960 - READ ACCESS TO File #811.7, Items .01 (Controlled Subs)
  1. ; #6113 - READ ACCESS TO File #811.9, Items 1.2, 1.6, 1.91, 103 (Controlled Subs)
  1. ; #10060 - READ ACCESS TO File #200, Items 16,29 (Supported)
  1. ; #1518 - READ ACCESS TO File #8989.3, Items 217 (Controlled Subs)
  1. Q
  1. ;
  1. REMIND(RESULT,DFN,DIV,SRV,LOC,USRCL) ;RPC: VPS GET CLINICAL REMINDERS
  1. ;Returns a list of patient's currently due PCE clinical reminders
  1. ;Input Parameter(s):
  1. ; DFN - Patient Identifier (File #2)
  1. ; DIV - Division Identifier (File #4)
  1. ; SRV - Service Identifier (File #49)
  1. ; LOC - Location Identifier (File #44)
  1. ; USRCL - List of User Classes separated by "^" (File #8930)
  1. ;Output Parameter(s):
  1. ; RESULT - Passed by reference, list of due now reminders
  1. ; Success : RESULT(0)=0, RESULT(1..n)= file 811.9 ien^reminder print name^date due^last occur.
  1. ; Error : RESULT(0)=-1^Error Message
  1. ;
  1. N VPSLST,VPSI,VPSJ,VPSIEN,VPSTXT,VPSX,VPSLSTDT,VPSDUEDT,VPSPRI,VPSDUE,VPSSTA
  1. ;
  1. ; -- validate patient ID
  1. I $G(DFN)="" S RESULT(0)="-1^PATIENT ID NOT SENT" Q
  1. I '$D(^DPT(DFN)) S RESULT(0)="-1^PATIENT "_DFN_" NOT FOUND" Q
  1. ;
  1. ; -- get all cover sheer reminder list
  1. D REMLIST(.VPSLST,$G(DIV),$G(SRV),$G(LOC),$G(USRCL))
  1. ;
  1. ; -- get clinical reminder for patient
  1. S VPSI=0,VPSJ=0
  1. F S VPSI=$O(VPSLST(VPSI)) Q:'VPSI D
  1. . S VPSIEN=$P(VPSLST(VPSI),U,2)
  1. . K ^TMP("PXRHM",$J)
  1. . D MAIN^PXRM(DFN,VPSIEN,0)
  1. . S VPSTXT="",VPSTXT=$O(^TMP("PXRHM",$J,VPSIEN,VPSTXT)) Q:VPSTXT="" D
  1. . . S VPSX=^TMP("PXRHM",$J,VPSIEN,VPSTXT)
  1. . . S VPSSTA=$P(VPSX,U,1),VPSDUEDT=$P(VPSX,U,2),VPSLSTDT=$P(VPSX,U,3)
  1. . . S VPSLSTDT=$S(+$G(VPSLSTDT)>0:VPSLSTDT,1:"") ;null if not a date
  1. . . S VPSJ=VPSJ+1
  1. . . S VPSDUE=$S(VPSSTA["DUE":1,VPSSTA["ERROR":3,VPSSTA["CNBD":4,1:2)
  1. . . I VPSDUE'=2 D I 1
  1. . . . S VPSPRI=$$GET1^DIQ(811.9,VPSIEN_",",1.91,"I") ;Priority
  1. . . . I VPSPRI="" S VPSPRI=2
  1. . . E S VPSDUEDT="",VPSLSTDT="",VPSPRI=""
  1. . . 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)
  1. . K ^TMP("PXRHM",$J)
  1. ;
  1. I '$D(RESULT) S RESULT(0)="-1^NO CLINICAL REMINDERS FOUND FOR PATIENT "_DFN Q
  1. S RESULT(0)=1
  1. Q
  1. ;
  1. REMACCUM(RESULT,LVL,TYP,SORT,CLASS) ;Gets Reminder data for each Parameter Entity
  1. ;Input Parameter(s):
  1. ; LVL - Parameter Entity
  1. ; TYP - Format of returned data
  1. ; SORT - Sort order for Reminders
  1. ; CLASS - User classes
  1. ;Output Parameter(s):
  1. ; RESULT - Sorted list of Reminders
  1. ;
  1. ; Format of entries in ORQQPX COVER SHEET REMINDERS:
  1. ; L:Lock;R:Remove;N:Normal / C:Category;R:Reminder / Cat or Rem IEN
  1. N IDX,I,J,K,M,FOUND,VPSERR,VPSTMP,FLAG,IEN
  1. N FFLAG,FIEN,OUT,P2,ADD,DOADD,CODE
  1. I LVL="CLASS" D I 1
  1. . N VPSLST,VPSCLS,VPSCLSPM,VPSWP
  1. . S VPSCLSPM="ORQQPX COVER SHEET REM CLASSES"
  1. . D GETLST^XPAR(.VPSLST,"SYS",VPSCLSPM,"Q",.VPSERR)
  1. . S I=0,M=0,CLASS=$G(CLASS)
  1. . F S I=$O(VPSLST(I)) Q:'I D
  1. . . S VPSCLS=$P(VPSLST(I),U,1)
  1. . . S ADD=0
  1. . . I CLASS]"" S ADD=(U_CLASS_U)[(U_VPSCLS_U)
  1. . . I +ADD D
  1. . . . D GETWP^XPAR(.VPSWP,"SYS",VPSCLSPM,VPSCLS,.VPSERR)
  1. . . . S K=0
  1. . . . F S K=$O(VPSWP(K)) Q:'K D
  1. . . . . S M=M+1
  1. . . . . S J=$P(VPSWP(K,0),";",1)
  1. . . . . S VPSTMP(M)=J_U_$P(VPSWP(K,0),";",2)
  1. E D GETLST^XPAR(.VPSTMP,LVL,"ORQQPX COVER SHEET REMINDERS",TYP,.VPSERR)
  1. S I=0,IDX=$O(RESULT(999999),-1)+1,ADD=(SORT="")
  1. F S I=$O(VPSTMP(I)) Q:'I D
  1. . S (FOUND,J)=0,P2=$P(VPSTMP(I),U,2)
  1. . S FLAG=$E(P2),IEN=$E(P2,2,999)
  1. . I ADD S DOADD=1
  1. . E D
  1. . . S DOADD=0
  1. . . F S J=$O(RESULT(J)) Q:'J D Q:FOUND
  1. . . . S P2=$P(RESULT(J),U,2)
  1. . . . S FIEN=$E(P2,2,999)
  1. . . . I FIEN=IEN S FOUND=J,FFLAG=$E(P2)
  1. . . I FOUND D I 1
  1. . . . I FLAG="R",FFLAG'="L" K RESULT(FOUND)
  1. . . . I FLAG'=FFLAG,(FLAG_FFLAG)["L" S $E(P2)="L",$P(RESULT(FOUND),U,2)=P2
  1. . . E I (FLAG'="R") S DOADD=1
  1. . I DOADD D
  1. . . S OUT(IDX)=VPSTMP(I)
  1. . . S $P(OUT(IDX),U)=$P(OUT(IDX),U)_SORT
  1. . . I SORT="" S OUT(IDX)=$$ADDNAME(OUT(IDX))
  1. . . S IDX=IDX+1
  1. M RESULT=OUT
  1. Q
  1. ;
  1. REMLIST(RESULT,DIV,SRV,LOC,UCL) ;Returns a list of all cover sheet reminders
  1. ;Input Parameter(s):
  1. ; DIV - Division Identifier
  1. ; SRV - Service Identifier
  1. ; LOC - Location Identifier
  1. ; UCL - List of User Classes separated by "^"
  1. ;Output Parameter(s):
  1. ; RESULT - Passed by reference, list of cover sheet reminders
  1. ;
  1. N I,J,VPSLST,CODE,IDX,IEN,NEWP,VPSERR
  1. ;
  1. D NEWCVOK(.NEWP,DIV,SRV)
  1. I 'NEWP D GETLST^XPAR(.RESULT,"LOC.`"_+LOC_"^SRV.`"_+SRV_"^DIV.`"_+DIV_"^SYS^PKG","ORQQPX SEARCH ITEMS","Q",.VPSERR) Q
  1. D REMACCUM(.VPSLST,"PKG","Q",1000)
  1. D REMACCUM(.VPSLST,"SYS","Q",2000)
  1. I +DIV D REMACCUM(.VPSLST,"DIV.`"_+DIV,"Q",3000)
  1. I +SRV D REMACCUM(.VPSLST,"SRV.`"_+SRV,"Q",4000)
  1. I +LOC D REMACCUM(.VPSLST,"LOC.`"_+LOC,"Q",5000)
  1. I (UCL]"") D REMACCUM(.VPSLST,"CLASS","Q",6000,UCL)
  1. S I=0
  1. F S I=$O(VPSLST(I)) Q:'I D
  1. . S IDX=$P(VPSLST(I),U,1)
  1. . F Q:'$D(RESULT(IDX)) S IDX=IDX+1
  1. . S CODE=$E($P(VPSLST(I),U,2),2)
  1. . S IEN=$E($P(VPSLST(I),U,2),3,999)
  1. . I CODE="R" D ADDREM(.RESULT,IDX,IEN)
  1. . I CODE="C" D ADDCAT(.RESULT,IDX,IEN)
  1. K RESULT("B")
  1. Q
  1. ;
  1. ADDNAME(VPSX) ;Add Reminder or Category Name
  1. ;Input Parameter(s):
  1. ; VPSX - Reminder Info
  1. ;Output Parameter(s):
  1. ; VPSX - Add name as 3rd piece
  1. ;
  1. N CAT,IEN
  1. S CAT=$E($P(VPSX,U,2),2)
  1. S IEN=$E($P(VPSX,U,2),3,99)
  1. I +IEN D
  1. . I CAT="R" S $P(VPSX,U,3)=$$GET1^DIQ(811.9,IEN_",",1.2,"I") ;Print Name
  1. . I CAT="C" S $P(VPSX,U,3)=$$GET1^DIQ(811.7,IEN_",",.01,"I") ;Name
  1. Q VPSX
  1. ;
  1. ADDREM(RESULT,IDX,IEN) ;Add Reminder to RESULT list, if applicable
  1. ;Input Parameter(s):
  1. ; IDX - External Reminder ID
  1. ; IEN - Internal Reminder ID
  1. ;Output Parameter(s):
  1. ; RESULT - Pass by reference, list of reminders
  1. ;
  1. Q:$G(IDX)=""
  1. Q:$G(IEN)=""
  1. N USAGE
  1. I $D(RESULT("B",IEN)) Q ; See if it's in the list
  1. I '$$FIND1^DIC(811.9,,,"`"_IEN) Q ; Check if Exists
  1. I $$GET1^DIQ(811.9,IEN_",",1.6,"I")'="" Q ; Check if Active
  1. ;check to see if the reminder is assigned to CPRS
  1. S USAGE=$$GET1^DIQ(811.9,IEN_",",103,"I") ;Usage
  1. I USAGE["L" Q
  1. I USAGE'["C",USAGE'="*" Q
  1. S RESULT(IDX)=IDX_U_IEN
  1. S RESULT("B",IEN)=""
  1. Q
  1. ;
  1. ADDCAT(RESULT,IDX,IEN) ;Add Reminders in a Category Reminder to RESULT list individually
  1. ;Input Parameter(s):
  1. ; IDX - External Category Reminder ID
  1. ; IEN - Internal Category Reminder ID
  1. ;Output Parameter(s):
  1. ; RESULT - Pass by reference, list of reminders
  1. ;
  1. Q:$G(IDX)=""
  1. Q:$G(IEN)=""
  1. N REM,I,IDX2,NREM
  1. D CATREM^PXRMAPI0(IEN,.REM)
  1. S I=0
  1. F S I=$O(REM(I)) Q:'I D
  1. . S IDX2="00000"_I
  1. . S IDX2=$E(IDX2,$L(IDX2)-5,99)
  1. . D ADDREM(.RESULT,+(IDX_"."_IDX2),$P(REM(I),U,1))
  1. Q
  1. ;
  1. NEWCVOK(RESULT,DIV,SRV) ; Checks if New or Old style Reminders are used
  1. ;Input Parameter(s):
  1. ; DIV - Division Identifier
  1. ; SRV - Service Identifier
  1. ;Output Parameter(s):
  1. ; RESULT - Passed by reference
  1. ; RESULT = 1 - if new style reminders
  1. ; RESULT = 0 - if old style reminders
  1. ;
  1. N VPSERR,VPSTMP
  1. S RESULT=0
  1. D GETLST^XPAR(.VPSTMP,"SRV.`"_+$G(SRV)_"^DIV.`"_+$G(DIV)_"^SYS^PKG","ORQQPX NEW REMINDER PARAMS","Q",.VPSERR)
  1. I +VPSTMP S RESULT=$P($G(VPSTMP(1)),U,2)
  1. Q