PXRMEUT1 ; SLC/PKR - General extract utilities ;09/01/2021
;;2.0;CLINICAL REMINDERS;**4,6,12,65**;Feb 04, 2005;Build 438
;=================================================
CLDATES ;Cleanup entries in ^TMP("PXRMDDOC",$J) before making date checks.
;For drug findings consolidate PS(55, PS(55NVA, and PSRX( back to
;PSDRUG(.
N FI,FIND0,ITEM,GLOBAL,LIST
S FIND0=""
F S FIND0=$O(^TMP("PXRMDDOC",$J,FIND0)) Q:FIND0="" D
. S FI=$P(FIND0,U,1)
. S GLOBAL=$P(FI,";",2)
. I GLOBAL'["PS" Q
. S GLOBAL="PSDRUG("
. S ITEM=$P(FI,";",1)
. S FI=ITEM_";"_GLOBAL_U_$P(FIND0,U,2,11)
. S LIST(FIND0)=FI
;
S FIND0=""
F S FIND0=$O(LIST(FIND0)) Q:FIND0="" D
. S FI=LIST(FIND0)
. S ^TMP("PXRMDDOC",$J,FI)=^TMP("PXRMDDOC",$J,FIND0)
. K ^TMP("PXRMDDOC",$J,FIND0)
Q
;
;=================================================
DAYSIM(FMDATE) ;Given a FileMan date return the number of days in the month.
N DAYS,MONTH
S MONTH=$E(FMDATE,4,5)
S DAYS=$S(MONTH="01":31,MONTH="02":28,MONTH="03":31,MONTH="04":30,MONTH="05":31,MONTH="06":30,MONTH="07":31,MONTH="08":31,MONTH="09":30,MONTH="10":31,MONTH="11":30,MONTH="12":31,1:"")
I MONTH="02" D
. N LYEAR,YEAR
. S YEAR=$E(FMDATE,1,3)+1700
. S LYEAR=$S((YEAR#4=0)&(YEAR#100'=0):1,YEAR#400=0:1,1:0)
. I LYEAR S DAYS=29
Q DAYS
;
;=================================================
DCONV(DATE,LBBDT,LBEDT) ;Convert dates to actual values.
I DATE=0 Q DATE
N PXRMDATE
S PXRMDATE=$S(DATE["BDT":LBBDT,1:LBEDT)
S DATE=$$STRREP^PXRMUTIL(DATE,"BDT","T")
Q $$CTFMD^PXRMDATE(DATE)
;
;=================================================
DOCDATES(RULESET,LBBDT,LBEDT,NL,OUTPUT) ;
N EM,FRACT,FRDATA,FRDATES,FRIEN,FRLST,FRLIEN,FROLST,FROUT,FRPAT
N FRPERM,FRSTRT,FRTIEN,FRTYP,FSEQ,OPER,PXRMFVPL
N RRIEN,RSDATA,RSDATES,RBDT,REDT,SEQ,SUB
I $G(PXRMDDOC)=2 D CLDATES
;Build the variable pointer list.
D BLDRLIST^PXRMVPTR(811.902,.01,.PXRMFVPL)
S SEQ="",NL=0
F S SEQ=$O(^PXRM(810.4,RULESET,30,"B",SEQ)) Q:'SEQ D
. S SUB=$O(^PXRM(810.4,RULESET,30,"B",SEQ,"")) Q:'SUB
. S RSDATA=$G(^PXRM(810.4,RULESET,30,SUB,0)) Q:RSDATA=""
. S OPER=$P(RSDATA,U,3)
. S OPER=$$EXTERNAL^DILFD(810.41,.03,"",OPER,.EM)
. S RSDATES=$G(^PXRM(810.4,RULESET,30,SUB,1))
.;Finding rule ien.
. S FRIEN=$P(RSDATA,U,2) Q:'FRIEN
.;Check if entry is a finding rule (not a set or reminder rule)
. S FRDATA=$G(^PXRM(810.4,FRIEN,0)),FRTYP=$P(FRDATA,U,3) Q:FRTYP=3
. S FRDATES=$P(FRDATA,U,4,5)
.;Get term IEN for finding rule
. I FRTYP=1 S FRTIEN=$P(FRDATA,U,7) Q:'FRTIEN
.;Get Reminder definition IEN for Reminder rule
. I FRTYP=2 S RRIEN=$P(FRDATA,U,10) Q:'RRIEN
.;Determine RBDT and REDT
. D RDATES(RSDATES,FRDATES,LBBDT,LBEDT,.RBDT,.REDT)
. S NL=NL+1,OUTPUT(NL)=""
. S NL=NL+1,OUTPUT(NL)="SEQUENCE "_SEQ_" "_$P(FRDATA,U,1)
. S NL=NL+1,OUTPUT(NL)=" Operation: "_OPER
.;Term finding rules
. I FRTYP=1 D TERM(FRTIEN,LBBDT,LBEDT,RBDT,REDT,.PXRMFVPL,.NL,.OUTPUT)
.;Reminder Definition List Rule
. I FRTYP=2 D REM(RRIEN,LBBDT,LBEDT,RBDT,REDT,.PXRMFVPL,.NL,.OUTPUT)
Q
;
;=================================================
FMULPRT(FARR,PXRMFVPL,NL,OUTPUT) ;Print the finding multiple
;information.
N BDT,EDT,DERROR,FNAME,FTYPE,IND,LC,NOCC,NOUT
N TBDT,TEDT,TEMP,TEXTIN,TEXTOUT,VPTR
S IND=0
F S IND=+$O(FARR(20,IND)) Q:IND=0 D
. S VPTR=$P(FARR(20,IND,0),U,1)
. S FNAME=$$ENTRYNAM^PXRMPTD2(VPTR)
. S FTYPE=$$FTYPE^PXRMPTD2(VPTR,1)
. S TEXTIN="FINDING "_IND_"-"_FTYPE_"."_FNAME
. D FORMATS^PXRMTEXT(3,78,TEXTIN,.NOUT,.TEXTOUT)
. F LC=1:1:NOUT S NL=NL+1,OUTPUT(NL)=TEXTOUT(LC)
.;Set the finding parameters.
. D SSPAR^PXRMUTIL(FARR(20,IND,0),.NOCC,.BDT,.EDT)
. S NL=NL+1,OUTPUT(NL)=" Beginning Date/Time: "_$$FMTE^XLFDT(BDT,"5Z")
. S NL=NL+1,OUTPUT(NL)=" Ending Date/Time: "_$$FMTE^XLFDT(EDT,"5Z")
. I $G(PXRMDDOC)'=2 Q
. S DERROR=0
. S TEMP=$G(^TMP("PXRMDDOC",$J,$P(FARR(20,IND,0),U,1,11)))
.;If TEMP is null then no evaluation was required and the check
.;cannot be made
. I TEMP="" Q
. I $P(TEMP,U,1)'=BDT D
.. S DERROR=1
.. S NL=NL+1,OUTPUT(NL)=" There is a consistency problem with the beginning date!"
.. S NL=NL+1,OUTPUT(NL)=" Date used to build the list was: "_$$FMTE^XLFDT($P(TEMP,U,1),"5Z")
.. S NL=NL+1,OUTPUT(NL)=" BDT for the list was: "_$$FMTE^XLFDT(BDT,"5Z")
. I $P(TEMP,U,2)'=EDT D
.. S DERROR=1
.. S NL=NL+1,OUTPUT(NL)=" There is a consistency problem with the ending date!"
.. S NL=NL+1,OUTPUT(NL)=" Date used to build the list was: "_$$FMTE^XLFDT($P(TEMP,U,2),"5Z")
.. S NL=NL+1,OUTPUT(NL)=" EDT for the list was: "_$$FMTE^XLFDT(EDT,"5Z")
. I DERROR D
.. S NL=NL+1,OUTPUT(NL)=" Please notify the developers."
.. ;S NL=NL+1,OUTPUT(NL)=" Please enter a Remedy ticket."
.. S NL=NL+1,OUTPUT(NL)=" "
Q
;
;=================================================
RDATES(RSDATES,FRDATES,LBBDT,LBEDT,RBDT,REDT) ;Determine the beginning and
;ending dates.
;Date precedence: LIST BUILD < RULE SET < FINDING RULE < TERM/REMINDER
S RBDT=$P(FRDATES,U,1),REDT=$P(FRDATES,U,2)
I RBDT="",REDT="" S RBDT=$P(RSDATES,U,1),REDT=$P(RSDATES,U,2)
I RBDT="",REDT="" S RBDT=LBBDT,REDT=LBEDT
I RBDT="" S RBDT=0
I REDT="" S REDT=LBEDT
I REDT=0 S REDT=DT
;Convert RBDT and REDT to FileMan dates.
S RBDT=$$DCONV(RBDT,LBBDT,LBEDT)
S REDT=$$DCONV(REDT,LBBDT,LBEDT)
;If the month is missing use January for the beginning date and
;December for the ending date.
I $E(RBDT,4,5)="00" S RBDT=$E(RBDT,1,3)_"01"_$E(RBDT,6,7)
I $E(REDT,4,5)="00" S REDT=$E(REDT,1,3)_"12"_$E(REDT,6,7)
;If the day is missing use the first for beginning date and the end
;of the month for ending date.
I $E(RBDT,6,7)="00" S RBDT=$E(RBDT,1,5)_"01"
I $E(REDT,6,7)="00" S REDT=$E(REDT,1,5)_$$DAYSIM(REDT)
Q
;
;=================================================
REM(IEN,LBBDT,LBEDT,RBDT,REDT,PXRMFVPL,NL,OUTPUT) ;
N DEFARR
D DEF^PXRMLDR(IEN,.DEFARR)
D DATES^PXRMRUL1(LBBDT,LBEDT,RBDT,REDT,.DEFARR)
S NL=NL+1,OUTPUT(NL)=" REMINDER DEFINITION "_$P(DEFARR(0),U,1)
D FMULPRT(.DEFARR,.PXRMFVPL,.NL,.OUTPUT)
Q
;
;=================================================
TERM(IEN,LBBDT,LBEDT,RBDT,REDT,PXRMFVPL,NL,OUTPUT) ;
N TERMARR
D TERM^PXRMLDR(IEN,.TERMARR)
D DATES^PXRMRUL1(LBBDT,LBEDT,RBDT,REDT,.TERMARR)
S NL=NL+1,OUTPUT(NL)=" TERM "_$P(TERMARR(0),U,1)
D FMULPRT(.TERMARR,.PXRMFVPL,.NL,.OUTPUT)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMEUT1 6410 printed Apr 09, 2024@20:48:42 Page 2
PXRMEUT1 ; SLC/PKR - General extract utilities ;09/01/2021
+1 ;;2.0;CLINICAL REMINDERS;**4,6,12,65**;Feb 04, 2005;Build 438
+2 ;=================================================
CLDATES ;Cleanup entries in ^TMP("PXRMDDOC",$J) before making date checks.
+1 ;For drug findings consolidate PS(55, PS(55NVA, and PSRX( back to
+2 ;PSDRUG(.
+3 NEW FI,FIND0,ITEM,GLOBAL,LIST
+4 SET FIND0=""
+5 FOR
SET FIND0=$ORDER(^TMP("PXRMDDOC",$JOB,FIND0))
if FIND0=""
QUIT
Begin DoDot:1
+6 SET FI=$PIECE(FIND0,U,1)
+7 SET GLOBAL=$PIECE(FI,";",2)
+8 IF GLOBAL'["PS"
QUIT
+9 SET GLOBAL="PSDRUG("
+10 SET ITEM=$PIECE(FI,";",1)
+11 SET FI=ITEM_";"_GLOBAL_U_$PIECE(FIND0,U,2,11)
+12 SET LIST(FIND0)=FI
End DoDot:1
+13 ;
+14 SET FIND0=""
+15 FOR
SET FIND0=$ORDER(LIST(FIND0))
if FIND0=""
QUIT
Begin DoDot:1
+16 SET FI=LIST(FIND0)
+17 SET ^TMP("PXRMDDOC",$JOB,FI)=^TMP("PXRMDDOC",$JOB,FIND0)
+18 KILL ^TMP("PXRMDDOC",$JOB,FIND0)
End DoDot:1
+19 QUIT
+20 ;
+21 ;=================================================
DAYSIM(FMDATE) ;Given a FileMan date return the number of days in the month.
+1 NEW DAYS,MONTH
+2 SET MONTH=$EXTRACT(FMDATE,4,5)
+3 SET DAYS=$SELECT(MONTH="01":31,MONTH="02":28,MONTH="03":31,MONTH="04":30,MONTH="05":31,MONTH="06":30,MONTH="07":31,MONTH="08":31,MONTH="09":30,MONTH="10":31,MONTH="11":30,MONTH="12":31,1:"")
+4 IF MONTH="02"
Begin DoDot:1
+5 NEW LYEAR,YEAR
+6 SET YEAR=$EXTRACT(FMDATE,1,3)+1700
+7 SET LYEAR=$SELECT((YEAR#4=0)&(YEAR#100'=0):1,YEAR#400=0:1,1:0)
+8 IF LYEAR
SET DAYS=29
End DoDot:1
+9 QUIT DAYS
+10 ;
+11 ;=================================================
DCONV(DATE,LBBDT,LBEDT) ;Convert dates to actual values.
+1 IF DATE=0
QUIT DATE
+2 NEW PXRMDATE
+3 SET PXRMDATE=$SELECT(DATE["BDT":LBBDT,1:LBEDT)
+4 SET DATE=$$STRREP^PXRMUTIL(DATE,"BDT","T")
+5 QUIT $$CTFMD^PXRMDATE(DATE)
+6 ;
+7 ;=================================================
DOCDATES(RULESET,LBBDT,LBEDT,NL,OUTPUT) ;
+1 NEW EM,FRACT,FRDATA,FRDATES,FRIEN,FRLST,FRLIEN,FROLST,FROUT,FRPAT
+2 NEW FRPERM,FRSTRT,FRTIEN,FRTYP,FSEQ,OPER,PXRMFVPL
+3 NEW RRIEN,RSDATA,RSDATES,RBDT,REDT,SEQ,SUB
+4 IF $GET(PXRMDDOC)=2
DO CLDATES
+5 ;Build the variable pointer list.
+6 DO BLDRLIST^PXRMVPTR(811.902,.01,.PXRMFVPL)
+7 SET SEQ=""
SET NL=0
+8 FOR
SET SEQ=$ORDER(^PXRM(810.4,RULESET,30,"B",SEQ))
if 'SEQ
QUIT
Begin DoDot:1
+9 SET SUB=$ORDER(^PXRM(810.4,RULESET,30,"B",SEQ,""))
if 'SUB
QUIT
+10 SET RSDATA=$GET(^PXRM(810.4,RULESET,30,SUB,0))
if RSDATA=""
QUIT
+11 SET OPER=$PIECE(RSDATA,U,3)
+12 SET OPER=$$EXTERNAL^DILFD(810.41,.03,"",OPER,.EM)
+13 SET RSDATES=$GET(^PXRM(810.4,RULESET,30,SUB,1))
+14 ;Finding rule ien.
+15 SET FRIEN=$PIECE(RSDATA,U,2)
if 'FRIEN
QUIT
+16 ;Check if entry is a finding rule (not a set or reminder rule)
+17 SET FRDATA=$GET(^PXRM(810.4,FRIEN,0))
SET FRTYP=$PIECE(FRDATA,U,3)
if FRTYP=3
QUIT
+18 SET FRDATES=$PIECE(FRDATA,U,4,5)
+19 ;Get term IEN for finding rule
+20 IF FRTYP=1
SET FRTIEN=$PIECE(FRDATA,U,7)
if 'FRTIEN
QUIT
+21 ;Get Reminder definition IEN for Reminder rule
+22 IF FRTYP=2
SET RRIEN=$PIECE(FRDATA,U,10)
if 'RRIEN
QUIT
+23 ;Determine RBDT and REDT
+24 DO RDATES(RSDATES,FRDATES,LBBDT,LBEDT,.RBDT,.REDT)
+25 SET NL=NL+1
SET OUTPUT(NL)=""
+26 SET NL=NL+1
SET OUTPUT(NL)="SEQUENCE "_SEQ_" "_$PIECE(FRDATA,U,1)
+27 SET NL=NL+1
SET OUTPUT(NL)=" Operation: "_OPER
+28 ;Term finding rules
+29 IF FRTYP=1
DO TERM(FRTIEN,LBBDT,LBEDT,RBDT,REDT,.PXRMFVPL,.NL,.OUTPUT)
+30 ;Reminder Definition List Rule
+31 IF FRTYP=2
DO REM(RRIEN,LBBDT,LBEDT,RBDT,REDT,.PXRMFVPL,.NL,.OUTPUT)
End DoDot:1
+32 QUIT
+33 ;
+34 ;=================================================
FMULPRT(FARR,PXRMFVPL,NL,OUTPUT) ;Print the finding multiple
+1 ;information.
+2 NEW BDT,EDT,DERROR,FNAME,FTYPE,IND,LC,NOCC,NOUT
+3 NEW TBDT,TEDT,TEMP,TEXTIN,TEXTOUT,VPTR
+4 SET IND=0
+5 FOR
SET IND=+$ORDER(FARR(20,IND))
if IND=0
QUIT
Begin DoDot:1
+6 SET VPTR=$PIECE(FARR(20,IND,0),U,1)
+7 SET FNAME=$$ENTRYNAM^PXRMPTD2(VPTR)
+8 SET FTYPE=$$FTYPE^PXRMPTD2(VPTR,1)
+9 SET TEXTIN="FINDING "_IND_"-"_FTYPE_"."_FNAME
+10 DO FORMATS^PXRMTEXT(3,78,TEXTIN,.NOUT,.TEXTOUT)
+11 FOR LC=1:1:NOUT
SET NL=NL+1
SET OUTPUT(NL)=TEXTOUT(LC)
+12 ;Set the finding parameters.
+13 DO SSPAR^PXRMUTIL(FARR(20,IND,0),.NOCC,.BDT,.EDT)
+14 SET NL=NL+1
SET OUTPUT(NL)=" Beginning Date/Time: "_$$FMTE^XLFDT(BDT,"5Z")
+15 SET NL=NL+1
SET OUTPUT(NL)=" Ending Date/Time: "_$$FMTE^XLFDT(EDT,"5Z")
+16 IF $GET(PXRMDDOC)'=2
QUIT
+17 SET DERROR=0
+18 SET TEMP=$GET(^TMP("PXRMDDOC",$JOB,$PIECE(FARR(20,IND,0),U,1,11)))
+19 ;If TEMP is null then no evaluation was required and the check
+20 ;cannot be made
+21 IF TEMP=""
QUIT
+22 IF $PIECE(TEMP,U,1)'=BDT
Begin DoDot:2
+23 SET DERROR=1
+24 SET NL=NL+1
SET OUTPUT(NL)=" There is a consistency problem with the beginning date!"
+25 SET NL=NL+1
SET OUTPUT(NL)=" Date used to build the list was: "_$$FMTE^XLFDT($PIECE(TEMP,U,1),"5Z")
+26 SET NL=NL+1
SET OUTPUT(NL)=" BDT for the list was: "_$$FMTE^XLFDT(BDT,"5Z")
End DoDot:2
+27 IF $PIECE(TEMP,U,2)'=EDT
Begin DoDot:2
+28 SET DERROR=1
+29 SET NL=NL+1
SET OUTPUT(NL)=" There is a consistency problem with the ending date!"
+30 SET NL=NL+1
SET OUTPUT(NL)=" Date used to build the list was: "_$$FMTE^XLFDT($PIECE(TEMP,U,2),"5Z")
+31 SET NL=NL+1
SET OUTPUT(NL)=" EDT for the list was: "_$$FMTE^XLFDT(EDT,"5Z")
End DoDot:2
+32 IF DERROR
Begin DoDot:2
+33 SET NL=NL+1
SET OUTPUT(NL)=" Please notify the developers."
+34 ;S NL=NL+1,OUTPUT(NL)=" Please enter a Remedy ticket."
+35 SET NL=NL+1
SET OUTPUT(NL)=" "
End DoDot:2
End DoDot:1
+36 QUIT
+37 ;
+38 ;=================================================
RDATES(RSDATES,FRDATES,LBBDT,LBEDT,RBDT,REDT) ;Determine the beginning and
+1 ;ending dates.
+2 ;Date precedence: LIST BUILD < RULE SET < FINDING RULE < TERM/REMINDER
+3 SET RBDT=$PIECE(FRDATES,U,1)
SET REDT=$PIECE(FRDATES,U,2)
+4 IF RBDT=""
IF REDT=""
SET RBDT=$PIECE(RSDATES,U,1)
SET REDT=$PIECE(RSDATES,U,2)
+5 IF RBDT=""
IF REDT=""
SET RBDT=LBBDT
SET REDT=LBEDT
+6 IF RBDT=""
SET RBDT=0
+7 IF REDT=""
SET REDT=LBEDT
+8 IF REDT=0
SET REDT=DT
+9 ;Convert RBDT and REDT to FileMan dates.
+10 SET RBDT=$$DCONV(RBDT,LBBDT,LBEDT)
+11 SET REDT=$$DCONV(REDT,LBBDT,LBEDT)
+12 ;If the month is missing use January for the beginning date and
+13 ;December for the ending date.
+14 IF $EXTRACT(RBDT,4,5)="00"
SET RBDT=$EXTRACT(RBDT,1,3)_"01"_$EXTRACT(RBDT,6,7)
+15 IF $EXTRACT(REDT,4,5)="00"
SET REDT=$EXTRACT(REDT,1,3)_"12"_$EXTRACT(REDT,6,7)
+16 ;If the day is missing use the first for beginning date and the end
+17 ;of the month for ending date.
+18 IF $EXTRACT(RBDT,6,7)="00"
SET RBDT=$EXTRACT(RBDT,1,5)_"01"
+19 IF $EXTRACT(REDT,6,7)="00"
SET REDT=$EXTRACT(REDT,1,5)_$$DAYSIM(REDT)
+20 QUIT
+21 ;
+22 ;=================================================
REM(IEN,LBBDT,LBEDT,RBDT,REDT,PXRMFVPL,NL,OUTPUT) ;
+1 NEW DEFARR
+2 DO DEF^PXRMLDR(IEN,.DEFARR)
+3 DO DATES^PXRMRUL1(LBBDT,LBEDT,RBDT,REDT,.DEFARR)
+4 SET NL=NL+1
SET OUTPUT(NL)=" REMINDER DEFINITION "_$PIECE(DEFARR(0),U,1)
+5 DO FMULPRT(.DEFARR,.PXRMFVPL,.NL,.OUTPUT)
+6 QUIT
+7 ;
+8 ;=================================================
TERM(IEN,LBBDT,LBEDT,RBDT,REDT,PXRMFVPL,NL,OUTPUT) ;
+1 NEW TERMARR
+2 DO TERM^PXRMLDR(IEN,.TERMARR)
+3 DO DATES^PXRMRUL1(LBBDT,LBEDT,RBDT,REDT,.TERMARR)
+4 SET NL=NL+1
SET OUTPUT(NL)=" TERM "_$PIECE(TERMARR(0),U,1)
+5 DO FMULPRT(.TERMARR,.PXRMFVPL,.NL,.OUTPUT)
+6 QUIT
+7 ;
