ORLPREM ;ISP/LMT,AGP - CPRS Team List from a Reminder Patient List ;Apr 21, 2021@22:16:19
;;3.0;ORDER ENTRY/RESULTS REPORTING;**377,498**;Dec 17, 1997;Build 38
;
;
ENTASK ;
;
; ZEXCEPT: ZTREQ
;
N ORLISTDUE,ORLSTMAP,ORREM
;
S ZTREQ="@"
;
D GETDUE(.ORLISTDUE)
;
S ORREM=0
F S ORREM=$O(ORLISTDUE(ORREM)) Q:'ORREM D
. M ORLSTMAP=ORLISTDUE(ORREM)
. D EN(ORREM,.ORLSTMAP)
;
Q
;
ENONE ;
;
; ZEXCEPT: ORLSTMAP,ORREM,ZTREQ
S ZTREQ="@"
;
D EN(ORREM,.ORLSTMAP)
Q
;
EN(ORREM,ORLSTMAP) ;
;
N DFN,ORCNT,ORDIV,ORERR,ORFDA,ORIENS,ORLST,OROVER,ORPL,ORREMNM,ORSCRBYDIV,ORX
;
S ORSCRBYDIV=0
S ORREMNM=$P($G(^PXRM(810.4,+ORREM,0)),U,1)
I ORREMNM="" Q
;
I $O(ORLSTMAP("SYS"),-1) S ORSCRBYDIV=1
;
; Get Reminder Patient List
S OROVER=$$GETOVER^ORLPREML(ORREM)
D GETRMLST^ORBSMART(.ORPL,ORREMNM,OROVER,0)
;
; Set FDA array to populate 100.21
S ORCNT=0
S DFN=0
F S DFN=$O(ORPL(DFN)) Q:'DFN D
. S ORCNT=ORCNT+1
. I 'ORSCRBYDIV D
. . S ORLST=$G(ORLSTMAP("SYS"))
. . I 'ORLST Q
. . S ORIENS="+"_ORCNT_","_ORLST_","
. . S ORFDA(ORLST,100.2101,ORIENS,.01)=DFN_";DPT("
. I ORSCRBYDIV D
. . S ORDIV=$$GETDIV(DFN)
. . I ORDIV,$G(ORLSTMAP(ORDIV)) D
. . . S ORLST=ORLSTMAP(ORDIV)
. . . S ORIENS="+"_ORCNT_","_ORLST_","
. . . S ORFDA(ORLST,100.2101,ORIENS,.01)=DFN_";DPT("
. . I $G(ORLSTMAP("SYS")),'ORDIV D
. . . S ORLST=ORLSTMAP("SYS")
. . . S ORIENS="+"_ORCNT_","_ORLST_","
. . . S ORFDA(ORLST,100.2101,ORIENS,.01)=DFN_";DPT("
;
S ORX=""
F S ORX=$O(ORLSTMAP(ORX)) Q:ORX="" D
. S ORLST=$G(ORLSTMAP(ORX))
. I 'ORLST Q
. D CLEAN^DILF
. ;
. L +^OR(100.21,ORLST):999
. D PRGLST(ORLST)
. ; p498 - in case there were no members on the list before and no members were added, force set 12.1
. S ORFDA(ORLST,100.21,ORLST_",",12.1)=$$NOW^XLFDT
. S ORFDA(ORLST,100.21,ORLST_",",12.2)=ORREM_";PXRM(810.4,"
. D UPDATE^DIE("","ORFDA("_ORLST_")")
. L -^OR(100.21,ORLST)
. ;
. I $D(^TMP("DIERR",$J)) D
. . D MSG^DIALOG("AE",.ORERR)
. . D SENDMSG("Error while filing patients to 100.21",.ORERR,ORREMNM,$P($G(^OR(100.21,ORLST,0)),U,1))
;
D CLEAN^DILF
;
D EN^XPAR("SYS","ORLP TEAM LIST FROM REM LAST","`"_ORREM,$$NOW^XLFDT)
;
Q
;
PRGLST(ORLST) ; Clear existing list of patients
;
N DA,DIK,ORMEM
;
S ORMEM=0
F S ORMEM=$O(^OR(100.21,ORLST,10,ORMEM)) Q:'ORMEM D
. S DA=ORMEM
. S DA(1)=ORLST
. S DIK="^OR(100.21,"_DA(1)_",10,"
. D ^DIK
;
Q
;
GETDIV(DFN) ;
;
N ORDIV,ORDIVS,ORPCP,ORX
;
S ORDIV=""
;
; PCP Institution
S ORPCP=+$$OUTPTPR^SDUTL3(DFN)
I ORPCP D
. S ORX=$$DIV4^XUSER(.ORDIVS,ORPCP)
. I 'ORX S ORDIV=$$KSP^XUPARAM("INST")
. I ORX D
. . S ORDIV=$O(ORDIVS(0))
. . I $O(ORDIVS(ORDIV)) S ORDIV="" ;PCP assigned more than one DIV
;
I ORDIV Q ORDIV
;
; Team's Institution
S ORDIV=$P($$INSTPCTM^SCAPMC(DFN),U,3)
I ORDIV Q ORDIV
;
; Preferred Facility
S ORDIV=$$PREF^DGENPTA(DFN)
;
Q ORDIV
;
SENDMSG(ORERR,ORERRARR,ORREM,ORLST) ;
;
; ZEXCEPT: XQY0,ZTSK
N ORCNT,ORI,ORINSTR,ORLST,ORREM,ORSUB,ORTO
K ^TMP("ORMSG",$J)
;
S ORCNT=0
S ORCNT=ORCNT+1,^TMP("ORMSG",$J,ORCNT)="There was an issue while updating the CPRS Team List from a"
S ORCNT=ORCNT+1,^TMP("ORMSG",$J,ORCNT)="Reminder Patient List."
S ORCNT=ORCNT+1,^TMP("ORMSG",$J,ORCNT)=" "
S ORCNT=ORCNT+1,^TMP("ORMSG",$J,ORCNT)="Task ID: "_$G(ZTSK)
S ORCNT=ORCNT+1,^TMP("ORMSG",$J,ORCNT)="Option: "_$P($G(XQY0),U,2)
S ORCNT=ORCNT+1,^TMP("ORMSG",$J,ORCNT)="Error: "_$G(ORERR)
S ORCNT=ORCNT+1,^TMP("ORMSG",$J,ORCNT)="Reminder Patient List: "_$G(ORREM)
S ORCNT=ORCNT+1,^TMP("ORMSG",$J,ORCNT)="OE/RR List: "_$G(ORLST)
;
I $D(ORERRARR) D
. S ORCNT=ORCNT+1,^TMP("ORMSG",$J,ORCNT)=" "
. S ORCNT=ORCNT+1,^TMP("ORMSG",$J,ORCNT)="Error Details:"
. S ORI=0
. F S ORI=$O(ORERRARR(ORI)) Q:'ORI D
. . S ORCNT=ORCNT+1,^TMP("ORMSG",$J,ORCNT)=$G(ORERRARR(ORI))
;
S ORSUB="Error Updating CPRS Team List"
S ORTO(DUZ)=""
S ORTO("G.OR CACS")=""
S ORINSTR("FROM")="CPRS TASKED JOB"
S ORINSTR("ADDR FLAGS")="R"
D SENDMSG^XMXAPI(DUZ,ORSUB,"^TMP(""ORMSG"",$J)",.ORTO,.ORINSTR,.ORMSGNUM)
;
Q
;
GETDUE(ORLISTDUE) ;
;
N ORFREQ,ORLASTRUN,ORNEXTRUN,ORREM
;
K ^TMP("ORLPREM",$J)
;
D GETAPARS^ORLPREML("I")
S ORREM=0
F S ORREM=$O(^TMP("ORLPREM",$J,ORREM)) Q:'ORREM D
. S ORLASTRUN=$$GETLAST^ORLPREML(ORREM)
. S ORFREQ=$$GETFREQ^ORLPREML(ORREM)
. ;
. I 'ORFREQ Q
. I 'ORLASTRUN D Q
. . M ORLISTDUE(ORREM)=^TMP("ORLPREM",$J,ORREM)
. ;
. S ORNEXTRUN=$$FMADD^XLFDT($P(ORLASTRUN,".",1),ORFREQ)
. I ORNEXTRUN=DT!(ORNEXTRUN<DT) D
. . M ORLISTDUE(ORREM)=^TMP("ORLPREM",$J,ORREM)
;
K ^TMP("ORLPREM",$J)
;
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORLPREM 4732 printed Sep 23, 2025@20:07:53 Page 2
ORLPREM ;ISP/LMT,AGP - CPRS Team List from a Reminder Patient List ;Apr 21, 2021@22:16:19
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**377,498**;Dec 17, 1997;Build 38
+2 ;
+3 ;
ENTASK ;
+1 ;
+2 ; ZEXCEPT: ZTREQ
+3 ;
+4 NEW ORLISTDUE,ORLSTMAP,ORREM
+5 ;
+6 SET ZTREQ="@"
+7 ;
+8 DO GETDUE(.ORLISTDUE)
+9 ;
+10 SET ORREM=0
+11 FOR
SET ORREM=$ORDER(ORLISTDUE(ORREM))
if 'ORREM
QUIT
Begin DoDot:1
+12 MERGE ORLSTMAP=ORLISTDUE(ORREM)
+13 DO EN(ORREM,.ORLSTMAP)
End DoDot:1
+14 ;
+15 QUIT
+16 ;
ENONE ;
+1 ;
+2 ; ZEXCEPT: ORLSTMAP,ORREM,ZTREQ
+3 SET ZTREQ="@"
+4 ;
+5 DO EN(ORREM,.ORLSTMAP)
+6 QUIT
+7 ;
EN(ORREM,ORLSTMAP) ;
+1 ;
+2 NEW DFN,ORCNT,ORDIV,ORERR,ORFDA,ORIENS,ORLST,OROVER,ORPL,ORREMNM,ORSCRBYDIV,ORX
+3 ;
+4 SET ORSCRBYDIV=0
+5 SET ORREMNM=$PIECE($GET(^PXRM(810.4,+ORREM,0)),U,1)
+6 IF ORREMNM=""
QUIT
+7 ;
+8 IF $ORDER(ORLSTMAP("SYS"),-1)
SET ORSCRBYDIV=1
+9 ;
+10 ; Get Reminder Patient List
+11 SET OROVER=$$GETOVER^ORLPREML(ORREM)
+12 DO GETRMLST^ORBSMART(.ORPL,ORREMNM,OROVER,0)
+13 ;
+14 ; Set FDA array to populate 100.21
+15 SET ORCNT=0
+16 SET DFN=0
+17 FOR
SET DFN=$ORDER(ORPL(DFN))
if 'DFN
QUIT
Begin DoDot:1
+18 SET ORCNT=ORCNT+1
+19 IF 'ORSCRBYDIV
Begin DoDot:2
+20 SET ORLST=$GET(ORLSTMAP("SYS"))
+21 IF 'ORLST
QUIT
+22 SET ORIENS="+"_ORCNT_","_ORLST_","
+23 SET ORFDA(ORLST,100.2101,ORIENS,.01)=DFN_";DPT("
End DoDot:2
+24 IF ORSCRBYDIV
Begin DoDot:2
+25 SET ORDIV=$$GETDIV(DFN)
+26 IF ORDIV
IF $GET(ORLSTMAP(ORDIV))
Begin DoDot:3
+27 SET ORLST=ORLSTMAP(ORDIV)
+28 SET ORIENS="+"_ORCNT_","_ORLST_","
+29 SET ORFDA(ORLST,100.2101,ORIENS,.01)=DFN_";DPT("
End DoDot:3
+30 IF $GET(ORLSTMAP("SYS"))
IF 'ORDIV
Begin DoDot:3
+31 SET ORLST=ORLSTMAP("SYS")
+32 SET ORIENS="+"_ORCNT_","_ORLST_","
+33 SET ORFDA(ORLST,100.2101,ORIENS,.01)=DFN_";DPT("
End DoDot:3
End DoDot:2
End DoDot:1
+34 ;
+35 SET ORX=""
+36 FOR
SET ORX=$ORDER(ORLSTMAP(ORX))
if ORX=""
QUIT
Begin DoDot:1
+37 SET ORLST=$GET(ORLSTMAP(ORX))
+38 IF 'ORLST
QUIT
+39 DO CLEAN^DILF
+40 ;
+41 LOCK +^OR(100.21,ORLST):999
+42 DO PRGLST(ORLST)
+43 ; p498 - in case there were no members on the list before and no members were added, force set 12.1
+44 SET ORFDA(ORLST,100.21,ORLST_",",12.1)=$$NOW^XLFDT
+45 SET ORFDA(ORLST,100.21,ORLST_",",12.2)=ORREM_";PXRM(810.4,"
+46 DO UPDATE^DIE("","ORFDA("_ORLST_")")
+47 LOCK -^OR(100.21,ORLST)
+48 ;
+49 IF $DATA(^TMP("DIERR",$JOB))
Begin DoDot:2
+50 DO MSG^DIALOG("AE",.ORERR)
+51 DO SENDMSG("Error while filing patients to 100.21",.ORERR,ORREMNM,$PIECE($GET(^OR(100.21,ORLST,0)),U,1))
End DoDot:2
End DoDot:1
+52 ;
+53 DO CLEAN^DILF
+54 ;
+55 DO EN^XPAR("SYS","ORLP TEAM LIST FROM REM LAST","`"_ORREM,$$NOW^XLFDT)
+56 ;
+57 QUIT
+58 ;
PRGLST(ORLST) ; Clear existing list of patients
+1 ;
+2 NEW DA,DIK,ORMEM
+3 ;
+4 SET ORMEM=0
+5 FOR
SET ORMEM=$ORDER(^OR(100.21,ORLST,10,ORMEM))
if 'ORMEM
QUIT
Begin DoDot:1
+6 SET DA=ORMEM
+7 SET DA(1)=ORLST
+8 SET DIK="^OR(100.21,"_DA(1)_",10,"
+9 DO ^DIK
End DoDot:1
+10 ;
+11 QUIT
+12 ;
GETDIV(DFN) ;
+1 ;
+2 NEW ORDIV,ORDIVS,ORPCP,ORX
+3 ;
+4 SET ORDIV=""
+5 ;
+6 ; PCP Institution
+7 SET ORPCP=+$$OUTPTPR^SDUTL3(DFN)
+8 IF ORPCP
Begin DoDot:1
+9 SET ORX=$$DIV4^XUSER(.ORDIVS,ORPCP)
+10 IF 'ORX
SET ORDIV=$$KSP^XUPARAM("INST")
+11 IF ORX
Begin DoDot:2
+12 SET ORDIV=$ORDER(ORDIVS(0))
+13 ;PCP assigned more than one DIV
IF $ORDER(ORDIVS(ORDIV))
SET ORDIV=""
End DoDot:2
End DoDot:1
+14 ;
+15 IF ORDIV
QUIT ORDIV
+16 ;
+17 ; Team's Institution
+18 SET ORDIV=$PIECE($$INSTPCTM^SCAPMC(DFN),U,3)
+19 IF ORDIV
QUIT ORDIV
+20 ;
+21 ; Preferred Facility
+22 SET ORDIV=$$PREF^DGENPTA(DFN)
+23 ;
+24 QUIT ORDIV
+25 ;
SENDMSG(ORERR,ORERRARR,ORREM,ORLST) ;
+1 ;
+2 ; ZEXCEPT: XQY0,ZTSK
+3 NEW ORCNT,ORI,ORINSTR,ORLST,ORREM,ORSUB,ORTO
+4 KILL ^TMP("ORMSG",$JOB)
+5 ;
+6 SET ORCNT=0
+7 SET ORCNT=ORCNT+1
SET ^TMP("ORMSG",$JOB,ORCNT)="There was an issue while updating the CPRS Team List from a"
+8 SET ORCNT=ORCNT+1
SET ^TMP("ORMSG",$JOB,ORCNT)="Reminder Patient List."
+9 SET ORCNT=ORCNT+1
SET ^TMP("ORMSG",$JOB,ORCNT)=" "
+10 SET ORCNT=ORCNT+1
SET ^TMP("ORMSG",$JOB,ORCNT)="Task ID: "_$GET(ZTSK)
+11 SET ORCNT=ORCNT+1
SET ^TMP("ORMSG",$JOB,ORCNT)="Option: "_$PIECE($GET(XQY0),U,2)
+12 SET ORCNT=ORCNT+1
SET ^TMP("ORMSG",$JOB,ORCNT)="Error: "_$GET(ORERR)
+13 SET ORCNT=ORCNT+1
SET ^TMP("ORMSG",$JOB,ORCNT)="Reminder Patient List: "_$GET(ORREM)
+14 SET ORCNT=ORCNT+1
SET ^TMP("ORMSG",$JOB,ORCNT)="OE/RR List: "_$GET(ORLST)
+15 ;
+16 IF $DATA(ORERRARR)
Begin DoDot:1
+17 SET ORCNT=ORCNT+1
SET ^TMP("ORMSG",$JOB,ORCNT)=" "
+18 SET ORCNT=ORCNT+1
SET ^TMP("ORMSG",$JOB,ORCNT)="Error Details:"
+19 SET ORI=0
+20 FOR
SET ORI=$ORDER(ORERRARR(ORI))
if 'ORI
QUIT
Begin DoDot:2
+21 SET ORCNT=ORCNT+1
SET ^TMP("ORMSG",$JOB,ORCNT)=$GET(ORERRARR(ORI))
End DoDot:2
End DoDot:1
+22 ;
+23 SET ORSUB="Error Updating CPRS Team List"
+24 SET ORTO(DUZ)=""
+25 SET ORTO("G.OR CACS")=""
+26 SET ORINSTR("FROM")="CPRS TASKED JOB"
+27 SET ORINSTR("ADDR FLAGS")="R"
+28 DO SENDMSG^XMXAPI(DUZ,ORSUB,"^TMP(""ORMSG"",$J)",.ORTO,.ORINSTR,.ORMSGNUM)
+29 ;
+30 QUIT
+31 ;
GETDUE(ORLISTDUE) ;
+1 ;
+2 NEW ORFREQ,ORLASTRUN,ORNEXTRUN,ORREM
+3 ;
+4 KILL ^TMP("ORLPREM",$JOB)
+5 ;
+6 DO GETAPARS^ORLPREML("I")
+7 SET ORREM=0
+8 FOR
SET ORREM=$ORDER(^TMP("ORLPREM",$JOB,ORREM))
if 'ORREM
QUIT
Begin DoDot:1
+9 SET ORLASTRUN=$$GETLAST^ORLPREML(ORREM)
+10 SET ORFREQ=$$GETFREQ^ORLPREML(ORREM)
+11 ;
+12 IF 'ORFREQ
QUIT
+13 IF 'ORLASTRUN
Begin DoDot:2
+14 MERGE ORLISTDUE(ORREM)=^TMP("ORLPREM",$JOB,ORREM)
End DoDot:2
QUIT
+15 ;
+16 SET ORNEXTRUN=$$FMADD^XLFDT($PIECE(ORLASTRUN,".",1),ORFREQ)
+17 IF ORNEXTRUN=DT!(ORNEXTRUN<DT)
Begin DoDot:2
+18 MERGE ORLISTDUE(ORREM)=^TMP("ORLPREM",$JOB,ORREM)
End DoDot:2
End DoDot:1
+19 ;
+20 KILL ^TMP("ORLPREM",$JOB)
+21 ;
+22 QUIT
+23 ;
