Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: SCRPW46

SCRPW46.m

Go to the documentation of this file. 
  1. SCRPW46 ;RENO/KEITH/MLR - Outpatient Diagnosis/Procedure Search (cont.) ; 9/27/00 10:29am
  1.  ;;5.3;Scheduling;**144,180,199,295,324,351,1015**;AUG 13, 1993;Build 21
  1.  ;  *199* 
  1.  ;  - Creation of Division subscript in ^TMP after DFN to capture,
  1.  ;    display, & count multi-divisional patients in Summary Section.
  1.  ;  - Filtering out on Sub-header those Division names not having
  1.  ;    patients meeting search criteria.
  1.  ;
  1. PDIS ;Parameter display
  1.  D SUBT^SCRPW50("**** Report Parameters Selected ****")
  1.  W ! D PD1^SCRPW47(0) S SDOUT=0
  1.  ;
  1. PDIS1 K DIR
  1.  S DIR(0)="S^C:CONTINUE;R:RE-DISPLAY PARAMETERS;P:PRINT PARAMETERS;Q:QUIT"
  1.  S DIR("A")="Select report action"
  1.  S DIR("B")="CONTINUE"
  1.  D ^DIR I $D(DTOUT)!$D(DUOUT) S SDOUT=1 Q
  1.  Q:Y="C"  G:Y="R" PDIS I Y="Q" S SDOUT=1 Q
  1.  N ZTSAVE
  1.  F SDI="SDDIV","SDDIV(","SD(","SDPAR(","SDCRI(","SDFMT","SDAPF(" S ZTSAVE(SDI)=""
  1.  W ! D EN^XUTMDEVQ("PPRT^SCRPW46","Print Report Parameters",.ZTSAVE)
  1.  G PDIS1
  1.  ;
  1. PPRT ;Print report parameters
  1.  D:$E(IOST)="C" DISP0^SCRPW23
  1.  S SDTIT(1)="<*>  OUTPATIENT DIAGNOSTIC/PROCEDURE CODE SEARCH  <*>"
  1.  S SDTIT(2)="Report Search Parameters" D HINI,HDR
  1.  D:'SDOUT PD1^SCRPW47(0) I $E(IOST)="P",$D(ZTQUEUED) G EXIT^SCRPW47
  1.  Q  ;PPRT
  1.  ;
  1. STOP ;Check for stop task request
  1.  S:$D(ZTQUEUED) (SDOUT,ZTSTOP)=$S($$S^%ZTLOAD:1,1:0) Q
  1.  ;
  1. HINI ;Initialize header variables
  1.  S SDLINE="",$P(SDLINE,"-",(IOM+1))=""
  1.  D NOW^%DTC S Y=% X ^DD("DD") S SDPNOW=$P(Y,":",1,2),SDPAGE=1,SDFF=0 Q
  1.  ;
  1. HDR ;Print report header
  1.  I $E(IOST)="C",SDFF N DIR S DIR(0)="E" W ! D ^DIR S SDOUT=Y'=1 Q:SDOUT
  1.  D STOP Q:SDOUT
  1.  I SDFF!('SDFF&($E(IOST)="C")) W $$XY^SCRPW50(IOF,1,0)
  1.  I $X W $$XY^SCRPW50("",0,0)
  1.  N SDI W SDLINE S SDI=0
  1.  F  S SDI=$O(SDTIT(SDI)) Q:'SDI  W !?(IOM-$L(SDTIT(SDI))\2),SDTIT(SDI)
  1.  W !,SDLINE,!,"For date range: ",SD("PBDT")," to ",SD("PEDT")
  1.  W !,"Date printed: ",SDPNOW,?(IOM-6-$L(SDPAGE)),"Page: ",SDPAGE
  1.  W !,SDLINE S SDPAGE=SDPAGE+1,SDFF=1
  1.  Q  ;HDR
  1.  ;
  1. DHDR(SDIV,SDI,SDTIT) ;Set up division subheaders
  1.  ;Required input: SDIV=division ifn or '0' for summary
  1.  ;Required input: SDI=array number to start with
  1.  ;Required input: SDTIT=array to store subheaders in (pass by reference)
  1.  D  ;
  1.  . I 'SDIV S SDTIT(SDI)="Summary for "_$P(SDDIV,U,2) Q
  1.  . I SDDIV,($P(SDDIV,U,2)="ALL DIVISIONS") S SDTIT(SDI)="For division: "_SDIVN_" "_SDIVL(SDIVN) Q  ; SD*5.3*324
  1.  . S SDTIT(SDI)="For facility: "_SDIVN Q
  1.  ;S SDTIT(SDI)=$S('SDIV:"Summary for "_$P(SDDIV,U,2),SDDIV!($P(SDDIV,U,2)="ALL DIVISIONS"):"For division: "_SDIVN_" "_SDIVL(SDIVN),1:"For facility: "_SDIVN)
  1.  ;
  1.  I 'SDIV,$P(SDDIV,U,2)="SELECTED DIVISIONS" N SDIVN S SDIVN="" D  Q
  1.  .F  S SDIVN=$O(SDDIV(SDIVN)) Q:SDIVN=""  S SDI=SDI+1,SDTIT(SDI)="Division: "_SDDIV(SDIVN)
  1.  .Q
  1.  ;
  1.  I 'SDIV,$P(SDDIV,U,2)="ALL DIVISIONS" D
  1.  .N SDIV S SDIV=0 F  S SDIV=$O(^TMP("SCRPW",$J,SDIV)) Q:'SDIV  D
  1.  .. Q:'$D(^TMP("SCRPW",$J,SDIV,2))
  1.  .. S SDI=SDI+1
  1.  .. S SDTIT(SDI)="Division: "_$P($G(^DG(40.8,SDIV,0)),U)_"  "_SDIV
  1.  .Q
  1.  Q
  1.  ;
  1. START ;Print report
  1.  K ^TMP("SCRPW",$J) S (SDOUT,SDSTOP)=0,SDMD="",SDMD=$O(SDDIV(SDMD)),SDMD=$O(SDDIV(SDMD)) S:$P(SDDIV,U,2)="ALL DIVISIONS" SDMD=1
  1.  ;Iterate through list of patient encounters
  1.  S DFN=0 F  S DFN=$O(^SCE("ADFN",DFN)) Q:'DFN  K SDPDIV S SDSTOP=SDSTOP+1 D:SDSTOP#100=0 STOP Q:SDOUT  D
  1.  .S SDT=SD("BDT") F  S SDT=$O(^SCE("ADFN",DFN,SDT)) Q:'SDT!SDOUT!(SDT>SD("EDT"))  D
  1.  ..S SDOE=0 F  S SDOE=$O(^SCE("ADFN",DFN,SDT,SDOE)) Q:'SDOE!SDOUT  D
  1.  ...S SDOE0=$$GETOE^SDOE(SDOE) S SDIV=$P(SDOE0,"^",11) Q:'SDIV!$P(SDOE0,"^",6)!'$$DIV()  S SDPDIV(SDIV)=""
  1.  ...;Build initial patient diagnosis/procedure lists
  1.  ...I $D(SD("LIST","D")) K SDLIST D GETDX^SDOE(SDOE,"SDLIST") S SDI=0 F  S SDI=$O(SDLIST(SDI)) Q:'SDI  D
  1.  ....S SDDX=$P(SDLIST(SDI),"^") S:SDDX ^TMP("SCRPW",$J,0,0,DFN,SDIV,"DX",SDDX)=""
  1.  ....Q
  1.  ...I $D(SD("LIST","P")) K SDLIST D GETCPT^SDOE(SDOE,"SDLIST") S SDI=0 F  S SDI=$O(SDLIST(SDI)) Q:'SDI  D
  1.  ....S SDCPT=$P(SDLIST(SDI),"^") S:SDCPT ^TMP("SCRPW",$J,0,0,DFN,SDIV,"CPT",SDCPT)=""
  1.  ....;Loop through modifiers and add to CPT array
  1.  .... N SDMODN,SDMOD  ; SDMODN=modifier node, SDMOD=mod pointer
  1.  .... S SDMODN=0
  1.  .... F  S SDMODN=+$O(SDLIST(SDI,1,SDMODN)) Q:'SDMODN  D
  1.  ..... S SDMOD=$P(SDLIST(SDI,1,SDMODN,0),"^",1)
  1.  ..... S:SDMOD ^TMP("SCRPW",$J,0,0,DFN,SDIV,"CPT",SDCPT,SDMOD)=""
  1.  ..... Q
  1.  .... Q
  1.  ...S:$P(SDFMT,"^")="E" ^TMP("SCRPW",$J,SDIV,1,DFN,SDIV,"ACT",SDT,SDOE)=SDOE0
  1.  ...S:$P(SDFMT,"^")="V" ^TMP("SCRPW",$J,SDIV,1,DFN,SDIV,"ACT",$P(SDT,"."))=""
  1.  ...S:$P(SDFMT,"^")="P" ^TMP("SCRPW",$J,SDIV,1,DFN,SDIV,"ACT")=""
  1.  ...Q
  1.  ..Q
  1.  .I '$D(^TMP("SCRPW",$J,0,0,DFN)) D  Q
  1.  ..N SDIV S SDIV="" F  S SDIV=$O(SDPDIV(SDIV)) Q:SDIV=""  K ^TMP("SCRPW",$J,SDIV,1,DFN)
  1.  ..Q
  1.  .;Build text lists for Diagnosis ranges if necessary
  1.  .I $D(SD("LIST","D","R")) D
  1.  .. N SDIV S SDIV="" F  S SDIV=$O(SDPDIV(SDIV)) Q:'SDIV  D
  1.  ... S SDI=0 F  S SDI=$O(^TMP("SCRPW",$J,0,0,DFN,SDIV,"DX",SDI)) Q:'SDI  D
  1.  ....S SDX=$$ICDDX^ICDCODE(SDI,+SDOE0),SDX=$P(SDX,"^",2)_" "_$P(SDX,"^",4)
  1.  .... S:$L(SDX)>1 ^TMP("SCRPW",$J,0,0,DFN,SDIV,"DXR",SDX)=SDI
  1.  .;Building text list for Procedure ranges
  1.  .I $D(SD("LIST","P","R")) S SDI=0 F  S SDI=$O(^TMP("SCRPW",$J,0,0,DFN,SDIV,"CPT",SDI)) Q:'SDI  D
  1.  ..; SDI=CPT pointer, SDI2=mod ptr, SDX=CPT+desc, SDX2=mod+desc
  1.  ..; get CPT and description and build array entry
  1.  .. N CPTINFO,CPTCODE,CPTTEXT
  1.  .. S CPTINFO=$$CPT^ICPTCOD(SDI,+SDOE0,1)
  1.  .. Q:CPTINFO'>0
  1.  .. S CPTCODE=$P(CPTINFO,"^",2)
  1.  .. S CPTTEXT=$P(CPTINFO,"^",3)
  1.  .. S SDX=CPTCODE_" "_CPTTEXT
  1.  .. S:$L(SDX)>1 ^TMP("SCRPW",$J,0,0,DFN,SDIV,"CPTR",SDX)=SDI
  1.  ..;
  1.  ..; loop through mods in CPT array and call API to get mod code/desc
  1.  .. S SDI2="" F  S SDI2=$O(^TMP("SCRPW",$J,0,0,DFN,SDIV,"CPT",SDI,SDI2)) Q:'SDI2  D
  1.  ... N MODINFO,MODCODE,MODTEXT
  1.  ... S MODINFO=$$MOD^ICPTMOD(SDI2,"I",+SDOE0,1)
  1.  ... Q:MODINFO'>0
  1.  ... S MODCODE=$P(MODINFO,"^",2)
  1.  ... S MODTEXT=$P(MODINFO,"^",3)
  1.  ... S SDX2=MODCODE_" "_MODTEXT
  1.  ... ; add mod code/desc to array
  1.  ... S:$L(SDX2)>1 ^TMP("SCRPW",$J,0,0,DFN,SDIV,"CPTR",SDX,SDX2)=SDI2
  1.  ... Q
  1.  ..Q
  1.  .;Iterate through criteria combine logic
  1.  .;Loop through secondary Division (SDIV) for multiple division episodes
  1.  . N SDIV S SDIV="" F  S SDIV=$O(SDPDIV(SDIV)) Q:SDIV=""  D
  1.  .. S SDCRI="" F  S SDCRI=$O(SDCRI(SDCRI)) Q:SDCRI=""  D
  1.  ... S SDCL=$TR($TR(SDCRI,"'",""),"&","") F SDI=1:1:$L(SDCL) S SDC=$E(SDCL,SDI) D:'$D(^TMP("SCRPW",$J,0,0,DFN,SDIV,"CRI",SDC))
  1.  ....;Build list of true items for each criteria element
  1.  .... S SDZ=$P(SDPAR(SDC),"^")
  1.  .... I SDZ="DL" S SDI=0 F  S SDI=$O(^TMP("SCRPW",$J,0,0,DFN,SDIV,"DX",SDI)) Q:'SDI  D
  1.  ..... S:$D(SDPAR(SDC,SDI)) ^TMP("SCRPW",$J,0,0,DFN,SDIV,"CRI",SDC,SDI)=""
  1.  ..... Q
  1.  .... I SDZ="DR" S SDR1="",SDR1=$O(SDPAR(SDC,SDR1)),SDR2=$O(SDPAR(SDC,SDR1)),SDI="" D
  1.  ..... F  S SDI=$O(^TMP("SCRPW",$J,0,0,DFN,SDIV,"DXR",SDI)) Q:SDI=""  D
  1.  ...... I SDR1']SDI,SDI']SDR2 S ^TMP("SCRPW",$J,0,0,DFN,SDIV,"CRI",SDC,SDI)=""  Q
  1.  ..... Q
  1.  .... I SDZ="PL" S SDI=0 F  S SDI=$O(^TMP("SCRPW",$J,0,0,DFN,SDIV,"CPT",SDI)) Q:'SDI  D
  1.  ..... I $D(SDPAR(SDC,SDI)) M ^TMP("SCRPW",$J,0,0,DFN,SDIV,"CRI",SDC,SDI)=^TMP("SCRPW",$J,0,0,DFN,SDIV,"CPT",SDI)
  1.  ..... Q
  1.  .... I SDZ="PR" S SDR1="",SDR1=$O(SDPAR(SDC,SDR1)),SDR2=$O(SDPAR(SDC,SDR1)),SDI="" D
  1.  ..... F  S SDI=$O(^TMP("SCRPW",$J,0,0,DFN,SDIV,"CPTR",SDI)) Q:SDI=""  D
  1.  ...... I SDR1']SDI,SDI']SDR2 M ^TMP("SCRPW",$J,0,0,DFN,SDIV,"CRI",SDC,SDI)=^TMP("SCRPW",$J,0,0,DFN,SDIV,"CPTR",SDI)
  1.  ......Q
  1.  .....Q
  1.  ....S ^TMP("SCRPW",$J,0,0,DFN,SDIV,"CRI",SDC)=($D(^TMP("SCRPW",$J,0,0,DFN,SDIV,"CRI",SDC))>0)_U_SDZ
  1.  .... Q
  1.  ...;Apply criteria combine logic
  1.  ...N A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,U,V,W,X,Y,Z
  1.  ...F SDI=1:1:$L(SDCL) S SDC=$E(SDCL,SDI),@SDC=$P(^TMP("SCRPW",$J,0,0,DFN,SDIV,"CRI",SDC),"^")
  1.  ...;If combine logic is "true", move items to final list
  1.  ...I @SDCRI F SDI=1:1:$L(SDCL) S SDC=$E(SDCL,SDI),SDX=^TMP("SCRPW",$J,0,0,DFN,SDIV,"CRI",SDC) D
  1.  ....I SDX M ^TMP("SCRPW",$J,0,1,DFN,SDIV,$P(SDX,"^",2))=^TMP("SCRPW",$J,0,0,DFN,SDIV,"CRI",SDC)
  1.  ....Q
  1.  ...Q
  1.  .I '$D(^TMP("SCRPW",$J,0,1,DFN)) D  Q
  1.  ..S SDIV="" F  S SDIV=$O(SDPDIV(SDIV)) Q:SDIV=""  K ^TMP("SCRPW",$J,SDIV,1,DFN)
  1.  ..Q
  1.  .;Move item ifn lists to text lists
  1.  .N SDIV S SDIV="" F  S SDIV=$O(SDPDIV(SDIV)) Q:SDIV=""  D
  1.  .. S SDI=0 F  S SDI=$O(^TMP("SCRPW",$J,0,1,DFN,SDIV,"DL",SDI)) Q:'SDI  D
  1.  ... S SDX=$$ICDDX^ICDCODE(SDI,+SDOE0),SDX=$P(SDX,"^",2)_" "_$P(SDX,"^",4) S:$L(SDX)>1 ^TMP("SCRPW",$J,0,1,DFN,SDIV,"DR",SDX)=$G(SDT)
  1.         ... Q
  1.  .N SDIV S SDIV="" F  S SDIV=$O(SDPDIV(SDIV)) Q:SDIV=""  D
  1.  .. S SDI=0 F  S SDI=$O(^TMP("SCRPW",$J,0,1,DFN,SDIV,"PL",SDI)) Q:'SDI  D
  1.  ... N CPTINFO,CPTCODE,CPTTEXT
  1.  ... S CPTINFO=$$CPT^ICPTCOD(SDI,+SDOE0,1)
  1.  ... Q:CPTINFO'>0
  1.  ... S CPTCODE=$P(CPTINFO,"^",2)
  1.  ... S CPTTEXT=$P(CPTINFO,"^",3)
  1.  ... S SDX=CPTCODE_" "_CPTTEXT
  1.  ... S:$L(SDX)>1 ^TMP("SCRPW",$J,0,1,DFN,SDIV,"PR",SDX)=""
  1.  ... ;
  1.  ... ;loop through mods in CPT array and call API to get mod code/desc
  1.  ... S SDI2=""
  1.  ... F  S SDI2=$O(^TMP("SCRPW",$J,0,1,DFN,SDIV,"PL",SDI,SDI2)) Q:'SDI2  D
  1.  .... N MODINFO,MODCODE,MODTEXT
  1.  .... S MODINFO=$$MOD^ICPTMOD(SDI2,"I",+SDOE0,1)
  1.  .... Q:MODINFO'>0
  1.  .... S MODCODE=$P(MODINFO,"^",2)
  1.  .... S MODTEXT=$P(MODINFO,"^",3)
  1.  .... S SDX2=MODCODE_" "_MODTEXT
  1.  .... ; add mod code/desc to array
  1.  .... S:$L(SDX2)>1 ^TMP("SCRPW",$J,0,1,DFN,SDIV,"PR",SDX,SDX2)=""
  1.  .... Q 
  1.  ...Q
  1.  . ; delete procedure list array
  1.  . N SDIV S SDIV="" F  S SDIV=$O(SDPDIV(SDIV)) Q:SDIV=""  D
  1.  ..;Merge activity list
  1.  .. M ^TMP("SCRPW",$J,SDIV,1,DFN,SDIV,"ACT")=^TMP("SCRPW",$J,SDIV,0,DFN,SDIV,"ACT")
  1.  ..;Kill scratch list, merge to summary global if multidivisional
  1.  ..I SDMD,SDFMT'="P" M ^TMP("SCRPW",$J,0,1,DFN,SDIV,"ACT")=^TMP("SCRPW",$J,SDIV,1,DFN,SDIV,"ACT")
  1.  ..;Delete scratch levels and arrays after merge
  1.  .. K ^TMP("SCRPW",$J,0,1,DFN,"DL")
  1.  .. K ^TMP("SCRPW",$J,0,1,DFN,"PL")
  1.  ..Q
  1.  .Q
  1.  ;Delete 0,0 scratch level prior to printing
  1.  K ^TMP("SCRPW",$J,0,0)
  1.  G:SDOUT EXIT^SCRPW47 G ^SCRPW47
  1.  ;
  1. DIV() ;Check division
  1.  Q:'SDDIV 1  Q $D(SDDIV(+SDIV))