- ORQQPX ; SLC/JM - PCE and Reminder routines ;10/16/2019
- ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,184,187,190,226,377**;Dec 17, 1997;Build 582
- Q
- ;
- IMMLIST(ORY,ORPT,ORSORT) ;return pt's immunization list:
- ;id^name^date/time^reaction^inverse d/t
- I $L($T(IMMUN^PXRHS03))<1 S ORY(1)="^Immunizations not available." Q
- K ^TMP("PXI",$J)
- D IMMUN^PXRHS03(ORPT,$G(ORSORT))
- N ORI,IMM,IVDT,IEN,X
- S ORI=0,IMM="",IVDT="",IEN=0
- F S IMM=$O(^TMP("PXI",$J,IMM)) Q:IMM="" D
- .F S IVDT=$O(^TMP("PXI",$J,IMM,IVDT)) Q:IVDT="" D
- ..F S IEN=$O(^TMP("PXI",$J,IMM,IVDT,IEN)) Q:IEN<1 D
- ...S ORI=ORI+1,X=$G(^TMP("PXI",$J,IMM,IVDT,IEN,0)) Q:'$L(X)
- ...S ORY(ORI)=IEN_U_IMM_U_$P(X,U,3)
- ...I $P(X,U,7)=1 S ORY(ORI)=ORY(ORI)_U_$P(X,U,6)_U_IVDT
- ...E S ORY(ORI)=ORY(ORI)_U_U_IVDT
- S:+$G(ORY(1))<1 ORY(1)="^No immunizations found.^2900101^^9999999"
- K ^TMP("PXI",$J)
- Q
- ;
- DETAIL(ORY,IMM) ; return detailed information for an immunization
- S ORY(1)="Detailed information on immunizations is not available."
- Q
- ;
- REMIND(ORY,ORPT) ;return pt's currently due PCE clinical reminders
- ; in the format file 811.9 ien^reminder print name^date due^last occur.
- N ORTMPLST,ORI,ORJ,ORIEN,ORTXT,ORX,ORLASTDT,ORDUEDT,ORLOC
- S ORJ=0
- ;
- ;get patient's location flag (INPATIENT ONLY - outpt locations cannot be
- ;reliably determined, and many simultaneous outpt locations can occur):
- I +$G(ORPT)>0 D
- .N DFN S DFN=ORPT,VA200="" D OERR^VADPT
- .I +$G(VAIN(4))>0 S ORLOC=+$G(^DIC(42,+$G(VAIN(4)),44))
- .K VA200,VAIN
- ;
- D REMLIST(.ORTMPLST,$G(ORLOC))
- ;D GETLST^XPAR(.ORTMPLST,"USR^LOC.`"_$G(ORLOC)_"^SRV.`"_+$G(ORSRV)_"^DIV^SYS^PKG","ORQQPX SEARCH ITEMS","Q",.ORERR)
- ;I ORERR>0 S ORY(1)=U_"Error: "_$P(ORERR,U,2) Q
- D AVAL^PXRMRPCA(.ORTMPLST,2)
- Q
- ;
- REMDET(ORY,ORPT,ORIEN) ;return detail for a pt's clinical reminder
- ; ORY - return array
- ; ORPT - patient DFN
- ; ORIEN - clinical reminder (811.9 ien)
- K ^TMP("PXRHM",$J)
- D MAIN^PXRM(ORPT,ORIEN,5) ; 5 returns all reminder info
- N CR,I,J,ORTXT S I=1
- S ORTXT="",ORTXT=$O(^TMP("PXRHM",$J,ORIEN,ORTXT)) Q:ORTXT="" D
- .S J=0 F S J=$O(^TMP("PXRHM",$J,ORIEN,ORTXT,"TXT",J)) Q:J="" D
- ..S ORY(I)=^TMP("PXRHM",$J,ORIEN,ORTXT,"TXT",J),I=I+1
- K ^TMP("PXRHM",$J)
- Q
- ;
- NEWACTIV(ORY) ;Return true if Interactive Reminders are active
- S ORY=0
- I $T(APPL^PXRMRPCA)'="",+$G(DUZ) D
- . N SRV
- . S SRV=$$GET1^DIQ(200,DUZ,29,"I")
- . S ORY=$$GET^XPAR(DUZ_";VA(200,^SRV.`"_+$G(SRV)_"^DIV^SYS","PXRM GUI REMINDERS ACTIVE",1,"Q")
- . I +ORY S ORY=1
- . E S ORY=0
- Q
- ;
- HISTLOC(LST) ;Returns a list of historical locations
- N IDX,PTR,LINE,NAME
- K ^TMP("OR",$J,"LOC")
- S LST=$NA(^TMP("OR",$J,"LOC"))
- S (LINE,IDX)=0
- F S IDX=$O(^AUTTLOC(IDX)) Q:'IDX D
- .S PTR=+$G(^AUTTLOC(IDX,0))
- .I +PTR D
- ..S NAME=$$GET1^DIQ(4,PTR,.01,"I")
- ..I NAME'="" D
- ...S LINE=LINE+1
- ...S ^TMP("OR",$J,"LOC",LINE)=PTR_U_NAME
- Q
- ;
- GETFLDRS(ORFLDRS) ;Return Visible Reminder Folders
- ; Codes: D=Due, A=Applicable, N=Not Applicable, E=Evaluated, O=Other
- N SRV,ORERR,ORTMP
- S SRV=$$GET1^DIQ(200,DUZ,29,"I")
- D GETLST^XPAR(.ORTMP,"USR^SRV.`"_+$G(SRV)_"^DIV^SYS^PKG","ORQQPX REMINDER FOLDERS","Q",.ORERR)
- I +ORTMP S ORFLDRS=$P($G(ORTMP(1)),U,2)
- E S ORFLDRS="DAO"
- Q
- ;
- SETFLDRS(ORY,ORFLDRS) ;Sets Visible Reminder Folders for the current user
- N ORERR
- D EN^XPAR(DUZ_";VA(200,","ORQQPX REMINDER FOLDERS",1,ORFLDRS,.ORERR)
- S ORY=1
- Q
- ;
- GETDEFOL(ORDEFLOC) ;Return Default Outside Locations
- N SRV,ORERR
- S SRV=$$GET1^DIQ(200,DUZ,29,"I")
- D GETLST^XPAR(.ORDEFLOC,"USR^SRV.`"_+$G(SRV)_"^DIV^SYS^PKG","ORQQPX DEFAULT LOCATIONS","Q",.ORERR)
- Q
- ;
- INSCURS(ORY) ; Returns status of ORQQPX REMINDER TEXT AT CURSOR
- N SRV,ORERR,ORTMP
- S ORY=0,SRV=$$GET1^DIQ(200,DUZ,29,"I")
- D GETLST^XPAR(.ORTMP,"USR^SRV.`"_+$G(SRV)_"^DIV^SYS^PKG","ORQQPX REMINDER TEXT AT CURSOR","Q",.ORERR)
- I +ORTMP S ORY=$P($G(ORTMP(1)),U,2)
- Q
- ;
- NEWCVOK(ORY) ; Returns status of
- N SRV,ORERR,ORTMP
- S ORY=0,SRV=$$GET1^DIQ(200,DUZ,29,"I")
- D GETLST^XPAR(.ORTMP,"USR^SRV.`"_+$G(SRV)_"^DIV^SYS^PKG","ORQQPX NEW REMINDER PARAMS","Q",.ORERR)
- I +ORTMP S ORY=$P($G(ORTMP(1)),U,2)
- Q
- ;
- ADDNAME(ORX) ; Add Reminder or Category Name as 3rd piece
- N CAT,IEN
- S CAT=$E($P(ORX,U,2),2)
- S IEN=$E($P(ORX,U,2),3,99)
- I +IEN D
- .I CAT="R" S $P(ORX,U,3)=$P($G(^PXD(811.9,IEN,0)),U,3)
- .I CAT="C" S $P(ORX,U,3)=$P($G(^PXRMD(811.7,IEN,0)),U)
- Q ORX
- ;
- REMACCUM(ORY,LVL,TYP,SORT,CLASS) ; Accumulates ORTMP into ORY
- ; 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,ORERR,ORTMP,FLAG,IEN
- N FFLAG,FIEN,OUT,P2,ADD,DOADD,CODE
- I LVL="CLASS" D I 1
- .N ORLST,ORCLS,ORCLSPRM,ORWP
- .S ORCLSPRM="ORQQPX COVER SHEET REM CLASSES"
- .D GETLST^XPAR(.ORLST,"SYS",ORCLSPRM,"Q",.ORERR)
- .S I=0,M=0,CLASS=$G(CLASS)
- .F S I=$O(ORLST(I)) Q:'I D
- ..S ORCLS=$P(ORLST(I),U,1)
- ..I +CLASS S ADD=(ORCLS=+CLASS) I 1
- ..E S ADD=$$ISA^USRLM(DUZ,ORCLS,.ORERR)
- ..I +ADD D
- ...D GETWP^XPAR(.ORWP,"SYS",ORCLSPRM,ORCLS,.ORERR)
- ...S K=0
- ...F S K=$O(ORWP(K)) Q:'K D
- ....S M=M+1
- ....S J=$P(ORWP(K,0),";",1)
- ....S ORTMP(M)=J_U_$P(ORWP(K,0),";",2)
- E D GETLST^XPAR(.ORTMP,LVL,"ORQQPX COVER SHEET REMINDERS",TYP,.ORERR)
- S I=0,IDX=$O(ORY(999999),-1)+1,ADD=(SORT="")
- F S I=$O(ORTMP(I)) Q:'I D
- .S (FOUND,J)=0,P2=$P(ORTMP(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(ORY(J)) Q:'J D Q:FOUND
- ...S P2=$P(ORY(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 ORY(FOUND)
- ...I FLAG'=FFLAG,(FLAG_FFLAG)["L" S $E(P2)="L",$P(ORY(FOUND),U,2)=P2
- ..E I (FLAG'="R") S DOADD=1
- .I DOADD D
- ..S OUT(IDX)=ORTMP(I)
- ..S $P(OUT(IDX),U)=$P(OUT(IDX),U)_SORT
- ..I SORT="" S OUT(IDX)=$$ADDNAME(OUT(IDX))
- ..S IDX=IDX+1
- M ORY=OUT
- Q
- ;
- ADDREM(ORY,IDX,IEN) ; Add Reminder to ORY list
- I $D(ORY("B",IEN)) Q ; See if it's in the list
- I '$D(^PXD(811.9,IEN)) Q ; Check if Exists
- I $P($G(^PXD(811.9,IEN,0)),U,6)'="" Q ; Check if Active
- ;Check to see if the reminder is assigned to CPRS
- N USAGE
- S USAGE=$P($G(^PXD(811.9,IEN,100)),U,4)
- ;If the Usage is List or Order Check skip it.
- I (USAGE["L")!(USAGE["O") Q
- ;If the Usage is not C or * skip it.
- I USAGE'["C",USAGE'="*" Q
- S ORY(IDX)=IDX_U_IEN
- S ORY("B",IEN)=""
- Q
- ;
- ADDCAT(ORY,IDX,IEN) ; Add Category Reminders to ORY list
- N ORREM,I,IDX2,NREM
- D CATREM^PXRMAPI0(IEN,.ORREM)
- S I=0
- F S I=$O(ORREM(I)) Q:'I D
- . S IDX2="00000"_I
- . S IDX2=$E(IDX2,$L(IDX2)-5,99)
- . D ADDREM(.ORY,+(IDX_"."_IDX2),$P(ORREM(I),U,1))
- Q
- ;
- REMLIST(ORY,LOC) ;Returns a list of all cover sheet reminders
- N SRV,I,J,ORLST,CODE,IDX,IEN,NEWP
- S SRV=$$GET1^DIQ(200,DUZ,29,"I")
- D NEWCVOK(.NEWP)
- I 'NEWP D Q
- . N OLDLIST,RESULT
- . D GETLST^XPAR(.OLDLIST,"USR^LOC.`"_$G(LOC)_"^SRV.`"_+$G(SRV)_"^DIV^SYS^PKG","ORQQPX SEARCH ITEMS","Q",.ORERR) Q
- . S I=0
- . F S I=$O(OLDLIST(I)) Q:'I D
- .. S IDX=$P(OLDLIST(I),U,1)
- .. F Q:'$D(RESULT(IDX)) S IDX=IDX+1
- .. S IEN=$P(OLDLIST(I),U,2)
- .. D ADDREM(.RESULT,IDX,IEN)
- . K RESULT("B")
- ;
- D REMACCUM(.ORLST,"PKG","Q",1000)
- D REMACCUM(.ORLST,"SYS","Q",2000)
- D REMACCUM(.ORLST,"DIV","Q",3000)
- I +SRV D REMACCUM(.ORLST,"SRV.`"_+$G(SRV),"Q",4000)
- I +LOC D REMACCUM(.ORLST,"LOC.`"_+$G(LOC),"Q",5000)
- D REMACCUM(.ORLST,"CLASS","Q",6000)
- D REMACCUM(.ORLST,"USR","Q",7000)
- S I=0
- F S I=$O(ORLST(I)) Q:'I D
- .S IDX=$P(ORLST(I),U,1)
- .F Q:'$D(ORY(IDX)) S IDX=IDX+1
- .S CODE=$E($P(ORLST(I),U,2),2)
- .S IEN=$E($P(ORLST(I),U,2),3,999)
- .I CODE="R" D ADDREM(.ORY,IDX,IEN)
- .I CODE="C" D ADDCAT(.ORY,IDX,IEN)
- K ORY("B")
- Q
- ;
- LVREMLST(ORY,LVL,CLASS) ;Returns cover sheet reminders at a specified level
- D REMACCUM(.ORY,LVL,"Q","",$G(CLASS))
- Q
- ;
- SAVELVL(ORY,LVL,CLASS,DATA) ;Save cover sheet reminders at a specified level
- N ORERR,PARAM,I
- I LVL="CLASS" D I 1
- .S PARAM="ORQQPX COVER SHEET REM CLASSES"
- .S LVL="SYS"
- .D DEL^XPAR(LVL,PARAM,"`"_CLASS,.ORERR)
- .D EN^XPAR(LVL,PARAM,"`"_CLASS,.DATA,.ORERR)
- E D
- .S PARAM="ORQQPX COVER SHEET REMINDERS"
- .D NDEL^XPAR(LVL,PARAM,.ORERR)
- .S I=0
- .F S I=$O(DATA(I)) Q:'I D
- ..D EN^XPAR(LVL,PARAM,$P(DATA(I),U,1),$P(DATA(I),U,2),.ORERR)
- S ORY=1
- Q
- ;
- GETLIST(ORY,ORLOC) ;Returns a list of all cover sheet reminders
- N I
- D REMLIST(.ORY,$G(ORLOC))
- S I=0
- F S I=$O(ORY(I)) Q:'I D
- .S ORY(I)=$P(ORY(I),U,2)
- Q
- ;
- EVALCOVR(ORY,ORPT,ORLOC) ; Evaluate Cover Sheet Reminders
- N ORTMP
- D GETLIST(.ORTMP,$G(ORLOC))
- D ALIST^ORQQPXRM(.ORY,ORPT,.ORTMP)
- Q
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORQQPX 8663 printed Jan 18, 2025@03:34:54 Page 2
- ORQQPX ; SLC/JM - PCE and Reminder routines ;10/16/2019
- +1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,184,187,190,226,377**;Dec 17, 1997;Build 582
- +2 QUIT
- +3 ;
- IMMLIST(ORY,ORPT,ORSORT) ;return pt's immunization list:
- +1 ;id^name^date/time^reaction^inverse d/t
- +2 IF $LENGTH($TEXT(IMMUN^PXRHS03))<1
- SET ORY(1)="^Immunizations not available."
- QUIT
- +3 KILL ^TMP("PXI",$JOB)
- +4 DO IMMUN^PXRHS03(ORPT,$GET(ORSORT))
- +5 NEW ORI,IMM,IVDT,IEN,X
- +6 SET ORI=0
- SET IMM=""
- SET IVDT=""
- SET IEN=0
- +7 FOR
- SET IMM=$ORDER(^TMP("PXI",$JOB,IMM))
- if IMM=""
- QUIT
- Begin DoDot:1
- +8 FOR
- SET IVDT=$ORDER(^TMP("PXI",$JOB,IMM,IVDT))
- if IVDT=""
- QUIT
- Begin DoDot:2
- +9 FOR
- SET IEN=$ORDER(^TMP("PXI",$JOB,IMM,IVDT,IEN))
- if IEN<1
- QUIT
- Begin DoDot:3
- +10 SET ORI=ORI+1
- SET X=$GET(^TMP("PXI",$JOB,IMM,IVDT,IEN,0))
- if '$LENGTH(X)
- QUIT
- +11 SET ORY(ORI)=IEN_U_IMM_U_$PIECE(X,U,3)
- +12 IF $PIECE(X,U,7)=1
- SET ORY(ORI)=ORY(ORI)_U_$PIECE(X,U,6)_U_IVDT
- +13 IF '$TEST
- SET ORY(ORI)=ORY(ORI)_U_U_IVDT
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +14 if +$GET(ORY(1))<1
- SET ORY(1)="^No immunizations found.^2900101^^9999999"
- +15 KILL ^TMP("PXI",$JOB)
- +16 QUIT
- +17 ;
- DETAIL(ORY,IMM) ; return detailed information for an immunization
- +1 SET ORY(1)="Detailed information on immunizations is not available."
- +2 QUIT
- +3 ;
- REMIND(ORY,ORPT) ;return pt's currently due PCE clinical reminders
- +1 ; in the format file 811.9 ien^reminder print name^date due^last occur.
- +2 NEW ORTMPLST,ORI,ORJ,ORIEN,ORTXT,ORX,ORLASTDT,ORDUEDT,ORLOC
- +3 SET ORJ=0
- +4 ;
- +5 ;get patient's location flag (INPATIENT ONLY - outpt locations cannot be
- +6 ;reliably determined, and many simultaneous outpt locations can occur):
- +7 IF +$GET(ORPT)>0
- Begin DoDot:1
- +8 NEW DFN
- SET DFN=ORPT
- SET VA200=""
- DO OERR^VADPT
- +9 IF +$GET(VAIN(4))>0
- SET ORLOC=+$GET(^DIC(42,+$GET(VAIN(4)),44))
- +10 KILL VA200,VAIN
- End DoDot:1
- +11 ;
- +12 DO REMLIST(.ORTMPLST,$GET(ORLOC))
- +13 ;D GETLST^XPAR(.ORTMPLST,"USR^LOC.`"_$G(ORLOC)_"^SRV.`"_+$G(ORSRV)_"^DIV^SYS^PKG","ORQQPX SEARCH ITEMS","Q",.ORERR)
- +14 ;I ORERR>0 S ORY(1)=U_"Error: "_$P(ORERR,U,2) Q
- +15 DO AVAL^PXRMRPCA(.ORTMPLST,2)
- +16 QUIT
- +17 ;
- REMDET(ORY,ORPT,ORIEN) ;return detail for a pt's clinical reminder
- +1 ; ORY - return array
- +2 ; ORPT - patient DFN
- +3 ; ORIEN - clinical reminder (811.9 ien)
- +4 KILL ^TMP("PXRHM",$JOB)
- +5 ; 5 returns all reminder info
- DO MAIN^PXRM(ORPT,ORIEN,5)
- +6 NEW CR,I,J,ORTXT
- SET I=1
- +7 SET ORTXT=""
- SET ORTXT=$ORDER(^TMP("PXRHM",$JOB,ORIEN,ORTXT))
- if ORTXT=""
- QUIT
- Begin DoDot:1
- +8 SET J=0
- FOR
- SET J=$ORDER(^TMP("PXRHM",$JOB,ORIEN,ORTXT,"TXT",J))
- if J=""
- QUIT
- Begin DoDot:2
- +9 SET ORY(I)=^TMP("PXRHM",$JOB,ORIEN,ORTXT,"TXT",J)
- SET I=I+1
- End DoDot:2
- End DoDot:1
- +10 KILL ^TMP("PXRHM",$JOB)
- +11 QUIT
- +12 ;
- NEWACTIV(ORY) ;Return true if Interactive Reminders are active
- +1 SET ORY=0
- +2 IF $TEXT(APPL^PXRMRPCA)'=""
- IF +$GET(DUZ)
- Begin DoDot:1
- +3 NEW SRV
- +4 SET SRV=$$GET1^DIQ(200,DUZ,29,"I")
- +5 SET ORY=$$GET^XPAR(DUZ_";VA(200,^SRV.`"_+$GET(SRV)_"^DIV^SYS","PXRM GUI REMINDERS ACTIVE",1,"Q")
- +6 IF +ORY
- SET ORY=1
- +7 IF '$TEST
- SET ORY=0
- End DoDot:1
- +8 QUIT
- +9 ;
- HISTLOC(LST) ;Returns a list of historical locations
- +1 NEW IDX,PTR,LINE,NAME
- +2 KILL ^TMP("OR",$JOB,"LOC")
- +3 SET LST=$NAME(^TMP("OR",$JOB,"LOC"))
- +4 SET (LINE,IDX)=0
- +5 FOR
- SET IDX=$ORDER(^AUTTLOC(IDX))
- if 'IDX
- QUIT
- Begin DoDot:1
- +6 SET PTR=+$GET(^AUTTLOC(IDX,0))
- +7 IF +PTR
- Begin DoDot:2
- +8 SET NAME=$$GET1^DIQ(4,PTR,.01,"I")
- +9 IF NAME'=""
- Begin DoDot:3
- +10 SET LINE=LINE+1
- +11 SET ^TMP("OR",$JOB,"LOC",LINE)=PTR_U_NAME
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +12 QUIT
- +13 ;
- GETFLDRS(ORFLDRS) ;Return Visible Reminder Folders
- +1 ; Codes: D=Due, A=Applicable, N=Not Applicable, E=Evaluated, O=Other
- +2 NEW SRV,ORERR,ORTMP
- +3 SET SRV=$$GET1^DIQ(200,DUZ,29,"I")
- +4 DO GETLST^XPAR(.ORTMP,"USR^SRV.`"_+$GET(SRV)_"^DIV^SYS^PKG","ORQQPX REMINDER FOLDERS","Q",.ORERR)
- +5 IF +ORTMP
- SET ORFLDRS=$PIECE($GET(ORTMP(1)),U,2)
- +6 IF '$TEST
- SET ORFLDRS="DAO"
- +7 QUIT
- +8 ;
- SETFLDRS(ORY,ORFLDRS) ;Sets Visible Reminder Folders for the current user
- +1 NEW ORERR
- +2 DO EN^XPAR(DUZ_";VA(200,","ORQQPX REMINDER FOLDERS",1,ORFLDRS,.ORERR)
- +3 SET ORY=1
- +4 QUIT
- +5 ;
- GETDEFOL(ORDEFLOC) ;Return Default Outside Locations
- +1 NEW SRV,ORERR
- +2 SET SRV=$$GET1^DIQ(200,DUZ,29,"I")
- +3 DO GETLST^XPAR(.ORDEFLOC,"USR^SRV.`"_+$GET(SRV)_"^DIV^SYS^PKG","ORQQPX DEFAULT LOCATIONS","Q",.ORERR)
- +4 QUIT
- +5 ;
- INSCURS(ORY) ; Returns status of ORQQPX REMINDER TEXT AT CURSOR
- +1 NEW SRV,ORERR,ORTMP
- +2 SET ORY=0
- SET SRV=$$GET1^DIQ(200,DUZ,29,"I")
- +3 DO GETLST^XPAR(.ORTMP,"USR^SRV.`"_+$GET(SRV)_"^DIV^SYS^PKG","ORQQPX REMINDER TEXT AT CURSOR","Q",.ORERR)
- +4 IF +ORTMP
- SET ORY=$PIECE($GET(ORTMP(1)),U,2)
- +5 QUIT
- +6 ;
- NEWCVOK(ORY) ; Returns status of
- +1 NEW SRV,ORERR,ORTMP
- +2 SET ORY=0
- SET SRV=$$GET1^DIQ(200,DUZ,29,"I")
- +3 DO GETLST^XPAR(.ORTMP,"USR^SRV.`"_+$GET(SRV)_"^DIV^SYS^PKG","ORQQPX NEW REMINDER PARAMS","Q",.ORERR)
- +4 IF +ORTMP
- SET ORY=$PIECE($GET(ORTMP(1)),U,2)
- +5 QUIT
- +6 ;
- ADDNAME(ORX) ; Add Reminder or Category Name as 3rd piece
- +1 NEW CAT,IEN
- +2 SET CAT=$EXTRACT($PIECE(ORX,U,2),2)
- +3 SET IEN=$EXTRACT($PIECE(ORX,U,2),3,99)
- +4 IF +IEN
- Begin DoDot:1
- +5 IF CAT="R"
- SET $PIECE(ORX,U,3)=$PIECE($GET(^PXD(811.9,IEN,0)),U,3)
- +6 IF CAT="C"
- SET $PIECE(ORX,U,3)=$PIECE($GET(^PXRMD(811.7,IEN,0)),U)
- End DoDot:1
- +7 QUIT ORX
- +8 ;
- REMACCUM(ORY,LVL,TYP,SORT,CLASS) ; Accumulates ORTMP into ORY
- +1 ; Format of entries in ORQQPX COVER SHEET REMINDERS:
- +2 ; L:Lock;R:Remove;N:Normal / C:Category;R:Reminder / Cat or Rem IEN
- +3 NEW IDX,I,J,K,M,FOUND,ORERR,ORTMP,FLAG,IEN
- +4 NEW FFLAG,FIEN,OUT,P2,ADD,DOADD,CODE
- +5 IF LVL="CLASS"
- Begin DoDot:1
- +6 NEW ORLST,ORCLS,ORCLSPRM,ORWP
- +7 SET ORCLSPRM="ORQQPX COVER SHEET REM CLASSES"
- +8 DO GETLST^XPAR(.ORLST,"SYS",ORCLSPRM,"Q",.ORERR)
- +9 SET I=0
- SET M=0
- SET CLASS=$GET(CLASS)
- +10 FOR
- SET I=$ORDER(ORLST(I))
- if 'I
- QUIT
- Begin DoDot:2
- +11 SET ORCLS=$PIECE(ORLST(I),U,1)
- +12 IF +CLASS
- SET ADD=(ORCLS=+CLASS)
- IF 1
- +13 IF '$TEST
- SET ADD=$$ISA^USRLM(DUZ,ORCLS,.ORERR)
- +14 IF +ADD
- Begin DoDot:3
- +15 DO GETWP^XPAR(.ORWP,"SYS",ORCLSPRM,ORCLS,.ORERR)
- +16 SET K=0
- +17 FOR
- SET K=$ORDER(ORWP(K))
- if 'K
- QUIT
- Begin DoDot:4
- +18 SET M=M+1
- +19 SET J=$PIECE(ORWP(K,0),";",1)
- +20 SET ORTMP(M)=J_U_$PIECE(ORWP(K,0),";",2)
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- IF 1
- +21 IF '$TEST
- DO GETLST^XPAR(.ORTMP,LVL,"ORQQPX COVER SHEET REMINDERS",TYP,.ORERR)
- +22 SET I=0
- SET IDX=$ORDER(ORY(999999),-1)+1
- SET ADD=(SORT="")
- +23 FOR
- SET I=$ORDER(ORTMP(I))
- if 'I
- QUIT
- Begin DoDot:1
- +24 SET (FOUND,J)=0
- SET P2=$PIECE(ORTMP(I),U,2)
- +25 SET FLAG=$EXTRACT(P2)
- SET IEN=$EXTRACT(P2,2,999)
- +26 IF ADD
- SET DOADD=1
- +27 IF '$TEST
- Begin DoDot:2
- +28 SET DOADD=0
- +29 FOR
- SET J=$ORDER(ORY(J))
- if 'J
- QUIT
- Begin DoDot:3
- +30 SET P2=$PIECE(ORY(J),U,2)
- +31 SET FIEN=$EXTRACT(P2,2,999)
- +32 IF FIEN=IEN
- SET FOUND=J
- SET FFLAG=$EXTRACT(P2)
- End DoDot:3
- if FOUND
- QUIT
- +33 IF FOUND
- Begin DoDot:3
- +34 IF FLAG="R"
- IF FFLAG'="L"
- KILL ORY(FOUND)
- +35 IF FLAG'=FFLAG
- IF (FLAG_FFLAG)["L"
- SET $EXTRACT(P2)="L"
- SET $PIECE(ORY(FOUND),U,2)=P2
- End DoDot:3
- IF 1
- +36 IF '$TEST
- IF (FLAG'="R")
- SET DOADD=1
- End DoDot:2
- +37 IF DOADD
- Begin DoDot:2
- +38 SET OUT(IDX)=ORTMP(I)
- +39 SET $PIECE(OUT(IDX),U)=$PIECE(OUT(IDX),U)_SORT
- +40 IF SORT=""
- SET OUT(IDX)=$$ADDNAME(OUT(IDX))
- +41 SET IDX=IDX+1
- End DoDot:2
- End DoDot:1
- +42 MERGE ORY=OUT
- +43 QUIT
- +44 ;
- ADDREM(ORY,IDX,IEN) ; Add Reminder to ORY list
- +1 ; See if it's in the list
- IF $DATA(ORY("B",IEN))
- QUIT
- +2 ; Check if Exists
- IF '$DATA(^PXD(811.9,IEN))
- QUIT
- +3 ; Check if Active
- IF $PIECE($GET(^PXD(811.9,IEN,0)),U,6)'=""
- QUIT
- +4 ;Check to see if the reminder is assigned to CPRS
- +5 NEW USAGE
- +6 SET USAGE=$PIECE($GET(^PXD(811.9,IEN,100)),U,4)
- +7 ;If the Usage is List or Order Check skip it.
- +8 IF (USAGE["L")!(USAGE["O")
- QUIT
- +9 ;If the Usage is not C or * skip it.
- +10 IF USAGE'["C"
- IF USAGE'="*"
- QUIT
- +11 SET ORY(IDX)=IDX_U_IEN
- +12 SET ORY("B",IEN)=""
- +13 QUIT
- +14 ;
- ADDCAT(ORY,IDX,IEN) ; Add Category Reminders to ORY list
- +1 NEW ORREM,I,IDX2,NREM
- +2 DO CATREM^PXRMAPI0(IEN,.ORREM)
- +3 SET I=0
- +4 FOR
- SET I=$ORDER(ORREM(I))
- if 'I
- QUIT
- Begin DoDot:1
- +5 SET IDX2="00000"_I
- +6 SET IDX2=$EXTRACT(IDX2,$LENGTH(IDX2)-5,99)
- +7 DO ADDREM(.ORY,+(IDX_"."_IDX2),$PIECE(ORREM(I),U,1))
- End DoDot:1
- +8 QUIT
- +9 ;
- REMLIST(ORY,LOC) ;Returns a list of all cover sheet reminders
- +1 NEW SRV,I,J,ORLST,CODE,IDX,IEN,NEWP
- +2 SET SRV=$$GET1^DIQ(200,DUZ,29,"I")
- +3 DO NEWCVOK(.NEWP)
- +4 IF 'NEWP
- Begin DoDot:1
- +5 NEW OLDLIST,RESULT
- +6 DO GETLST^XPAR(.OLDLIST,"USR^LOC.`"_$GET(LOC)_"^SRV.`"_+$GET(SRV)_"^DIV^SYS^PKG","ORQQPX SEARCH ITEMS","Q",.ORERR)
- QUIT
- +7 SET I=0
- +8 FOR
- SET I=$ORDER(OLDLIST(I))
- if 'I
- QUIT
- Begin DoDot:2
- +9 SET IDX=$PIECE(OLDLIST(I),U,1)
- +10 FOR
- if '$DATA(RESULT(IDX))
- QUIT
- SET IDX=IDX+1
- +11 SET IEN=$PIECE(OLDLIST(I),U,2)
- +12 DO ADDREM(.RESULT,IDX,IEN)
- End DoDot:2
- +13 KILL RESULT("B")
- End DoDot:1
- QUIT
- +14 ;
- +15 DO REMACCUM(.ORLST,"PKG","Q",1000)
- +16 DO REMACCUM(.ORLST,"SYS","Q",2000)
- +17 DO REMACCUM(.ORLST,"DIV","Q",3000)
- +18 IF +SRV
- DO REMACCUM(.ORLST,"SRV.`"_+$GET(SRV),"Q",4000)
- +19 IF +LOC
- DO REMACCUM(.ORLST,"LOC.`"_+$GET(LOC),"Q",5000)
- +20 DO REMACCUM(.ORLST,"CLASS","Q",6000)
- +21 DO REMACCUM(.ORLST,"USR","Q",7000)
- +22 SET I=0
- +23 FOR
- SET I=$ORDER(ORLST(I))
- if 'I
- QUIT
- Begin DoDot:1
- +24 SET IDX=$PIECE(ORLST(I),U,1)
- +25 FOR
- if '$DATA(ORY(IDX))
- QUIT
- SET IDX=IDX+1
- +26 SET CODE=$EXTRACT($PIECE(ORLST(I),U,2),2)
- +27 SET IEN=$EXTRACT($PIECE(ORLST(I),U,2),3,999)
- +28 IF CODE="R"
- DO ADDREM(.ORY,IDX,IEN)
- +29 IF CODE="C"
- DO ADDCAT(.ORY,IDX,IEN)
- End DoDot:1
- +30 KILL ORY("B")
- +31 QUIT
- +32 ;
- LVREMLST(ORY,LVL,CLASS) ;Returns cover sheet reminders at a specified level
- +1 DO REMACCUM(.ORY,LVL,"Q","",$GET(CLASS))
- +2 QUIT
- +3 ;
- SAVELVL(ORY,LVL,CLASS,DATA) ;Save cover sheet reminders at a specified level
- +1 NEW ORERR,PARAM,I
- +2 IF LVL="CLASS"
- Begin DoDot:1
- +3 SET PARAM="ORQQPX COVER SHEET REM CLASSES"
- +4 SET LVL="SYS"
- +5 DO DEL^XPAR(LVL,PARAM,"`"_CLASS,.ORERR)
- +6 DO EN^XPAR(LVL,PARAM,"`"_CLASS,.DATA,.ORERR)
- End DoDot:1
- IF 1
- +7 IF '$TEST
- Begin DoDot:1
- +8 SET PARAM="ORQQPX COVER SHEET REMINDERS"
- +9 DO NDEL^XPAR(LVL,PARAM,.ORERR)
- +10 SET I=0
- +11 FOR
- SET I=$ORDER(DATA(I))
- if 'I
- QUIT
- Begin DoDot:2
- +12 DO EN^XPAR(LVL,PARAM,$PIECE(DATA(I),U,1),$PIECE(DATA(I),U,2),.ORERR)
- End DoDot:2
- End DoDot:1
- +13 SET ORY=1
- +14 QUIT
- +15 ;
- GETLIST(ORY,ORLOC) ;Returns a list of all cover sheet reminders
- +1 NEW I
- +2 DO REMLIST(.ORY,$GET(ORLOC))
- +3 SET I=0
- +4 FOR
- SET I=$ORDER(ORY(I))
- if 'I
- QUIT
- Begin DoDot:1
- +5 SET ORY(I)=$PIECE(ORY(I),U,2)
- End DoDot:1
- +6 QUIT
- +7 ;
- EVALCOVR(ORY,ORPT,ORLOC) ; Evaluate Cover Sheet Reminders
- +1 NEW ORTMP
- +2 DO GETLIST(.ORTMP,$GET(ORLOC))
- +3 DO ALIST^ORQQPXRM(.ORY,ORPT,.ORTMP)
- +4 QUIT
- +5 ;