- SCRPW45 ;RENO/KEITH - Outpatient Diagnosis/Procedure Search ;15 Jul 98 02:38PM
- ;;5.3;Scheduling;**144,351,409,593**;AUG 13, 1993;Build 13
- N SD,SDDIV,SDPAR,SDCRI,DIR,%DT
- D TITL^SCRPW50("Outpatient Diagnosis/Procedure Search ")
- G:'$$DIVA^SCRPW17(.SDDIV) EXIT
- D SUBT^SCRPW50("**** Date Range Selection ****")
- S Y=$$IMP^SCRPWICD(30) S SD("I10DTI")=Y X ^DD("DD") S SD("I10DTE")=Y
- BDT 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
- EDT S %DT("A")=" Ending date: " W ! D ^%DT G:Y<1 EXIT
- I Y<SD("BDT") W !!,$C(7),"End date cannot be before begin date!",! G EDT
- ;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
- S SD("EDT")=Y_.999999 X ^DD("DD") S SD("PEDT")=Y
- I (SD("BDT")<SD("I10DTI")),(SD("EDT")'<SD("I10DTI")) D G BDT
- . W !!,$C(7),"Beginning and Ending dates must both be prior to "_SD("I10DTE")_" (ICD-9) or both be on or after "_SD("I10DTE")_" (ICD-10)."
- S (SDOUT,SDNUL)=0 F SDI=1:1:26 D PAR Q:SDOUT!SDNUL
- G:SDOUT!'$D(SDPAR) EXIT S SDNUL=0 F D CRI Q:SDOUT!SDNUL
- G:SDOUT!'$D(SDCRI) EXIT
- D SUBT^SCRPW50("**** Report Detail Format Selection ****")
- 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."
- W ! D ^DIR G:$D(DUOUT)!$D(DTOUT) EXIT S SDFMT=Y_U_Y(0),SDD=$S(Y="E":1,1:2)
- 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
- I Y D BLD^SCRPW21 S (SDOUT,SDNUL)=0,T="~" F Q:SDOUT!SDNUL D APF
- G:SDOUT EXIT D PDIS^SCRPW46 G:SDOUT EXIT
- QUE N ZTSAVE F SDI="SDFMT","SDAPF(","SD(","SDDIV(","SDDIV","SDPAR(","SDCRI(" S ZTSAVE(SDI)=""
- W ! D EN^XUTMDEVQ("START^SCRPW46","Outpatient Diagnosis/Procedure Search",.ZTSAVE)
- EXIT G EXIT^SCRPW47
- ;
- PAR ;Select report search criteria
- S SDVAR=$C(SDI+64)
- D SUBT^SCRPW50("**** Report Search Criteria Selection (Element '"_SDVAR_"') ****")
- 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_"'"
- 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
- I X="" S SDNUL=1 Q
- S SDSEL=Y,SDSEL(0)=Y(0) N DIC S DIC(0)="AEMQZ",DIC=$S(SDSEL["D":"^ICD9(",1:"^ICPT(")
- S:DIC="^ICD9(" DIC("S")="I $$CSI^SCRPWICD(80,Y)="_$S(SD("BDT")<SD("I10DTI"):1,1:30)
- D:SDSEL["L" LIST D:SDSEL["R" RANGE S SDNUL=0
- G:'$D(SDPAR(SDVAR)) PAR S SDPAR(SDVAR)=SDSEL_U_SDSEL(0),SD("LIST",$E(SDSEL),$E(SDSEL,2))=""
- Q
- ;
- LIST W ! F D Q:SDNUL!SDOUT
- .D ^DIC I $D(DUOUT)!$D(DTOUT) S SDOUT=1 Q
- .I X="" S SDNUL=1 Q
- .I Y>0 D
- ..S Y(0)=$S(SDSEL["D":$P($$ICDDX^SCRPWICD(+Y),"^",2,99),1:$P($$CPT^ICPTCOD(+Y,,1),"^",2,99))
- ..S SDPAR(SDVAR,$P(Y,U))=$P(Y(0),U)_" "_$P(Y(0),U,$S(SDSEL["D":3,1:2))
- Q
- ;
- RANGE W ! S DIC("A")="From "_$S(SDSEL["D":"ICD DIAGNOSIS: ",1:"CPT CODE: ")
- D ^DIC I $D(DUOUT)!$D(DTOUT) S SDOUT=1 Q
- I X="" S SDNUL=1 Q
- Q:Y<1
- S Y(0)=$S(SDSEL["D":$P($$ICDDX^SCRPWICD(+Y),"^",2,99),1:$P($$CPT^ICPTCOD(+Y,,1),"^",2,99))
- 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)
- R2 W ! D ^DIC I $D(DUOUT)!$D(DTOUT) S SDOUT=1 Q
- I X=""!(Y<1) S SDNUL=1 K SDPAR(SDVAR) Q
- S Y(0)=$S(SDSEL["D":$P($$ICDDX^SCRPWICD(+Y),"^",2,99),1:$P($$CPT^ICPTCOD(+Y,,1),"^",2,99))
- S S2=$P(Y(0),U)_" "_$P(Y(0),U,$S(SDSEL["D":3,1:2))
- I S1]S2 W !!,$C(7),"Ending value must collate after beginning value!",! G R2
- S SDPAR(SDVAR,S2)=$P(Y,U) Q
- ;
- CRI ;Prompt for element combination criteria
- D SUBT^SCRPW50("**** Search Element Combination Criteria ****")
- W !!," Specify letter combinations that represent how the search elements selected",!," above will be applied in evaluating patient activity (eg. ""ABC"" or ""ABC'D""):"
- F SDII=1:1 D CRI1 Q:SDOUT!SDNUL
- Q
- ;
- CRI1 K DIR S DIR(0)="F"_$S(SDII=1:"",1:"O")_"^1:40",DIR("A")=$S(SDII=1:"IF",1:"OR")
- 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"
- 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"""
- S DIR("?")="will return data where element 'A' is true and element 'B' is not true."
- W ! D ^DIR I $D(DTOUT)!$D(DUOUT) S SDOUT=1 Q
- I X="" S SDNUL=1 Q
- I $E(X)="&" W $C(7)," ?? Invalid!" G CRI1
- F S SDC=$E(Y,$L(Y)) Q:SDC'="'" S Y=$E(Y,1,($L(Y)-1))
- I '$L(Y)!$TR($TR(Y,"'",""),"&","")="" W $C(7),"No criteria selected!" G CRI1
- I Y["'&" W $C(7)," ?? The value ""'&"" is incorrect syntax!" G CRI1
- I Y["''" W $C(7)," ?? Character ""'"" appears redundantly!" G CRI1
- I Y["&&" W $C(7)," ?? Character ""&"" appears redundantly!" G CRI1
- I Y="" W $C(7),"No criteria selected!" G CRI1
- S SDBAD=0,SDSTR="",SDRESP=Y,SDR=$TR(Y,"&","") F SDIII=1:1:$L(SDR) S SDC=$E(SDR,SDIII) D Q:SDBAD
- .I "&'"'[SDC,$L(SDR,SDC)>2 W $C(7)," ?? Element '"_SDC_"' appears redundantly!" S SDBAD=1 Q
- .I SDC'="'",'$D(SDPAR(SDC)) W $C(7)," ?? Character '"_SDC_"' is not recognized!" S SDBAD=1 Q
- .S SDSTR=SDSTR_SDC_$S(SDC'="'":"&",1:"")
- .Q
- G:SDBAD CRI1
- 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)
- Q
- ;
- STR(SDSTR,SDTX) ;Convert combine logic into output text string
- ;Required input: SDSTR=combine logic string
- ;Required input: SDTX=array (pass by reference) to return text
- N SDI,SDEXE,SDX
- F SDI=1:1:$L(SDSTR) S SDX(SDI)=$$STR1($E(SDSTR,SDI))
- S SDOXE(2)="S SDLTH=75",SDLTH=71-$L(SDSTR) D WRAP(.SDX,.SDTX,,.SDOXE,SDLTH,"")
- Q
- ;
- STR1(SDX) ;Convert to text (cont.)
- ;Required input: SDX=character to transform
- Q:SDX="&" "and " Q:SDX="'" "not "
- Q $P(SDPAR(SDX),U,2)_" '"_SDX_"' "
- ;
- APF ;Select additional print fields
- D SUBT^SCRPW50("Select additional print fields for patient detail: (optional)")
- K DIR S DIR("A")="Specify additional print field",DIR("?")="These fields will be included in the patient detail list output."
- S S1=$$DIR^SCRPW23(.DIR,1,"","","O",SDD) Q:SDOUT!SDNUL
- 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
- S SDSEL=$P(S1,U)_$P(S2,U) G:$D(SDAPF("PFX",SDSEL)) PFD
- 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)=""
- Q
- ;
- 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)
- I Y S S1=$O(SDAPF("PFX",SDSEL,"")),S2=$O(SDAPF("PFX",SDSEL,S1,"")) K SDAPF("SDX",SDSEL),SDAPF("PF",S1,S2) W !,"deleted..."
- Q
- ;
- WRAP(SDITX,SDOTX,SDIXE,SDOXE,SDLTH,SDUJC) ;Text wrapper
- ;Required input: SDITX=array (passed by reference) of text to be reformatted
- ;Required input: SDOTX=array (passed by reference) to return reformatted text
- ;Optional input: SDIXE=array (passed by reference) where SDIXE(n) is code to be executed prior to processing node SDITX(n)
- ;Optional input: SDOXE=array (passed by reference) where SDOXE(n) is code to be executed prior to creating node SDOTX(n)
- ;Optional input: SDLTH=line length, if not defined, SDLTH=IOM
- ;Optional input: SDUJC=value (0-5 characters) to be inserted when values are joined, if undefined AQKUJC=" "
- ;Output: Reformats values found in SDITX() array into wraparound text in SDOTX() of SDLTH length (10-255) characters
- ;
- N SDUI,SDUII,X,X1,X2,X3,X4,Y,Y1,Y2,SDLAST,SDUIII,SDUIV,SDTXB
- 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
- 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
- Q
- ;
- PIX I $D(SDIXE(SDUI)) X SDIXE(SDUI)
- Q
- ;
- POX I $D(SDOXE(SDUII)) X SDOXE(SDUII)
- Q
- 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
- I X1'>Y2 S SDOTX(SDUII)=SDOTX(SDUII)_X Q
- MOVE1 I X'[" ",X1'>SDLTH D:Y1 INCR S SDOTX(SDUII)=X Q
- MOVE2 I X'[" ",X1>SDLTH D:Y1 INCR S SDOTX(SDUII)=$E(X,1,SDLTH),X=$E(X,(SDLTH+1),999) G MOVE
- S X3=$L($P(X," ")) I X3=Y2 S SDOTX(SDUII)=SDOTX(SDUII)_$P(X," "),X=$P(X," ",2,999) G MOVE
- I X3>Y2,X3'>SDLTH D INCR G MOVE
- I X3>SDLTH D:Y1 INCR S SDOTX(SDUII)=$E(X,1,SDLTH),X=$E(X,(SDLTH+1),999) G MOVE
- MOVE3 K SDTXB F SDUIII=1:1:X2 S X4=999-$L($P(X," ",1,SDUIII)),SDTXB(X4,SDUIII)=""
- 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
- Q
- ;
- INCR S SDUII=SDUII+1,SDOTX(SDUII)="" D POX Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCRPW45 9011 printed Feb 19, 2025@00:10:13 Page 2
- SCRPW45 ;RENO/KEITH - Outpatient Diagnosis/Procedure Search ;15 Jul 98 02:38PM
- +1 ;;5.3;Scheduling;**144,351,409,593**;AUG 13, 1993;Build 13
- +2 NEW SD,SDDIV,SDPAR,SDCRI,DIR,%DT
- +3 DO TITL^SCRPW50("Outpatient Diagnosis/Procedure Search ")
- +4 if '$$DIVA^SCRPW17(.SDDIV)
- GOTO EXIT
- +5 DO SUBT^SCRPW50("**** Date Range Selection ****")
- +6 SET Y=$$IMP^SCRPWICD(30)
- SET SD("I10DTI")=Y
- XECUTE ^DD("DD")
- SET SD("I10DTE")=Y
- BDT WRITE !
- SET %DT="AEPX"
- SET %DT(0)=2961001
- SET %DT("A")="Beginning date: "
- DO ^%DT
- if Y<1
- GOTO EXIT
- SET SD("BDT")=Y
- XECUTE ^DD("DD")
- SET SD("PBDT")=Y
- EDT SET %DT("A")=" Ending date: "
- WRITE !
- DO ^%DT
- if Y<1
- GOTO EXIT
- +1 IF Y<SD("BDT")
- WRITE !!,$CHAR(7),"End date cannot be before begin date!",!
- GOTO EDT
- +2 ;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
- +3 SET SD("EDT")=Y_.999999
- XECUTE ^DD("DD")
- SET SD("PEDT")=Y
- +4 IF (SD("BDT")<SD("I10DTI"))
- IF (SD("EDT")'<SD("I10DTI"))
- Begin DoDot:1
- +5 WRITE !!,$CHAR(7),"Beginning and Ending dates must both be prior to "_SD("I10DTE")_" (ICD-9) or both be on or after "_SD("I10DTE")_" (ICD-10)."
- End DoDot:1
- GOTO BDT
- +6 SET (SDOUT,SDNUL)=0
- FOR SDI=1:1:26
- DO PAR
- if SDOUT!SDNUL
- QUIT
- +7 if SDOUT!'$DATA(SDPAR)
- GOTO EXIT
- SET SDNUL=0
- FOR
- DO CRI
- if SDOUT!SDNUL
- QUIT
- +8 if SDOUT!'$DATA(SDCRI)
- GOTO EXIT
- +9 DO SUBT^SCRPW50("**** Report Detail Format Selection ****")
- +10 KILL DIR
- SET DIR(0)="S^P:PATIENT;V:VISIT;E:ENCOUNTER"
- SET DIR("A")="Specify the level of detail desired"
- SET DIR("B")="PATIENT"
- SET DIR("?")="This determines what type of detail list will be printed."
- +11 WRITE !
- DO ^DIR
- if $DATA(DUOUT)!$DATA(DTOUT)
- GOTO EXIT
- SET SDFMT=Y_U_Y(0)
- SET SDD=$SELECT(Y="E":1,1:2)
- +12 KILL DIR
- SET DIR(0)="Y"
- SET DIR("A")="Include additional print fields in the report"
- SET DIR("B")="NO"
- WRITE !
- DO ^DIR
- if $DATA(DUOUT)!$DATA(DTOUT)
- GOTO EXIT
- +13 IF Y
- DO BLD^SCRPW21
- SET (SDOUT,SDNUL)=0
- SET T="~"
- FOR
- if SDOUT!SDNUL
- QUIT
- DO APF
- +14 if SDOUT
- GOTO EXIT
- DO PDIS^SCRPW46
- if SDOUT
- GOTO EXIT
- QUE NEW ZTSAVE
- FOR SDI="SDFMT","SDAPF(","SD(","SDDIV(","SDDIV","SDPAR(","SDCRI("
- SET ZTSAVE(SDI)=""
- +1 WRITE !
- DO EN^XUTMDEVQ("START^SCRPW46","Outpatient Diagnosis/Procedure Search",.ZTSAVE)
- EXIT GOTO EXIT^SCRPW47
- +1 ;
- PAR ;Select report search criteria
- +1 SET SDVAR=$CHAR(SDI+64)
- +2 DO SUBT^SCRPW50("**** Report Search Criteria Selection (Element '"_SDVAR_"') ****")
- +3 KILL DIR
- SET DIR(0)="SO^DL:DIAGNOSIS LIST;DR:DIAGNOSIS RANGE;PL:PROCEDURE LIST;PR:PROCEDURE RANGE"
- SET DIR("A")="Specify criteria type for search element '"_SDVAR_"'"
- +4 SET DIR("?")="Select the type of data to search for with element '"_SDVAR_"'."
- WRITE !
- DO ^DIR
- IF $DATA(DTOUT)!$DATA(DUOUT)
- SET SDOUT=1
- QUIT
- +5 IF X=""
- SET SDNUL=1
- QUIT
- +6 SET SDSEL=Y
- SET SDSEL(0)=Y(0)
- NEW DIC
- SET DIC(0)="AEMQZ"
- SET DIC=$SELECT(SDSEL["D":"^ICD9(",1:"^ICPT(")
- +7 if DIC="^ICD9("
- SET DIC("S")="I $$CSI^SCRPWICD(80,Y)="_$SELECT(SD("BDT")<SD("I10DTI"):1,1:30)
- +8 if SDSEL["L"
- DO LIST
- if SDSEL["R"
- DO RANGE
- SET SDNUL=0
- +9 if '$DATA(SDPAR(SDVAR))
- GOTO PAR
- SET SDPAR(SDVAR)=SDSEL_U_SDSEL(0)
- SET SD("LIST",$EXTRACT(SDSEL),$EXTRACT(SDSEL,2))=""
- +10 QUIT
- +11 ;
- LIST WRITE !
- FOR
- Begin DoDot:1
- +1 DO ^DIC
- IF $DATA(DUOUT)!$DATA(DTOUT)
- SET SDOUT=1
- QUIT
- +2 IF X=""
- SET SDNUL=1
- QUIT
- +3 IF Y>0
- Begin DoDot:2
- +4 SET Y(0)=$SELECT(SDSEL["D":$PIECE($$ICDDX^SCRPWICD(+Y),"^",2,99),1:$PIECE($$CPT^ICPTCOD(+Y,,1),"^",2,99))
- +5 SET SDPAR(SDVAR,$PIECE(Y,U))=$PIECE(Y(0),U)_" "_$PIECE(Y(0),U,$SELECT(SDSEL["D":3,1:2))
- End DoDot:2
- End DoDot:1
- if SDNUL!SDOUT
- QUIT
- +6 QUIT
- +7 ;
- RANGE WRITE !
- SET DIC("A")="From "_$SELECT(SDSEL["D":"ICD DIAGNOSIS: ",1:"CPT CODE: ")
- +1 DO ^DIC
- IF $DATA(DUOUT)!$DATA(DTOUT)
- SET SDOUT=1
- QUIT
- +2 IF X=""
- SET SDNUL=1
- QUIT
- +3 if Y<1
- QUIT
- +4 SET Y(0)=$SELECT(SDSEL["D":$PIECE($$ICDDX^SCRPWICD(+Y),"^",2,99),1:$PIECE($$CPT^ICPTCOD(+Y,,1),"^",2,99))
- +5 SET S1=$PIECE(Y(0),U)_" "_$PIECE(Y(0),U,$SELECT(SDSEL["D":3,1:2))
- SET SDPAR(SDVAR,S1)=$PIECE(Y,U)
- SET DIC("A")="To "_$PIECE(DIC("A")," ",2,99)
- R2 WRITE !
- DO ^DIC
- IF $DATA(DUOUT)!$DATA(DTOUT)
- SET SDOUT=1
- QUIT
- +1 IF X=""!(Y<1)
- SET SDNUL=1
- KILL SDPAR(SDVAR)
- QUIT
- +2 SET Y(0)=$SELECT(SDSEL["D":$PIECE($$ICDDX^SCRPWICD(+Y),"^",2,99),1:$PIECE($$CPT^ICPTCOD(+Y,,1),"^",2,99))
- +3 SET S2=$PIECE(Y(0),U)_" "_$PIECE(Y(0),U,$SELECT(SDSEL["D":3,1:2))
- +4 IF S1]S2
- WRITE !!,$CHAR(7),"Ending value must collate after beginning value!",!
- GOTO R2
- +5 SET SDPAR(SDVAR,S2)=$PIECE(Y,U)
- QUIT
- +6 ;
- CRI ;Prompt for element combination criteria
- +1 DO SUBT^SCRPW50("**** Search Element Combination Criteria ****")
- +2 WRITE !!," Specify letter combinations that represent how the search elements selected",!," above will be applied in evaluating patient activity (eg. ""ABC"" or ""ABC'D""):"
- +3 FOR SDII=1:1
- DO CRI1
- if SDOUT!SDNUL
- QUIT
- +4 QUIT
- +5 ;
- CRI1 KILL DIR
- SET DIR(0)="F"_$SELECT(SDII=1:"",1:"O")_"^1:40"
- SET DIR("A")=$SELECT(SDII=1:"IF",1:"OR")
- +1 SET DIR("?",1)="Enter a string that represents the method which represents how the selected"
- SET DIR("?",2)="search criteria items will be applied during evaluation (eg. ""AB"" indicates"
- +2 SET DIR("?",3)="that element 'A' and 'B' must be true for data to be returned. The apostrophy"
- SET DIR("?",4)="""'"" may be used to negate (or exclude) a sort item. For example, ""A'B"""
- +3 SET DIR("?")="will return data where element 'A' is true and element 'B' is not true."
- +4 WRITE !
- DO ^DIR
- IF $DATA(DTOUT)!$DATA(DUOUT)
- SET SDOUT=1
- QUIT
- +5 IF X=""
- SET SDNUL=1
- QUIT
- +6 IF $EXTRACT(X)="&"
- WRITE $CHAR(7)," ?? Invalid!"
- GOTO CRI1
- +7 FOR
- SET SDC=$EXTRACT(Y,$LENGTH(Y))
- if SDC'="'"
- QUIT
- SET Y=$EXTRACT(Y,1,($LENGTH(Y)-1))
- +8 IF '$LENGTH(Y)!$TRANSLATE($TRANSLATE(Y,"'",""),"&","")=""
- WRITE $CHAR(7),"No criteria selected!"
- GOTO CRI1
- +9 IF Y["'&"
- WRITE $CHAR(7)," ?? The value ""'&"" is incorrect syntax!"
- GOTO CRI1
- +10 IF Y["''"
- WRITE $CHAR(7)," ?? Character ""'"" appears redundantly!"
- GOTO CRI1
- +11 IF Y["&&"
- WRITE $CHAR(7)," ?? Character ""&"" appears redundantly!"
- GOTO CRI1
- +12 IF Y=""
- WRITE $CHAR(7),"No criteria selected!"
- GOTO CRI1
- +13 SET SDBAD=0
- SET SDSTR=""
- SET SDRESP=Y
- SET SDR=$TRANSLATE(Y,"&","")
- FOR SDIII=1:1:$LENGTH(SDR)
- SET SDC=$EXTRACT(SDR,SDIII)
- Begin DoDot:1
- +14 IF "&'"'[SDC
- IF $LENGTH(SDR,SDC)>2
- WRITE $CHAR(7)," ?? Element '"_SDC_"' appears redundantly!"
- SET SDBAD=1
- QUIT
- +15 IF SDC'="'"
- IF '$DATA(SDPAR(SDC))
- WRITE $CHAR(7)," ?? Character '"_SDC_"' is not recognized!"
- SET SDBAD=1
- QUIT
- +16 SET SDSTR=SDSTR_SDC_$SELECT(SDC'="'":"&",1:"")
- +17 QUIT
- End DoDot:1
- if SDBAD
- QUIT
- +18 if SDBAD
- GOTO CRI1
- +19 SET SDSTR=$EXTRACT(SDSTR,1,($LENGTH(SDSTR)-1))
- DO STR(SDSTR,.SDTX)
- MERGE SDCRI(SDSTR)=SDTX
- WRITE " ",$SELECT(SDII=1:"If ",1:"Or "),SDTX(1)
- SET SDIII=1
- FOR
- SET SDIII=$ORDER(SDTX(SDIII))
- if 'SDIII
- QUIT
- WRITE !?4,SDTX(SDIII)
- +20 QUIT
- +21 ;
- STR(SDSTR,SDTX) ;Convert combine logic into output text string
- +1 ;Required input: SDSTR=combine logic string
- +2 ;Required input: SDTX=array (pass by reference) to return text
- +3 NEW SDI,SDEXE,SDX
- +4 FOR SDI=1:1:$LENGTH(SDSTR)
- SET SDX(SDI)=$$STR1($EXTRACT(SDSTR,SDI))
- +5 SET SDOXE(2)="S SDLTH=75"
- SET SDLTH=71-$LENGTH(SDSTR)
- DO WRAP(.SDX,.SDTX,,.SDOXE,SDLTH,"")
- +6 QUIT
- +7 ;
- STR1(SDX) ;Convert to text (cont.)
- +1 ;Required input: SDX=character to transform
- +2 if SDX="&"
- QUIT "and "
- if SDX="'"
- QUIT "not "
- +3 QUIT $PIECE(SDPAR(SDX),U,2)_" '"_SDX_"' "
- +4 ;
- APF ;Select additional print fields
- +1 DO SUBT^SCRPW50("Select additional print fields for patient detail: (optional)")
- +2 KILL DIR
- SET DIR("A")="Specify additional print field"
- SET DIR("?")="These fields will be included in the patient detail list output."
- +3 SET S1=$$DIR^SCRPW23(.DIR,1,"","","O",SDD)
- if SDOUT!SDNUL
- QUIT
- +4 KILL DIR
- SET DIR("A")="Select "_$PIECE(S1,U,2)_" category"
- SET S2=$$DIR^SCRPW23(.DIR,2,"",$PIECE(S1,U),"O",SDD,1)
- if SDOUT
- QUIT
- IF SDNUL
- SET SDNUL=0
- QUIT
- +5 SET SDSEL=$PIECE(S1,U)_$PIECE(S2,U)
- if $DATA(SDAPF("PFX",SDSEL))
- GOTO PFD
- +6 SET SDS1=$PIECE(^TMP("SCRPW",$JOB,"ACT",SDSEL),T,11)
- SET SDS2=$ORDER(SDAPF(SDS1,""),-1)+1
- SET SDAPF(SDS1,SDS2)=SDSEL_U_$PIECE(S1,U,2)_U_$PIECE(S2,U,2)
- SET SDAPF("PFX",SDSEL,SDS1,SDS2)=""
- +7 QUIT
- +8 ;
- PFD NEW DIR
- SET DIR(0)="Y"
- SET DIR("A")="This item is already selected as a print field, do you want to delete it"
- SET DIR("B")="NO"
- DO ^DIR
- if $DATA(DTOUT)!$DATA(DUOUT)
- QUIT
- +1 IF Y
- SET S1=$ORDER(SDAPF("PFX",SDSEL,""))
- SET S2=$ORDER(SDAPF("PFX",SDSEL,S1,""))
- KILL SDAPF("SDX",SDSEL),SDAPF("PF",S1,S2)
- WRITE !,"deleted..."
- +2 QUIT
- +3 ;
- WRAP(SDITX,SDOTX,SDIXE,SDOXE,SDLTH,SDUJC) ;Text wrapper
- +1 ;Required input: SDITX=array (passed by reference) of text to be reformatted
- +2 ;Required input: SDOTX=array (passed by reference) to return reformatted text
- +3 ;Optional input: SDIXE=array (passed by reference) where SDIXE(n) is code to be executed prior to processing node SDITX(n)
- +4 ;Optional input: SDOXE=array (passed by reference) where SDOXE(n) is code to be executed prior to creating node SDOTX(n)
- +5 ;Optional input: SDLTH=line length, if not defined, SDLTH=IOM
- +6 ;Optional input: SDUJC=value (0-5 characters) to be inserted when values are joined, if undefined AQKUJC=" "
- +7 ;Output: Reformats values found in SDITX() array into wraparound text in SDOTX() of SDLTH length (10-255) characters
- +8 ;
- +9 NEW SDUI,SDUII,X,X1,X2,X3,X4,Y,Y1,Y2,SDLAST,SDUIII,SDUIV,SDTXB
- +10 if $DATA(SDITX)'>1
- QUIT
- if '$DATA(SDUJC)
- SET SDUJC=" "
- if $GET(SDLTH)<10!($GET(SDLTH)>255)
- SET SDLTH=IOM
- KILL SDOTX
- SET SDUJC=$EXTRACT(SDUJC,1,5)
- SET SDUI=""
- SET SDUII=1
- SET SDOTX(1)=""
- SET SDLAST=$ORDER(SDITX(""),-1)
- DO POX
- +11 FOR
- SET SDUI=$ORDER(SDITX(SDUI))
- if SDUI']""
- QUIT
- IF $LENGTH(SDITX(SDUI))
- DO PIX
- SET X=SDITX(SDUI)_$SELECT(SDUI'=SDLAST:SDUJC,1:"")
- DO MOVE
- +12 QUIT
- +13 ;
- PIX IF $DATA(SDIXE(SDUI))
- XECUTE SDIXE(SDUI)
- +1 QUIT
- +2 ;
- POX IF $DATA(SDOXE(SDUII))
- XECUTE SDOXE(SDUII)
- +1 QUIT
- MOVE SET X1=$LENGTH(X)
- if 'X1
- QUIT
- SET X2=$LENGTH(X," ")
- SET Y=SDOTX(SDUII)
- SET Y1=$LENGTH(Y)
- SET Y2=SDLTH-Y1
- IF 'Y2
- DO INCR
- GOTO MOVE
- +1 IF X1'>Y2
- SET SDOTX(SDUII)=SDOTX(SDUII)_X
- QUIT
- MOVE1 IF X'[" "
- IF X1'>SDLTH
- if Y1
- DO INCR
- SET SDOTX(SDUII)=X
- QUIT
- MOVE2 IF X'[" "
- IF X1>SDLTH
- if Y1
- DO INCR
- SET SDOTX(SDUII)=$EXTRACT(X,1,SDLTH)
- SET X=$EXTRACT(X,(SDLTH+1),999)
- GOTO MOVE
- +1 SET X3=$LENGTH($PIECE(X," "))
- IF X3=Y2
- SET SDOTX(SDUII)=SDOTX(SDUII)_$PIECE(X," ")
- SET X=$PIECE(X," ",2,999)
- GOTO MOVE
- +2 IF X3>Y2
- IF X3'>SDLTH
- DO INCR
- GOTO MOVE
- +3 IF X3>SDLTH
- if Y1
- DO INCR
- SET SDOTX(SDUII)=$EXTRACT(X,1,SDLTH)
- SET X=$EXTRACT(X,(SDLTH+1),999)
- GOTO MOVE
- MOVE3 KILL SDTXB
- FOR SDUIII=1:1:X2
- SET X4=999-$LENGTH($PIECE(X," ",1,SDUIII))
- SET SDTXB(X4,SDUIII)=""
- +1 SET SDUIII=$ORDER(SDTXB(998-Y2))
- SET SDUIV=$ORDER(SDTXB(SDUIII,0))
- SET SDOTX(SDUII)=SDOTX(SDUII)_$EXTRACT(X,1,($LENGTH($PIECE(X," ",1,SDUIV))+1))
- SET X=$PIECE(X," ",(SDUIV+1),999)
- GOTO MOVE
- +2 QUIT
- +3 ;
- INCR SET SDUII=SDUII+1
- SET SDOTX(SDUII)=""
- DO POX
- QUIT