PXRMEUT1.m

PXRMEUT1 ; SLC/PKR - General extract utilities ;07/14/2009

 ;;2.0;CLINICAL REMINDERS;**4,6,12**;Feb 04, 2005;Build 73

 ;=================================================

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 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")

 . 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")

 . 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

 ;

PXRMEUT1  ; SLC/PKR - General extract utilities ;07/14/2009

 +1       ;;2.0;CLINICAL REMINDERS;**4,6,12**;Feb 04, 2005;Build 73

 +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 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")

                       End DoDot:2

 +26               IF $PIECE(TEMP,U,2)'=EDT

                       Begin DoDot:2

 +27                       SET DERROR=1

 +28                       SET NL=NL+1

                           SET OUTPUT(NL)="  There is a consistency problem with the ending date!"

 +29                       SET NL=NL+1

                           SET OUTPUT(NL)="  Date used to build the list was: "_$$FMTE^XLFDT($PIECE(TEMP,U,2),"5Z")

                       End DoDot:2

 +30               IF DERROR

                       Begin DoDot:2

 +31                       SET NL=NL+1

                           SET OUTPUT(NL)="  Please notify the developers."

 +32      ;S NL=NL+1,OUTPUT(NL)="  Please enter a Remedy ticket."

 +33                       SET NL=NL+1

                           SET OUTPUT(NL)=" "

                       End DoDot:2

               End DoDot:1

 +34       QUIT 

 +35      ;

 +36      ;=================================================

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       ;