| 1 | SCRPW45 ;RENO/KEITH - Outpatient Diagnosis/Procedure Search ; 15 Jul 98 02:38PM
|
|---|
| 2 | ;;5.3;Scheduling;**144,351,409**;AUG 13, 1993
|
|---|
| 3 | N SD,SDDIV,SDPAR,SDCRI,DIR,%DT
|
|---|
| 4 | D TITL^SCRPW50("Outpatient Diagnosis/Procedure Search ")
|
|---|
| 5 | G:'$$DIVA^SCRPW17(.SDDIV) EXIT
|
|---|
| 6 | D SUBT^SCRPW50("**** Date Range Selection ****")
|
|---|
| 7 | W ! S %DT="AEPX",%DT(0)=2961001,%DT("A")="Beginning date: " D ^%DT G:Y<1 EXIT S SD("BDT")=Y X ^DD("DD") S SD("PBDT")=Y
|
|---|
| 8 | EDT S %DT("A")=" Ending date: " W ! D ^%DT G:Y<1 EXIT
|
|---|
| 9 | I Y<SD("BDT") W !!,$C(7),"End date cannot be before begin date!",! G EDT
|
|---|
| 10 | S SD("EDT")=Y_.999999 X ^DD("DD") S SD("PEDT")=Y,(SDOUT,SDNUL)=0 F SDI=1:1:26 D PAR Q:SDOUT!SDNUL
|
|---|
| 11 | G:SDOUT!'$D(SDPAR) EXIT S SDNUL=0 F D CRI Q:SDOUT!SDNUL
|
|---|
| 12 | G:SDOUT!'$D(SDCRI) EXIT
|
|---|
| 13 | D SUBT^SCRPW50("**** Report Detail Format Selection ****")
|
|---|
| 14 | K DIR S DIR(0)="S^P:PATIENT;V:VISIT;E:ENCOUNTER",DIR("A")="Specify the level of detail desired",DIR("B")="PATIENT",DIR("?")="This determines what type of detail list will be printed."
|
|---|
| 15 | W ! D ^DIR G:$D(DUOUT)!$D(DTOUT) EXIT S SDFMT=Y_U_Y(0),SDD=$S(Y="E":1,1:2)
|
|---|
| 16 | K DIR S DIR(0)="Y",DIR("A")="Include additional print fields in the report",DIR("B")="NO" W ! D ^DIR G:$D(DUOUT)!$D(DTOUT) EXIT
|
|---|
| 17 | I Y D BLD^SCRPW21 S (SDOUT,SDNUL)=0,T="~" F Q:SDOUT!SDNUL D APF
|
|---|
| 18 | G:SDOUT EXIT D PDIS^SCRPW46 G:SDOUT EXIT
|
|---|
| 19 | QUE N ZTSAVE F SDI="SDFMT","SDAPF(","SD(","SDDIV(","SDDIV","SDPAR(","SDCRI(" S ZTSAVE(SDI)=""
|
|---|
| 20 | W ! D EN^XUTMDEVQ("START^SCRPW46","Outpatient Diagnosis/Procedure Search",.ZTSAVE)
|
|---|
| 21 | EXIT G EXIT^SCRPW47
|
|---|
| 22 | ;
|
|---|
| 23 | PAR ;Select report search criteria
|
|---|
| 24 | S SDVAR=$C(SDI+64)
|
|---|
| 25 | D SUBT^SCRPW50("**** Report Search Criteria Selection (Element '"_SDVAR_"') ****")
|
|---|
| 26 | K DIR S DIR(0)="SO^DL:DIAGNOSIS LIST;DR:DIAGNOSIS RANGE;PL:PROCEDURE LIST;PR:PROCEDURE RANGE",DIR("A")="Specify criteria type for search element '"_SDVAR_"'"
|
|---|
| 27 | S DIR("?")="Select the type of data to search for with element '"_SDVAR_"'." W ! D ^DIR I $D(DTOUT)!$D(DUOUT) S SDOUT=1 Q
|
|---|
| 28 | I X="" S SDNUL=1 Q
|
|---|
| 29 | S SDSEL=Y,SDSEL(0)=Y(0) N DIC S DIC(0)="AEMQZ",DIC=$S(SDSEL["D":"^ICD9(",1:"^ICPT(") D:SDSEL["L" LIST D:SDSEL["R" RANGE S SDNUL=0
|
|---|
| 30 | G:'$D(SDPAR(SDVAR)) PAR S SDPAR(SDVAR)=SDSEL_U_SDSEL(0),SD("LIST",$E(SDSEL),$E(SDSEL,2))=""
|
|---|
| 31 | Q
|
|---|
| 32 | ;
|
|---|
| 33 | LIST W ! F D Q:SDNUL!SDOUT
|
|---|
| 34 | .D ^DIC I $D(DUOUT)!$D(DTOUT) S SDOUT=1 Q
|
|---|
| 35 | .I X="" S SDNUL=1 Q
|
|---|
| 36 | .I Y>0 D
|
|---|
| 37 | ..S Y(0)=$S(SDSEL["D":$P($$ICDDX^ICDCODE(+Y),"^",2,99),1:$P($$CPT^ICPTCOD(+Y,,1),"^",2,99))
|
|---|
| 38 | ..S SDPAR(SDVAR,$P(Y,U))=$P(Y(0),U)_" "_$P(Y(0),U,$S(SDSEL["D":3,1:2))
|
|---|
| 39 | Q
|
|---|
| 40 | ;
|
|---|
| 41 | RANGE W ! S DIC("A")="From "_$S(SDSEL["D":"ICD DIAGNOSIS: ",1:"CPT CODE: ")
|
|---|
| 42 | D ^DIC I $D(DUOUT)!$D(DTOUT) S SDOUT=1 Q
|
|---|
| 43 | I X="" S SDNUL=1 Q
|
|---|
| 44 | Q:Y<1
|
|---|
| 45 | S Y(0)=$S(SDSEL["D":$P($$ICDDX^ICDCODE(+Y),"^",2,99),1:$P($$CPT^ICPTCOD(+Y,,1),"^",2,99))
|
|---|
| 46 | S S1=$P(Y(0),U)_" "_$P(Y(0),U,$S(SDSEL["D":3,1:2)),SDPAR(SDVAR,S1)=$P(Y,U),DIC("A")="To "_$P(DIC("A")," ",2,99)
|
|---|
| 47 | R2 W ! D ^DIC I $D(DUOUT)!$D(DTOUT) S SDOUT=1 Q
|
|---|
| 48 | I X=""!(Y<1) S SDNUL=1 K SDPAR(SDVAR) Q
|
|---|
| 49 | S Y(0)=$S(SDSEL["D":$P($$ICDDX^ICDCODE(+Y),"^",2,99),1:$P($$CPT^ICPTCOD(+Y,,1),"^",2,99))
|
|---|
| 50 | S S2=$P(Y(0),U)_" "_$P(Y(0),U,$S(SDSEL["D":3,1:2))
|
|---|
| 51 | I S1]S2 W !!,$C(7),"Ending value must collate after beginning value!",! G R2
|
|---|
| 52 | S SDPAR(SDVAR,S2)=$P(Y,U) Q
|
|---|
| 53 | ;
|
|---|
| 54 | CRI ;Prompt for element combination criteria
|
|---|
| 55 | D SUBT^SCRPW50("**** Search Element Combination Criteria ****")
|
|---|
| 56 | W !!," Specify letter combinations that represent how the search elements selected",!," above will be applied in evaluating patient activity (eg. ""ABC"" or ""ABC'D""):"
|
|---|
| 57 | F SDII=1:1 D CRI1 Q:SDOUT!SDNUL
|
|---|
| 58 | Q
|
|---|
| 59 | ;
|
|---|
| 60 | CRI1 K DIR S DIR(0)="F"_$S(SDII=1:"",1:"O")_"^1:40",DIR("A")=$S(SDII=1:"IF",1:"OR")
|
|---|
| 61 | S DIR("?",1)="Enter a string that represents the method which represents how the selected",DIR("?",2)="search criteria items will be applied during evaluation (eg. ""AB"" indicates"
|
|---|
| 62 | S DIR("?",3)="that element 'A' and 'B' must be true for data to be returned. The apostrophy",DIR("?",4)="""'"" may be used to negate (or exclude) a sort item. For example, ""A'B"""
|
|---|
| 63 | S DIR("?")="will return data where element 'A' is true and element 'B' is not true."
|
|---|
| 64 | W ! D ^DIR I $D(DTOUT)!$D(DUOUT) S SDOUT=1 Q
|
|---|
| 65 | I X="" S SDNUL=1 Q
|
|---|
| 66 | I $E(X)="&" W $C(7)," ?? Invalid!" G CRI1
|
|---|
| 67 | F S SDC=$E(Y,$L(Y)) Q:SDC'="'" S Y=$E(Y,1,($L(Y)-1))
|
|---|
| 68 | I '$L(Y)!$TR($TR(Y,"'",""),"&","")="" W $C(7),"No criteria selected!" G CRI1
|
|---|
| 69 | I Y["'&" W $C(7)," ?? The value ""'&"" is incorrect syntax!" G CRI1
|
|---|
| 70 | I Y["''" W $C(7)," ?? Character ""'"" appears redundantly!" G CRI1
|
|---|
| 71 | I Y["&&" W $C(7)," ?? Character ""&"" appears redundantly!" G CRI1
|
|---|
| 72 | I Y="" W $C(7),"No criteria selected!" G CRI1
|
|---|
| 73 | S SDBAD=0,SDSTR="",SDRESP=Y,SDR=$TR(Y,"&","") F SDIII=1:1:$L(SDR) S SDC=$E(SDR,SDIII) D Q:SDBAD
|
|---|
| 74 | .I "&'"'[SDC,$L(SDR,SDC)>2 W $C(7)," ?? Element '"_SDC_"' appears redundantly!" S SDBAD=1 Q
|
|---|
| 75 | .I SDC'="'",'$D(SDPAR(SDC)) W $C(7)," ?? Character '"_SDC_"' is not recognized!" S SDBAD=1 Q
|
|---|
| 76 | .S SDSTR=SDSTR_SDC_$S(SDC'="'":"&",1:"")
|
|---|
| 77 | .Q
|
|---|
| 78 | G:SDBAD CRI1
|
|---|
| 79 | S SDSTR=$E(SDSTR,1,($L(SDSTR)-1)) D STR(SDSTR,.SDTX) M SDCRI(SDSTR)=SDTX W " ",$S(SDII=1:"If ",1:"Or "),SDTX(1) S SDIII=1 F S SDIII=$O(SDTX(SDIII)) Q:'SDIII W !?4,SDTX(SDIII)
|
|---|
| 80 | Q
|
|---|
| 81 | ;
|
|---|
| 82 | STR(SDSTR,SDTX) ;Convert combine logic into output text string
|
|---|
| 83 | ;Required input: SDSTR=combine logic string
|
|---|
| 84 | ;Required input: SDTX=array (pass by reference) to return text
|
|---|
| 85 | N SDI,SDEXE,SDX
|
|---|
| 86 | F SDI=1:1:$L(SDSTR) S SDX(SDI)=$$STR1($E(SDSTR,SDI))
|
|---|
| 87 | S SDOXE(2)="S SDLTH=75",SDLTH=71-$L(SDSTR) D WRAP(.SDX,.SDTX,,.SDOXE,SDLTH,"")
|
|---|
| 88 | Q
|
|---|
| 89 | ;
|
|---|
| 90 | STR1(SDX) ;Convert to text (cont.)
|
|---|
| 91 | ;Required input: SDX=character to transform
|
|---|
| 92 | Q:SDX="&" "and " Q:SDX="'" "not "
|
|---|
| 93 | Q $P(SDPAR(SDX),U,2)_" '"_SDX_"' "
|
|---|
| 94 | ;
|
|---|
| 95 | APF ;Select additional print fields
|
|---|
| 96 | D SUBT^SCRPW50("Select additional print fields for patient detail: (optional)")
|
|---|
| 97 | K DIR S DIR("A")="Specify additional print field",DIR("?")="These fields will be included in the patient detail list output."
|
|---|
| 98 | S S1=$$DIR^SCRPW23(.DIR,1,"","","O",SDD) Q:SDOUT!SDNUL
|
|---|
| 99 | K DIR S DIR("A")="Select "_$P(S1,U,2)_" category",S2=$$DIR^SCRPW23(.DIR,2,"",$P(S1,U),"O",SDD,1) Q:SDOUT I SDNUL S SDNUL=0 Q
|
|---|
| 100 | S SDSEL=$P(S1,U)_$P(S2,U) G:$D(SDAPF("PFX",SDSEL)) PFD
|
|---|
| 101 | S SDS1=$P(^TMP("SCRPW",$J,"ACT",SDSEL),T,11),SDS2=$O(SDAPF(SDS1,""),-1)+1,SDAPF(SDS1,SDS2)=SDSEL_U_$P(S1,U,2)_U_$P(S2,U,2),SDAPF("PFX",SDSEL,SDS1,SDS2)=""
|
|---|
| 102 | Q
|
|---|
| 103 | ;
|
|---|
| 104 | PFD N DIR S DIR(0)="Y",DIR("A")="This item is already selected as a print field, do you want to delete it",DIR("B")="NO" D ^DIR Q:$D(DTOUT)!$D(DUOUT)
|
|---|
| 105 | I Y S S1=$O(SDAPF("PFX",SDSEL,"")),S2=$O(SDAPF("PFX",SDSEL,S1,"")) K SDAPF("SDX",SDSEL),SDAPF("PF",S1,S2) W !,"deleted..."
|
|---|
| 106 | Q
|
|---|
| 107 | ;
|
|---|
| 108 | WRAP(SDITX,SDOTX,SDIXE,SDOXE,SDLTH,SDUJC) ;Text wrapper
|
|---|
| 109 | ;Required input: SDITX=array (passed by reference) of text to be reformatted
|
|---|
| 110 | ;Required input: SDOTX=array (passed by reference) to return reformatted text
|
|---|
| 111 | ;Optional input: SDIXE=array (passed by reference) where SDIXE(n) is code to be executed prior to processing node SDITX(n)
|
|---|
| 112 | ;Optional input: SDOXE=array (passed by reference) where SDOXE(n) is code to be executed prior to creating node SDOTX(n)
|
|---|
| 113 | ;Optional input: SDLTH=line length, if not defined, SDLTH=IOM
|
|---|
| 114 | ;Optional input: SDUJC=value (0-5 characters) to be inserted when values are joined, if undefined AQKUJC=" "
|
|---|
| 115 | ;Output: Reformats values found in SDITX() array into wraparound text in SDOTX() of SDLTH length (10-255) characters
|
|---|
| 116 | ;
|
|---|
| 117 | N SDUI,SDUII,X,X1,X2,X3,X4,Y,Y1,Y2,SDLAST,SDUIII,SDUIV,SDTXB
|
|---|
| 118 | Q:$D(SDITX)'>1 S:'$D(SDUJC) SDUJC=" " S:$G(SDLTH)<10!($G(SDLTH)>255) SDLTH=IOM K SDOTX S SDUJC=$E(SDUJC,1,5),SDUI="",SDUII=1,SDOTX(1)="",SDLAST=$O(SDITX(""),-1) D POX
|
|---|
| 119 | F S SDUI=$O(SDITX(SDUI)) Q:SDUI']"" I $L(SDITX(SDUI)) D PIX S X=SDITX(SDUI)_$S(SDUI'=SDLAST:SDUJC,1:"") D MOVE
|
|---|
| 120 | Q
|
|---|
| 121 | ;
|
|---|
| 122 | PIX I $D(SDIXE(SDUI)) X SDIXE(SDUI)
|
|---|
| 123 | Q
|
|---|
| 124 | ;
|
|---|
| 125 | POX I $D(SDOXE(SDUII)) X SDOXE(SDUII)
|
|---|
| 126 | Q
|
|---|
| 127 | MOVE S X1=$L(X) Q:'X1 S X2=$L(X," "),Y=SDOTX(SDUII),Y1=$L(Y),Y2=SDLTH-Y1 I 'Y2 D INCR G MOVE
|
|---|
| 128 | I X1'>Y2 S SDOTX(SDUII)=SDOTX(SDUII)_X Q
|
|---|
| 129 | MOVE1 I X'[" ",X1'>SDLTH D:Y1 INCR S SDOTX(SDUII)=X Q
|
|---|
| 130 | MOVE2 I X'[" ",X1>SDLTH D:Y1 INCR S SDOTX(SDUII)=$E(X,1,SDLTH),X=$E(X,(SDLTH+1),999) G MOVE
|
|---|
| 131 | S X3=$L($P(X," ")) I X3=Y2 S SDOTX(SDUII)=SDOTX(SDUII)_$P(X," "),X=$P(X," ",2,999) G MOVE
|
|---|
| 132 | I X3>Y2,X3'>SDLTH D INCR G MOVE
|
|---|
| 133 | I X3>SDLTH D:Y1 INCR S SDOTX(SDUII)=$E(X,1,SDLTH),X=$E(X,(SDLTH+1),999) G MOVE
|
|---|
| 134 | MOVE3 K SDTXB F SDUIII=1:1:X2 S X4=999-$L($P(X," ",1,SDUIII)),SDTXB(X4,SDUIII)=""
|
|---|
| 135 | S SDUIII=$O(SDTXB(998-Y2)),SDUIV=$O(SDTXB(SDUIII,0)),SDOTX(SDUII)=SDOTX(SDUII)_$E(X,1,($L($P(X," ",1,SDUIV))+1)),X=$P(X," ",(SDUIV+1),999) G MOVE
|
|---|
| 136 | Q
|
|---|
| 137 | ;
|
|---|
| 138 | INCR S SDUII=SDUII+1,SDOTX(SDUII)="" D POX Q
|
|---|
