- RORXU003 ;HCIOFO/BH,SG - REPORT BUILDER UTILITIES ; 7/19/06 12:34pm
- ;;1.5;CLINICAL CASE REGISTRIES;**1**;Feb 17, 2006;Build 24
- ;
- ; This routine uses the following IAs:
- ;
- ; #1894 ENCEVENT^PXKENC (controlled)
- ;
- Q
- ;
- ;***** SEARCHES FOR UTLIZATION
- ;
- ; STDT Start date for search (FileMan)
- ; ENDT End date for search (FileMan)
- ;
- ; RORDFN Patient IEN in the PATIENT file (#2)
- ;
- ; CHK Reference to a local array that identifies the
- ; packages files that need to be checked i.e. CHK("O"):
- ; A Allergy
- ; C Cytopathology
- ; I Inpatients
- ; IP Inpatient Pharmacy
- ; IV IV Medications
- ; L Laboratory
- ; M Microbiology
- ; O Outpatient
- ; OP Outpatient Pharmacy
- ; R Radiology
- ; SP Surgical Pathology
- ;
- ; If set to "ALL", Outpatients, Inpatients, Radiology,
- ; Allergy, Pharmacy, Microbiology, Surgical Pathology,
- ; Cytopathology, and Lab data will be checked.
- ;
- ; Return Values:
- ; 0 No utilization has been found
- ; 1 The patient has had utilization. The subsequent "^"-pieces
- ; will indicate the utilization areas (the same codes as
- ; those for the CHK parameter)
- ;
- ; For example, if a patient had utilization for Inpatients,
- ; Outpatient, Pharmacy, and Lab the string would look as
- ; follows: 1^O^I^OP^L
- ;
- UTIL(STDT,ENDT,RORDFN,CHK) ;
- N IEN,LRDFN,RES,RORMSG,RORVAL
- S RORVAL=""
- ;
- ;--- Outpatient data
- I $D(CHK("ALL"))!$D(CHK("O")) D
- . S RES=$$OUTPAT(STDT,ENDT,RORDFN)
- . S:RES RORVAL=RORVAL_U_$P(RES,U,2,999)
- ;
- ;--- Inpatient data
- I $D(CHK("ALL"))!$D(CHK("I")) D
- . S RES=$$INPAT(STDT,ENDT,RORDFN)
- . S:RES RORVAL=RORVAL_U_$P(RES,U,2,999)
- ;
- ;--- Radiology data
- I $D(CHK("ALL"))!$D(CHK("R")) D
- . S RES=$$RAD(STDT,ENDT,RORDFN)
- . S:RES RORVAL=RORVAL_U_$P(RES,U,2,999)
- ;
- ;--- Allergy data
- I $D(CHK("ALL"))!$D(CHK("A")) D
- . S RES=$$ALLERGY(STDT,ENDT,RORDFN)
- . S:RES RORVAL=RORVAL_U_$P(RES,U,2,999)
- ;
- ;--- Pharmacy data
- I $D(CHK("ALL"))!$D(CHK("IP"))!$D(CHK("OP"))!$D(CHK("IV")) D
- . S RES=$$PHARM(STDT,ENDT,RORDFN,.CHK)
- . S:RES RORVAL=RORVAL_U_$P(RES,U,2,999)
- ;
- S LRDFN=+$$LABREF^RORUTL18(RORDFN)
- ;
- I LRDFN>0 D
- . ;--- Microbiology
- . I $D(CHK("ALL"))!$D(CHK("M")) D
- . . S RES=$$MICRO(STDT,ENDT,LRDFN)
- . . S:RES RORVAL=RORVAL_U_$P(RES,U,2,999)
- . ;--- Surgical Pathology
- . I $D(CHK("ALL"))!$D(CHK("SP")) D
- . . S RES=$$SURGP(STDT,ENDT,LRDFN)
- . . S:RES RORVAL=RORVAL_U_$P(RES,U,2,999)
- . ;--- Cytopathology
- . I $D(CHK("ALL"))!$D(CHK("C")) D
- . . S RES=$$CYTO(STDT,ENDT,LRDFN)
- . . S:RES RORVAL=RORVAL_U_$P(RES,U,2,999)
- ;
- ;--- Lab data
- I $D(CHK("ALL"))!$D(CHK("L")) D
- . S RES=$$LAB(STDT,ENDT,RORDFN)
- . S:RES RORVAL=RORVAL_U_$P(RES,U,2,999)
- ;
- S $P(RORVAL,U)=(RORVAL'="")
- Q RORVAL
- ;
- ;***** CHECKS ALLERGY DATA
- ALLERGY(STDT,ENDT,RORDFN) ;
- N DTE,IEN,RC
- S RC=0
- S DTE=$O(^GMR(120.8,"AODT",STDT),-1)
- S ENDT=ENDT_".999999"
- F S DTE=$O(^GMR(120.8,"AODT",DTE)) Q:'DTE!(DTE'<ENDT) D Q:RC
- . S IEN=0
- . F S IEN=$O(^GMR(120.8,"AODT",DTE,IEN)) Q:'IEN D Q:RC
- . . S:$D(^GMR(120.8,"B",RORDFN,IEN)) RC="1^A"
- Q RC
- ;
- ;***** CHECKS CYTOPATHOLOGY DATA
- CYTO(STDT,ENDT,LRDFN) ;
- N IDT
- S IDT=$O(^LR(LRDFN,"CY",9999999-STDT))
- S IDT=$O(^LR(LRDFN,"CY",IDT),-1)
- Q $S(IDT&(IDT>(9999999-ENDT)):"1^C",1:0)
- ;
- ;***** CHECKS INPATIENT DATA
- INPAT(STDT,ENDT,DFN) ;
- N ADMDT,DATE,DISDT,IEN,QUIT,RC,VAIP
- S STDT=STDT\1
- ;--- Check for an admission date inside the time frame
- S QUIT=0,DATE=(ENDT\1)_".999999"
- F S DATE=$O(^DGPT("AAD",DFN,DATE),-1) Q:'DATE!(DATE<STDT) D Q:QUIT
- . S IEN=""
- . F S IEN=$O(^DGPT("AAD",DFN,DATE,IEN),-1) Q:'IEN D Q:QUIT
- . . S:'$$PTF^RORXU001(IEN,"FP") QUIT=1
- Q:QUIT=1 "1^I"
- ;--- Check for an earlier admission that overlaps the date range
- S QUIT=0,VAIP("D")=STDT
- F D Q:QUIT
- . D IN5^VADPT
- . S VAIP("D")=+$G(VAIP(13,1))
- . I VAIP("D")'>0 S QUIT=2 Q
- . S VAIP("D")=$$FMADD^XLFDT(VAIP("D"),,,,-1)
- . S IEN=+$G(VAIP(12)) Q:IEN'>0
- . S RC=$$PTF^RORXU001(IEN,"FP",,.DISDT)
- . S QUIT=$S(RC:0,$G(DISDT)'>0:1,DISDT>STDT:1,1:2)
- Q $S(QUIT=1:"1^I",1:0)
- ;
- ;***** CHECKS LAB DATA
- LAB(STDT,ENDT,RORDFN) ;
- N PTID,RC,RORMSG,RORTMP
- S PTID=$$PTID^RORUTL02(RORDFN) Q:PTID<0 0
- S RORTMP=$$ALLOC^RORTMP()
- ;--- Get the Lab data
- S ENDT=(ENDT\1+1)_"^CD",STDT=STDT_"^CD"
- S RC=$$GCPR^LA7QRY(PTID,STDT,ENDT,"CH","*",.RORMSG,RORTMP)
- S RC=$S(($D(RORMSG)>1)&(RC=""):0,$D(@RORTMP)>1:"1^L",1:0)
- ;--- Cleanup
- D FREE^RORTMP(RORTMP)
- Q RC
- ;
- ;***** CHECKS MICROBIOLOGY DATA
- MICRO(STDT,ENDT,LRDFN) ;
- N RC,RORTMP
- S RC=0,RORTMP=$$ALLOC^RORTMP()
- D:$$GETDATA^LA7UTL1A(LRDFN,STDT,ENDT,"CD",RORTMP)'<0
- . S:$D(@RORTMP@(LRDFN)) RC="1^M"
- D FREE^RORTMP(RORTMP)
- Q RC
- ;
- ;***** CHECKS OUTPATIENT DATA
- OUTPAT(STDT,ENDT,RORDFN) ;
- S STDT=$P(STDT,".",1),STDT=STDT-1,STDT=STDT+.9999
- S ENDT=$P(ENDT,".",1),ENDT=ENDT+1
- N QUERY,RORDST,RORECNT
- S RORECNT=0
- S RORDST=$NA(^TMP("RORXU003",$J,"OUT"))
- D OPEN^SDQ(.QUERY)
- D INDEX^SDQ(.QUERY,"PATIENT/DATE","SET")
- D PAT^SDQ(.QUERY,RORDFN,"SET")
- D DATE^SDQ(.QUERY,STDT,ENDT,"SET")
- D SCANCB^SDQ(.QUERY,"D SCAN^RORXU003()","SET")
- D ACTIVE^SDQ(.QUERY,"TRUE","SET")
- D SCAN^SDQ(.QUERY,"FORWARD")
- D CLOSE^SDQ(.QUERY)
- Q $S(RORECNT:"1^O",1:0)
- ;
- ;***** CHECKS PHARMACY DATA
- PHARM(STDT,ENDT,RORDFN,CHK) ;
- N BUF,II,IP,IV,OP,ORD,RC,RORLST,SKIP,TMP,TYPE
- S ENDT=$$FMADD^XLFDT(ENDT\1,1)
- I '$D(CHK("ALL")) D
- . S IP='$D(CHK("IP"))
- . S IV='$D(CHK("IV"))
- . S OP='$D(CHK("OP"))
- E S (OP,IP,IV)=0
- ;=== Get the list of orders
- K ^TMP("PS",$J)
- D OCL^PSOORRL(RORDFN,STDT,ENDT)
- Q:$D(^TMP("PS",$J))<10 0
- S RORLST=$$ALLOC^RORTMP()
- ;=== Preselect the orders
- S II=0
- F S II=$O(^TMP("PS",$J,II)) Q:'II D
- . S BUF=$G(^TMP("PS",$J,II,0)),ORD=$P(BUF,U) Q:ORD'>0
- . S TMP=$L(ORD),TYPE=$E(ORD,TMP-2,TMP)
- . S TYPE=$S(TYPE="R;O":"R",TYPE="U;I":"U",TYPE="V;I":"V",1:"")
- . ;--- Check if this kind of orders should be processed
- . Q:$S(TYPE="R":OP,TYPE="U":IP,TYPE="V":IV,1:1)
- . ;--- Check the dates
- . I "UV"[TYPE S TMP=$P(BUF,U,15) Q:(TMP<STDT)!(TMP'<ENDT)
- . I TYPE="R" S TMP=$P(BUF,U,10) Q:TMP<STDT
- . ;--- Add the order to the list
- . S @RORLST@(II)=TYPE,@RORLST@(II,0)=BUF
- ;=== Process the preselected orders
- S II=0,RC=""
- F S II=$O(@RORLST@(II)) Q:'II D Q:OP&IP&IV
- . S TYPE=@RORLST@(II),ORD=$P(@RORLST@(II,0),U)
- . ;--- Outpatient
- . I TYPE="R" Q:OP D S:'SKIP OP=1,RC=RC_U_"OP" Q
- . . ;--- Double-check the Rx date(s)
- . . K ^TMP("PS",$J)
- . . D OEL^PSOORRL(RORDFN,ORD)
- . . I $D(^TMP("PS",$J))<10 S SKIP=1 Q
- . . S SKIP=$$DTCHECK^RORUTL15(STDT,ENDT)
- . ;--- Inpatient
- . I TYPE="U" Q:IP S IP=1,RC=RC_U_"IP" Q
- . ;--- IV
- . I TYPE="V" Q:IV S IV=1,RC=RC_U_"IV" Q
- ;===
- D FREE^RORTMP(RORLST)
- K ^TMP("PS",$J)
- S $P(RC,U)=(RC'="")
- Q RC
- ;
- ;***** CHECKS RADIOLOGY DATA
- RAD(STDT,ENDT,RORDFN) ;
- N RC
- K ^TMP($J,"RAE1")
- D EN1^RAO7PC1(RORDFN,STDT,ENDT,999999999)
- S RC=$S($D(^TMP($J,"RAE1",RORDFN))>1:"1^R",1:0)
- K ^TMP($J,"RAE1")
- Q RC
- ;
- ;*****
- SCAN() ;
- S RORECNT=1
- Q
- ;
- ;***** CHECKS SURGICAL PATHOLOGY DATA
- SURGP(STDT,ENDT,LRDFN) ;
- N IDT
- S IDT=$O(^LR(LRDFN,"SP",9999999-STDT))
- S IDT=$O(^LR(LRDFN,"SP",IDT),-1)
- Q $S(IDT&(IDT>(9999999-ENDT)):"1^SP",1:0)
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRORXU003 7581 printed Feb 18, 2025@23:11:29 Page 2
- RORXU003 ;HCIOFO/BH,SG - REPORT BUILDER UTILITIES ; 7/19/06 12:34pm
- +1 ;;1.5;CLINICAL CASE REGISTRIES;**1**;Feb 17, 2006;Build 24
- +2 ;
- +3 ; This routine uses the following IAs:
- +4 ;
- +5 ; #1894 ENCEVENT^PXKENC (controlled)
- +6 ;
- +7 QUIT
- +8 ;
- +9 ;***** SEARCHES FOR UTLIZATION
- +10 ;
- +11 ; STDT Start date for search (FileMan)
- +12 ; ENDT End date for search (FileMan)
- +13 ;
- +14 ; RORDFN Patient IEN in the PATIENT file (#2)
- +15 ;
- +16 ; CHK Reference to a local array that identifies the
- +17 ; packages files that need to be checked i.e. CHK("O"):
- +18 ; A Allergy
- +19 ; C Cytopathology
- +20 ; I Inpatients
- +21 ; IP Inpatient Pharmacy
- +22 ; IV IV Medications
- +23 ; L Laboratory
- +24 ; M Microbiology
- +25 ; O Outpatient
- +26 ; OP Outpatient Pharmacy
- +27 ; R Radiology
- +28 ; SP Surgical Pathology
- +29 ;
- +30 ; If set to "ALL", Outpatients, Inpatients, Radiology,
- +31 ; Allergy, Pharmacy, Microbiology, Surgical Pathology,
- +32 ; Cytopathology, and Lab data will be checked.
- +33 ;
- +34 ; Return Values:
- +35 ; 0 No utilization has been found
- +36 ; 1 The patient has had utilization. The subsequent "^"-pieces
- +37 ; will indicate the utilization areas (the same codes as
- +38 ; those for the CHK parameter)
- +39 ;
- +40 ; For example, if a patient had utilization for Inpatients,
- +41 ; Outpatient, Pharmacy, and Lab the string would look as
- +42 ; follows: 1^O^I^OP^L
- +43 ;
- UTIL(STDT,ENDT,RORDFN,CHK) ;
- +1 NEW IEN,LRDFN,RES,RORMSG,RORVAL
- +2 SET RORVAL=""
- +3 ;
- +4 ;--- Outpatient data
- +5 IF $DATA(CHK("ALL"))!$DATA(CHK("O"))
- Begin DoDot:1
- +6 SET RES=$$OUTPAT(STDT,ENDT,RORDFN)
- +7 if RES
- SET RORVAL=RORVAL_U_$PIECE(RES,U,2,999)
- End DoDot:1
- +8 ;
- +9 ;--- Inpatient data
- +10 IF $DATA(CHK("ALL"))!$DATA(CHK("I"))
- Begin DoDot:1
- +11 SET RES=$$INPAT(STDT,ENDT,RORDFN)
- +12 if RES
- SET RORVAL=RORVAL_U_$PIECE(RES,U,2,999)
- End DoDot:1
- +13 ;
- +14 ;--- Radiology data
- +15 IF $DATA(CHK("ALL"))!$DATA(CHK("R"))
- Begin DoDot:1
- +16 SET RES=$$RAD(STDT,ENDT,RORDFN)
- +17 if RES
- SET RORVAL=RORVAL_U_$PIECE(RES,U,2,999)
- End DoDot:1
- +18 ;
- +19 ;--- Allergy data
- +20 IF $DATA(CHK("ALL"))!$DATA(CHK("A"))
- Begin DoDot:1
- +21 SET RES=$$ALLERGY(STDT,ENDT,RORDFN)
- +22 if RES
- SET RORVAL=RORVAL_U_$PIECE(RES,U,2,999)
- End DoDot:1
- +23 ;
- +24 ;--- Pharmacy data
- +25 IF $DATA(CHK("ALL"))!$DATA(CHK("IP"))!$DATA(CHK("OP"))!$DATA(CHK("IV"))
- Begin DoDot:1
- +26 SET RES=$$PHARM(STDT,ENDT,RORDFN,.CHK)
- +27 if RES
- SET RORVAL=RORVAL_U_$PIECE(RES,U,2,999)
- End DoDot:1
- +28 ;
- +29 SET LRDFN=+$$LABREF^RORUTL18(RORDFN)
- +30 ;
- +31 IF LRDFN>0
- Begin DoDot:1
- +32 ;--- Microbiology
- +33 IF $DATA(CHK("ALL"))!$DATA(CHK("M"))
- Begin DoDot:2
- +34 SET RES=$$MICRO(STDT,ENDT,LRDFN)
- +35 if RES
- SET RORVAL=RORVAL_U_$PIECE(RES,U,2,999)
- End DoDot:2
- +36 ;--- Surgical Pathology
- +37 IF $DATA(CHK("ALL"))!$DATA(CHK("SP"))
- Begin DoDot:2
- +38 SET RES=$$SURGP(STDT,ENDT,LRDFN)
- +39 if RES
- SET RORVAL=RORVAL_U_$PIECE(RES,U,2,999)
- End DoDot:2
- +40 ;--- Cytopathology
- +41 IF $DATA(CHK("ALL"))!$DATA(CHK("C"))
- Begin DoDot:2
- +42 SET RES=$$CYTO(STDT,ENDT,LRDFN)
- +43 if RES
- SET RORVAL=RORVAL_U_$PIECE(RES,U,2,999)
- End DoDot:2
- End DoDot:1
- +44 ;
- +45 ;--- Lab data
- +46 IF $DATA(CHK("ALL"))!$DATA(CHK("L"))
- Begin DoDot:1
- +47 SET RES=$$LAB(STDT,ENDT,RORDFN)
- +48 if RES
- SET RORVAL=RORVAL_U_$PIECE(RES,U,2,999)
- End DoDot:1
- +49 ;
- +50 SET $PIECE(RORVAL,U)=(RORVAL'="")
- +51 QUIT RORVAL
- +52 ;
- +53 ;***** CHECKS ALLERGY DATA
- ALLERGY(STDT,ENDT,RORDFN) ;
- +1 NEW DTE,IEN,RC
- +2 SET RC=0
- +3 SET DTE=$ORDER(^GMR(120.8,"AODT",STDT),-1)
- +4 SET ENDT=ENDT_".999999"
- +5 FOR
- SET DTE=$ORDER(^GMR(120.8,"AODT",DTE))
- if 'DTE!(DTE'<ENDT)
- QUIT
- Begin DoDot:1
- +6 SET IEN=0
- +7 FOR
- SET IEN=$ORDER(^GMR(120.8,"AODT",DTE,IEN))
- if 'IEN
- QUIT
- Begin DoDot:2
- +8 if $DATA(^GMR(120.8,"B",RORDFN,IEN))
- SET RC="1^A"
- End DoDot:2
- if RC
- QUIT
- End DoDot:1
- if RC
- QUIT
- +9 QUIT RC
- +10 ;
- +11 ;***** CHECKS CYTOPATHOLOGY DATA
- CYTO(STDT,ENDT,LRDFN) ;
- +1 NEW IDT
- +2 SET IDT=$ORDER(^LR(LRDFN,"CY",9999999-STDT))
- +3 SET IDT=$ORDER(^LR(LRDFN,"CY",IDT),-1)
- +4 QUIT $SELECT(IDT&(IDT>(9999999-ENDT)):"1^C",1:0)
- +5 ;
- +6 ;***** CHECKS INPATIENT DATA
- INPAT(STDT,ENDT,DFN) ;
- +1 NEW ADMDT,DATE,DISDT,IEN,QUIT,RC,VAIP
- +2 SET STDT=STDT\1
- +3 ;--- Check for an admission date inside the time frame
- +4 SET QUIT=0
- SET DATE=(ENDT\1)_".999999"
- +5 FOR
- SET DATE=$ORDER(^DGPT("AAD",DFN,DATE),-1)
- if 'DATE!(DATE<STDT)
- QUIT
- Begin DoDot:1
- +6 SET IEN=""
- +7 FOR
- SET IEN=$ORDER(^DGPT("AAD",DFN,DATE,IEN),-1)
- if 'IEN
- QUIT
- Begin DoDot:2
- +8 if '$$PTF^RORXU001(IEN,"FP")
- SET QUIT=1
- End DoDot:2
- if QUIT
- QUIT
- End DoDot:1
- if QUIT
- QUIT
- +9 if QUIT=1
- QUIT "1^I"
- +10 ;--- Check for an earlier admission that overlaps the date range
- +11 SET QUIT=0
- SET VAIP("D")=STDT
- +12 FOR
- Begin DoDot:1
- +13 DO IN5^VADPT
- +14 SET VAIP("D")=+$GET(VAIP(13,1))
- +15 IF VAIP("D")'>0
- SET QUIT=2
- QUIT
- +16 SET VAIP("D")=$$FMADD^XLFDT(VAIP("D"),,,,-1)
- +17 SET IEN=+$GET(VAIP(12))
- if IEN'>0
- QUIT
- +18 SET RC=$$PTF^RORXU001(IEN,"FP",,.DISDT)
- +19 SET QUIT=$SELECT(RC:0,$GET(DISDT)'>0:1,DISDT>STDT:1,1:2)
- End DoDot:1
- if QUIT
- QUIT
- +20 QUIT $SELECT(QUIT=1:"1^I",1:0)
- +21 ;
- +22 ;***** CHECKS LAB DATA
- LAB(STDT,ENDT,RORDFN) ;
- +1 NEW PTID,RC,RORMSG,RORTMP
- +2 SET PTID=$$PTID^RORUTL02(RORDFN)
- if PTID<0
- QUIT 0
- +3 SET RORTMP=$$ALLOC^RORTMP()
- +4 ;--- Get the Lab data
- +5 SET ENDT=(ENDT\1+1)_"^CD"
- SET STDT=STDT_"^CD"
- +6 SET RC=$$GCPR^LA7QRY(PTID,STDT,ENDT,"CH","*",.RORMSG,RORTMP)
- +7 SET RC=$SELECT(($DATA(RORMSG)>1)&(RC=""):0,$DATA(@RORTMP)>1:"1^L",1:0)
- +8 ;--- Cleanup
- +9 DO FREE^RORTMP(RORTMP)
- +10 QUIT RC
- +11 ;
- +12 ;***** CHECKS MICROBIOLOGY DATA
- MICRO(STDT,ENDT,LRDFN) ;
- +1 NEW RC,RORTMP
- +2 SET RC=0
- SET RORTMP=$$ALLOC^RORTMP()
- +3 if $$GETDATA^LA7UTL1A(LRDFN,STDT,ENDT,"CD",RORTMP)'<0
- Begin DoDot:1
- +4 if $DATA(@RORTMP@(LRDFN))
- SET RC="1^M"
- End DoDot:1
- +5 DO FREE^RORTMP(RORTMP)
- +6 QUIT RC
- +7 ;
- +8 ;***** CHECKS OUTPATIENT DATA
- OUTPAT(STDT,ENDT,RORDFN) ;
- +1 SET STDT=$PIECE(STDT,".",1)
- SET STDT=STDT-1
- SET STDT=STDT+.9999
- +2 SET ENDT=$PIECE(ENDT,".",1)
- SET ENDT=ENDT+1
- +3 NEW QUERY,RORDST,RORECNT
- +4 SET RORECNT=0
- +5 SET RORDST=$NAME(^TMP("RORXU003",$JOB,"OUT"))
- +6 DO OPEN^SDQ(.QUERY)
- +7 DO INDEX^SDQ(.QUERY,"PATIENT/DATE","SET")
- +8 DO PAT^SDQ(.QUERY,RORDFN,"SET")
- +9 DO DATE^SDQ(.QUERY,STDT,ENDT,"SET")
- +10 DO SCANCB^SDQ(.QUERY,"D SCAN^RORXU003()","SET")
- +11 DO ACTIVE^SDQ(.QUERY,"TRUE","SET")
- +12 DO SCAN^SDQ(.QUERY,"FORWARD")
- +13 DO CLOSE^SDQ(.QUERY)
- +14 QUIT $SELECT(RORECNT:"1^O",1:0)
- +15 ;
- +16 ;***** CHECKS PHARMACY DATA
- PHARM(STDT,ENDT,RORDFN,CHK) ;
- +1 NEW BUF,II,IP,IV,OP,ORD,RC,RORLST,SKIP,TMP,TYPE
- +2 SET ENDT=$$FMADD^XLFDT(ENDT\1,1)
- +3 IF '$DATA(CHK("ALL"))
- Begin DoDot:1
- +4 SET IP='$DATA(CHK("IP"))
- +5 SET IV='$DATA(CHK("IV"))
- +6 SET OP='$DATA(CHK("OP"))
- End DoDot:1
- +7 IF '$TEST
- SET (OP,IP,IV)=0
- +8 ;=== Get the list of orders
- +9 KILL ^TMP("PS",$JOB)
- +10 DO OCL^PSOORRL(RORDFN,STDT,ENDT)
- +11 if $DATA(^TMP("PS",$JOB))<10
- QUIT 0
- +12 SET RORLST=$$ALLOC^RORTMP()
- +13 ;=== Preselect the orders
- +14 SET II=0
- +15 FOR
- SET II=$ORDER(^TMP("PS",$JOB,II))
- if 'II
- QUIT
- Begin DoDot:1
- +16 SET BUF=$GET(^TMP("PS",$JOB,II,0))
- SET ORD=$PIECE(BUF,U)
- if ORD'>0
- QUIT
- +17 SET TMP=$LENGTH(ORD)
- SET TYPE=$EXTRACT(ORD,TMP-2,TMP)
- +18 SET TYPE=$SELECT(TYPE="R;O":"R",TYPE="U;I":"U",TYPE="V;I":"V",1:"")
- +19 ;--- Check if this kind of orders should be processed
- +20 if $SELECT(TYPE="R"
- QUIT
- +21 ;--- Check the dates
- +22 IF "UV"[TYPE
- SET TMP=$PIECE(BUF,U,15)
- if (TMP<STDT)!(TMP'<ENDT)
- QUIT
- +23 IF TYPE="R"
- SET TMP=$PIECE(BUF,U,10)
- if TMP<STDT
- QUIT
- +24 ;--- Add the order to the list
- +25 SET @RORLST@(II)=TYPE
- SET @RORLST@(II,0)=BUF
- End DoDot:1
- +26 ;=== Process the preselected orders
- +27 SET II=0
- SET RC=""
- +28 FOR
- SET II=$ORDER(@RORLST@(II))
- if 'II
- QUIT
- Begin DoDot:1
- +29 SET TYPE=@RORLST@(II)
- SET ORD=$PIECE(@RORLST@(II,0),U)
- +30 ;--- Outpatient
- +31 IF TYPE="R"
- if OP
- QUIT
- Begin DoDot:2
- +32 ;--- Double-check the Rx date(s)
- +33 KILL ^TMP("PS",$JOB)
- +34 DO OEL^PSOORRL(RORDFN,ORD)
- +35 IF $DATA(^TMP("PS",$JOB))<10
- SET SKIP=1
- QUIT
- +36 SET SKIP=$$DTCHECK^RORUTL15(STDT,ENDT)
- End DoDot:2
- if 'SKIP
- SET OP=1
- SET RC=RC_U_"OP"
- QUIT
- +37 ;--- Inpatient
- +38 IF TYPE="U"
- if IP
- QUIT
- SET IP=1
- SET RC=RC_U_"IP"
- QUIT
- +39 ;--- IV
- +40 IF TYPE="V"
- if IV
- QUIT
- SET IV=1
- SET RC=RC_U_"IV"
- QUIT
- End DoDot:1
- if OP&IP&IV
- QUIT
- +41 ;===
- +42 DO FREE^RORTMP(RORLST)
- +43 KILL ^TMP("PS",$JOB)
- +44 SET $PIECE(RC,U)=(RC'="")
- +45 QUIT RC
- +46 ;
- +47 ;***** CHECKS RADIOLOGY DATA
- RAD(STDT,ENDT,RORDFN) ;
- +1 NEW RC
- +2 KILL ^TMP($JOB,"RAE1")
- +3 DO EN1^RAO7PC1(RORDFN,STDT,ENDT,999999999)
- +4 SET RC=$SELECT($DATA(^TMP($JOB,"RAE1",RORDFN))>1:"1^R",1:0)
- +5 KILL ^TMP($JOB,"RAE1")
- +6 QUIT RC
- +7 ;
- +8 ;*****
- SCAN() ;
- +1 SET RORECNT=1
- +2 QUIT
- +3 ;
- +4 ;***** CHECKS SURGICAL PATHOLOGY DATA
- SURGP(STDT,ENDT,LRDFN) ;
- +1 NEW IDT
- +2 SET IDT=$ORDER(^LR(LRDFN,"SP",9999999-STDT))
- +3 SET IDT=$ORDER(^LR(LRDFN,"SP",IDT),-1)
- +4 QUIT $SELECT(IDT&(IDT>(9999999-ENDT)):"1^SP",1:0)