SCRPW23 ;RENO/KEITH - ACRP Ad Hoc Report (cont.) ;15 Jul 98 02:38PM
;;5.3;Scheduling;**144,474,593**;AUG 13, 1993;Build 13
DIRB(SDFL) ;Get default values for range
;Required input: SDFL="F" for first, "L" for last
N SDX S SDX=$O(SDPAR("X",SDS2,$S(SDDV:5,1:4),""),$S(SDFL="F":1,1:-1)) Q $S(SDX=""!'SDDV:SDX,1:SDPAR("X",SDS2,5,SDX))
;
RL ;Prompt for range or list
N SDI,SDIRQ,SDCSYS X:$L($P(SDACT,T,9)) $P(SDACT,T,9) S SDDV=0 S:$P(SDACT,T,2)="D" SDDV=1,SDPAR("X",SDS2,6)="D"
I $P(SDPAR("X",SDS2,2),U)="N" D NULL Q
I ($P(SDACT,T,2)="P"),($P(SDACT,T,3)="^ICD9(") S SDCSYS=$$ICDSYS()
I $P(SDPAR("X",SDS2,2),U)="L" D LST Q
RNG N SDR1,SDR2 D SUBT^SCRPW50("*** Item Range Selection ***")
R1 W !!,"Start with:" S SDR1=$$SEL($P(SDACT,T,2),$$DIRB("F")) Q:SDOUT!SDNUL
S SDR2=$O(SDPAR("X",SDS2,$S(SDDV:5,1:4),""),-1) I $L(SDR2),$P(SDR1,U,$S(SDDV:1,1:2))]SDR2 F SDI=SDS1,"X" K SDPAR(SDI,SDS2,$S(SDDV:5,1:4),SDR2)
R2 W !!,"End with:" S SDR2=$$SEL($P(SDACT,T,2),$$DIRB("L")) Q:SDOUT!SDNUL
I '$$RCOL() W !!,$C(7),"End value must collate after start value!" G R2
F SDX="SDR1","SDR2" S SDPAR("X",SDS2,4,$P(@SDX,U,2),$P(@SDX,U))=""
F SDX="SDR1","SDR2" S SDPAR("X",SDS2,5,$P(@SDX,U))=$P(@SDX,U,2)
Q
;
ICDSYS() ;Prompt for coding system. (Structurally similar to $$RL^SCRPW22.)
N IEN,CSYS,I10DTI,I10DTE
I $D(SDPAR("X",SDS2,4)) D I 1
. S IEN=$O(SDPAR("X",SDS2,5,"")) Q:IEN=""
. S CSYS=$$CSI^SCRPWICD(80,IEN)
E I SDS1="P" D I 1
. S Y=$$IMP^SCRPWICD(30) S I10DTI=Y X ^DD("DD") S I10DTE=Y
. K DIR S DIR(0)="S^9:ICD-9 (PRIOR TO "_I10DTE_");10:ICD-10 ("_I10DTE_" AND AFTER)"
. S DIR("A")="Select coding system" S DIR("B")=$S(DT'<I10DTI:"10",1:"9")
. D ^DIR K DIR S CSYS=$S($P(Y,U,1)="9":1,$P(Y,U,1)="10":30,1:$S(DT<I10DTI:1,1:30))
E I SDS1="L" D I 1
. S CSYS=$S($P(SDPAR("L",1),U,1)<$$IMP^SCRPWICD(30):1,1:30)
Q CSYS
;
RCOL() ;Determine range collation validity
;Output: 1=valid, 0=invalid
I $P(SDR1,U,2)=+$P(SDR1,U,2),$P(SDR2,U,2)=+$P(SDR2,U,2) Q SDR1'>SDR2
I SDDV Q $P(SDR1,U)'>$P(SDR2,U)
Q $P(SDR1,U,2)']$P(SDR2,U,2)
;
NULL ;Set list for null value
S SDPAR("X",SDS2,4,"~~~NONE~~~","~~~NONE~~~")="",SDPAR("X",SDS2,5,"~~~NONE~~~")="~~~NONE~~~" Q
;
LST I $D(SDPAR("X",SDS2,4)) D LST1
D SUBT^SCRPW50("*** Item List Selection ***") W !
F I=1:1:$P(SDACT,T,6) S SDX=$$SEL($P(SDACT,T,2)) Q:SDOUT!SDNUL D LST0
Q
;
LST0 I $D(SDPAR("X",SDS2,5,$P(SDX,U))) Q:$$LSD()
S SDPAR("X",SDS2,4,$P(SDX,U,2),$P(SDX,U))=""
S SDPAR("X",SDS2,5,$P(SDX,U))=$P(SDX,U,2)
Q
;
LSD() N DIR W !!,$C(7),$P(SDX,U,2)," is already selected." S DIR(0)="Y",DIR("A")="Do you want to delete it",DIR("B")="NO" D ^DIR I $D(DTOUT)!$D(DUOUT) S SDOUT=1 Q 0
I Y D W !," ...deleted." Q 1
.F SDI=SDS1,"X" K SDPAR(SDI,SDS2,5,$P(SDX,U)),SDPAR(SDI,SDS2,4,$P(SDX,U,2),$P(SDX,U))
.Q
Q 0
;
LST1 ;List existing item selections
N SDOUT,SDL,SDX S SDOUT=0,SDL=1,SDX="" W !,"Items currently selected:"
F S SDX=$O(SDPAR("X",SDS2,4,SDX)) Q:SDX=""!SDOUT S SDL=SDL+1 W !?5,SDX D:SDL>15 WAIT^SCRPW22
Q
;
SEL(SDTYP,SDIRB) ;Select items for list or range
;Required input: SDTYP=type of data (D, P, F, N, T, C, PP, S)
;Optional input: SDIRB=value for default prompt
N SDX S SDX="" D @SDTYP Q SDX
;
D ;Get date values
N DIR M DIR=SDIRQ S DIR(0)=$P(SDACT,T,4),DIR("A")="Select "_$P(SDACT,T) S:$L($G(SDIRB)) DIR("B")=SDIRB D ^DIR I $D(DTOUT)!$D(DUOUT) S SDOUT=1 Q
I '$L(Y) S SDNUL=1 Q
S SDX=Y X ^DD("DD") S SDX=SDX_U_Y X:$L($P(SDACT,T,8)) $P(SDACT,T,8) Q
;
P ;Get pointer values ;SD*5.3*474 added PSCRN to screen certain status types
N DIC M DIC=SDIRQ S DIC=$P(SDACT,T,3),DIC(0)="AEMQ",DIC("S")=$P(SDACT,T,4) K:'$L(DIC("S")) DIC("S") D PSCRN D ^DIC I $D(DTOUT)!$D(DUOUT) S SDOUT=1 Q
I Y'>0 S SDNUL=1 Q
S SDX=Y X:$L($P(SDACT,T,8)) $P(SDACT,T,8) Q
;
PSCRN ;screen out the 4 cancellation type status' SD*5.3*474
I DIC="^SD(409.63," S DIC("S")="I $P(^(0),U,2)'=""C"",$P(^(0),U,2)'=""CA"",$P(^(0),U,2)'=""PC"",$P(^(0),U,2)'=""PCA"""
I DIC="^ICD9(" S DIC("S")="I $$CSI^SCRPWICD(80,Y)="_SDCSYS
Q
;
F ;Get field values
N DIR M DIR=SDIRQ S DIR(0)=$P(SDACT,T,3) S:$L($G(SDIRB)) DIR("B")=SDIRB D ^DIR I $D(DTOUT)!$D(DUOUT) S SDOUT=1 Q
I '$D(DIR("B")),X="" S SDNUL=1 Q
S SDX=Y_U_$G(Y(0)) X:$L($P(SDACT,T,8)) $P(SDACT,T,8) Q
;
N ;Get number value
N DIR M DIR=SDIRQ S DIR(0)=$P(SDACT,T,4),DIR("A")="Select "_$P(SDACT,T) S:$L($G(SDIRB)) DIR("B")=SDIRB D ^DIR I $D(DTOUT)!$D(DUOUT) S SDOUT=1 Q
I Y'?1.N S SDNUL=1 Q
S SDX=Y_U_Y X:$L($P(SDACT,T,8)) $P(SDACT,T,8) Q
;
T ;Get text value
N DIR M DIR=SDIRQ S DIR(0)=$P(SDACT,T,4),DIR("A")="Select "_$P(SDACT,T) S:$L($G(SDIRB)) DIR("B")=SDIRB D ^DIR I $D(DTOUT)!$D(DUOUT) S SDOUT=1 Q
I '$L(Y) S SDNUL=1 Q
S SDX=Y_U_Y X:$L($P(SDACT,T,8)) $P(SDACT,T,8) Q
;
C ;Get computed value
D @($P(SDACT,T,4)) X:$L($P(SDACT,T,8)) $P(SDACT,T,8) Q
;
PP ;Get pointer value from file multiple
N DIC M DIC=SDIRQ S DIC=$P($P(SDACT,T,3),";"),DIC(0)="AEMQ",DIC("B")=$P($G(SDIRB),";") K:'$L(DIC("B")) DIC("B") D ^DIC I $D(DTOUT)!$D(DUOUT) S SDOUT=1 Q
I Y<1 S SDNUL=1 Q
S SDX=Y,DIC=DIC_+SDX_$P($P(SDACT,T,3),";",2),DIC("B")=$P($G(SDIRB),";",2) K:'$L(DIC("B")) DIC("B") D ^DIC I $D(DTOUT)!$D(DUOUT) S SDX="",SDOUT=1 Q
I Y<1 S SDX="",SDNUL=1 Q
S SDX=+SDX_";"_+Y_U_$P(SDX,U,2)_" / "_$P(Y,U,2) X:$L($P(SDACT,T,8)) $P(SDACT,T,8) Q
;
S ;Get set-of-codes value
N DIR M DIR=SDIRQ X $P(SDACT,T,3) S DIR("A")="Select "_$P(SDACT,T) S:$L($G(SDIRB)) DIR("B")=SDIRB D ^DIR I $D(DTOUT)!$D(DUOUT) S SDOUT=1 Q
I '$L(Y) S SDNUL=1 Q
S SDX=Y_U_Y(0) X:$L($P(SDACT,T,8)) $P(SDACT,T,8) Q
;
VCP(SDX) ;Validate Stop Code credit pair
;Required input: SDX=6 digit numeric value
;Output: 1=valid credit pair, 0=invalid credit pair
G:SDX'?6N VCPQ G:'$D(^DIC(40.7,"C",$E(SDX,1,3))) VCPQ G:'$D(^DIC(40.7,"C",$E(SDX,4,6)))&($E(SDX,4,6)'="000") VCPQ
Q 1
;
VCPQ W $C(7)," ??",!,"This response must be a 6 digit numeric value",!,"that represents two valid stop codes!" Q 0
;
PLIST ;Print category list
N ZTSAVE D EN^XUTMDEVQ("PLST^SCRPW23","CATEGORY LIST",.ZTSAVE) Q
PLST ;Print category list
D:'$D(^TMP("SCRPW",$J,"SEL")) BLD^SCRPW21
S I=0 F S I=$O(^TMP("SCRPW",$J,"SEL",1,I)) Q:'I S X1=$O(^TMP("SCRPW",$J,"SEL",1,I,"")) W !!,$P(^TMP("SCRPW",$J,"SEL",1,I,X1),"~") D PLST1
K I,II,X1,X2,^TMP("SCRPW",$J) Q
;
PLST1 S II=0 F S II=$O(^TMP("SCRPW",$J,"SEL",2,X1,II)) Q:'II S X2=$O(^TMP("SCRPW",$J,"SEL",2,X1,II,"")) W !?4,$P(^TMP("SCRPW",$J,"SEL",2,X1,II,X2),"~")
Q
;
DISP0 ;Return to full screen scrolling
Q:$E(IOST)'="C"
D ENS^%ZISS S SDRM=^%ZOSF("RM"),SDXY=^%ZOSF("XY"),(IOTM,IOBM)=0 W $$XY(IOSTBM,1),@IOF N DX,DY,X S (DX,DY)=0 X SDXY S X=IOM X SDRM Q
;
DISP(SDTOP,SDBOT) ;Create centered scrolling region
;Required input: SDTOP=text to center at top of screen
;Required input: SDBOT(n)=numbered array of text to display at bottom of screen
N X D DISP0 S X=0 X SDRM W $$XY(IORVON) F I=1:1:(78-$L(SDTOP)\2) W "-"
W " ",SDTOP," " F W "-" Q:$X>79
W $$XY(IORVOFF) S IOTM=3 W $$XY(IOSTBM,1) S (C,I)="" F S I=$O(SDBOT(I)) Q:I="" S C=C+1
F W ! Q:$Y>(IOSL-C)
S II=$O(SDBOT("")) Q:II="" W $$XY(IORVON) F I=1:1:(78-$L(SDBOT(II))\2) W "-"
W " ",SDBOT(II)," " F W "-" Q:$X>79
W $$XY(IORVOFF) F S II=$O(SDBOT(II)) Q:II="" W !,$E(SDBOT(II),1,80)
S IOBM=(IOSL-C-1) W $$XY(IOSTBM,1) Q
;
XY(X,SDI) ;Maintain $X, $Y
;Required input: X=screen handling variable to write
;Optional input: SDI=1 (to specify the use of indirection)
N DX,DY S DX=$X,DY=$Y
I $G(SDI) W @X X SDXY Q ""
W X X SDXY Q ""
;
DIR(DIR,SDLEV,SDEXE,SDS,SDO,SDPFL,SDA) ;Ask questions!
;Required input: DIR array (pass by reference)
;Required input: SDLEV=level to build DIR(0) for large sets
;Optional input: SDEXE=code to execute prior to ^DIR
;Optional input: SDS=subscript lookup value for level 2 (required for level 2)
;Optional input: SDO="O" to indicate input is optional
;Optional input: SDPFL=print field level (1,2) for print field prompts
;Optional input: SDA=1 to force single item selection prompt
X:$L($G(SDEXE)) SDEXE I '$D(DIR(0)) D @("DIR"_SDLEV)
I '$G(SDA),$E(DIR(0))="S",$L(DIR(0),":")=2 Q $P($P(DIR(0),U,2),":")_U_$P(DIR(0),":",2)
D ^DIR I $D(DTOUT)!$D(DUOUT) S SDOUT=1 Q ""
I X="" S SDNUL=1 Q ""
Q Y_U_$S($L($G(Y(0))):Y(0),1:Y)
;
DIR1 N X,I,II S X="",I=0 F S I=$O(^TMP("SCRPW",$J,"SEL",1,I)) Q:'I S II="" F S II=$O(^TMP("SCRPW",$J,"SEL",1,I,II)) Q:II="" S:$$PFL1() X=X_";"_II_":"_$P(^TMP("SCRPW",$J,"SEL",1,I,II),T)
S DIR(0)="S"_$G(SDO)_"^"_$E(X,2,245) Q
;
DIR2 N X,I,II S X="",I=0 F S I=$O(^TMP("SCRPW",$J,"SEL",2,SDS,I)) Q:'I S II="" F S II=$O(^TMP("SCRPW",$J,"SEL",2,SDS,I,II)) Q:II="" S:$$PFL2() X=X_";"_II_":"_$P(^TMP("SCRPW",$J,"SEL",2,SDS,I,II),T)
S DIR(0)="S"_$G(SDO)_"^"_$E(X,2,245) Q
;
PFL1() ;Print field level 1 evaluator
Q:'$G(SDPFL) 1
Q $P(^TMP("SCRPW",$J,"SEL",1,I,II),T,2)>(SDPFL-1)
;
PFL2() ;Print field level 2 evaluator
Q:'$G(SDPFL) 1
Q $P(^TMP("SCRPW",$J,"SEL",2,SDS,I,II),T,2)>(SDPFL-1)
;
DIRB1(S1,S2,SDEF) ;Set DIR("B")
;Required input: S1, S2=subscript values
;Optional input: SDEF=default value
S DIR("B")=$S($D(SDPAR(S1,S2)):$P(SDPAR(S1,S2),U,2),1:$G(SDEF))
K:'$L(DIR("B")) DIR("B") Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCRPW23 9222 printed Dec 13, 2024@02:43:26 Page 2
SCRPW23 ;RENO/KEITH - ACRP Ad Hoc Report (cont.) ;15 Jul 98 02:38PM
+1 ;;5.3;Scheduling;**144,474,593**;AUG 13, 1993;Build 13
DIRB(SDFL) ;Get default values for range
+1 ;Required input: SDFL="F" for first, "L" for last
+2 NEW SDX
SET SDX=$ORDER(SDPAR("X",SDS2,$SELECT(SDDV:5,1:4),""),$SELECT(SDFL="F":1,1:-1))
QUIT $SELECT(SDX=""!'SDDV:SDX,1:SDPAR("X",SDS2,5,SDX))
+3 ;
RL ;Prompt for range or list
+1 NEW SDI,SDIRQ,SDCSYS
if $LENGTH($PIECE(SDACT,T,9))
XECUTE $PIECE(SDACT,T,9)
SET SDDV=0
if $PIECE(SDACT,T,2)="D"
SET SDDV=1
SET SDPAR("X",SDS2,6)="D"
+2 IF $PIECE(SDPAR("X",SDS2,2),U)="N"
DO NULL
QUIT
+3 IF ($PIECE(SDACT,T,2)="P")
IF ($PIECE(SDACT,T,3)="^ICD9(")
SET SDCSYS=$$ICDSYS()
+4 IF $PIECE(SDPAR("X",SDS2,2),U)="L"
DO LST
QUIT
RNG NEW SDR1,SDR2
DO SUBT^SCRPW50("*** Item Range Selection ***")
R1 WRITE !!,"Start with:"
SET SDR1=$$SEL($PIECE(SDACT,T,2),$$DIRB("F"))
if SDOUT!SDNUL
QUIT
+1 SET SDR2=$ORDER(SDPAR("X",SDS2,$SELECT(SDDV:5,1:4),""),-1)
IF $LENGTH(SDR2)
IF $PIECE(SDR1,U,$SELECT(SDDV:1,1:2))]SDR2
FOR SDI=SDS1,"X"
KILL SDPAR(SDI,SDS2,$SELECT(SDDV:5,1:4),SDR2)
R2 WRITE !!,"End with:"
SET SDR2=$$SEL($PIECE(SDACT,T,2),$$DIRB("L"))
if SDOUT!SDNUL
QUIT
+1 IF '$$RCOL()
WRITE !!,$CHAR(7),"End value must collate after start value!"
GOTO R2
+2 FOR SDX="SDR1","SDR2"
SET SDPAR("X",SDS2,4,$PIECE(@SDX,U,2),$PIECE(@SDX,U))=""
+3 FOR SDX="SDR1","SDR2"
SET SDPAR("X",SDS2,5,$PIECE(@SDX,U))=$PIECE(@SDX,U,2)
+4 QUIT
+5 ;
ICDSYS() ;Prompt for coding system. (Structurally similar to $$RL^SCRPW22.)
+1 NEW IEN,CSYS,I10DTI,I10DTE
+2 IF $DATA(SDPAR("X",SDS2,4))
Begin DoDot:1
+3 SET IEN=$ORDER(SDPAR("X",SDS2,5,""))
if IEN=""
QUIT
+4 SET CSYS=$$CSI^SCRPWICD(80,IEN)
End DoDot:1
IF 1
+5 IF '$TEST
IF SDS1="P"
Begin DoDot:1
+6 SET Y=$$IMP^SCRPWICD(30)
SET I10DTI=Y
XECUTE ^DD("DD")
SET I10DTE=Y
+7 KILL DIR
SET DIR(0)="S^9:ICD-9 (PRIOR TO "_I10DTE_");10:ICD-10 ("_I10DTE_" AND AFTER)"
+8 SET DIR("A")="Select coding system"
SET DIR("B")=$SELECT(DT'<I10DTI:"10",1:"9")
+9 DO ^DIR
KILL DIR
SET CSYS=$SELECT($PIECE(Y,U,1)="9":1,$PIECE(Y,U,1)="10":30,1:$SELECT(DT<I10DTI:1,1:30))
End DoDot:1
IF 1
+10 IF '$TEST
IF SDS1="L"
Begin DoDot:1
+11 SET CSYS=$SELECT($PIECE(SDPAR("L",1),U,1)<$$IMP^SCRPWICD(30):1,1:30)
End DoDot:1
IF 1
+12 QUIT CSYS
+13 ;
RCOL() ;Determine range collation validity
+1 ;Output: 1=valid, 0=invalid
+2 IF $PIECE(SDR1,U,2)=+$PIECE(SDR1,U,2)
IF $PIECE(SDR2,U,2)=+$PIECE(SDR2,U,2)
QUIT SDR1'>SDR2
+3 IF SDDV
QUIT $PIECE(SDR1,U)'>$PIECE(SDR2,U)
+4 QUIT $PIECE(SDR1,U,2)']$PIECE(SDR2,U,2)
+5 ;
NULL ;Set list for null value
+1 SET SDPAR("X",SDS2,4,"~~~NONE~~~","~~~NONE~~~")=""
SET SDPAR("X",SDS2,5,"~~~NONE~~~")="~~~NONE~~~"
QUIT
+2 ;
LST IF $DATA(SDPAR("X",SDS2,4))
DO LST1
+1 DO SUBT^SCRPW50("*** Item List Selection ***")
WRITE !
+2 FOR I=1:1:$PIECE(SDACT,T,6)
SET SDX=$$SEL($PIECE(SDACT,T,2))
if SDOUT!SDNUL
QUIT
DO LST0
+3 QUIT
+4 ;
LST0 IF $DATA(SDPAR("X",SDS2,5,$PIECE(SDX,U)))
if $$LSD()
QUIT
+1 SET SDPAR("X",SDS2,4,$PIECE(SDX,U,2),$PIECE(SDX,U))=""
+2 SET SDPAR("X",SDS2,5,$PIECE(SDX,U))=$PIECE(SDX,U,2)
+3 QUIT
+4 ;
LSD() NEW DIR
WRITE !!,$CHAR(7),$PIECE(SDX,U,2)," is already selected."
SET DIR(0)="Y"
SET DIR("A")="Do you want to delete it"
SET DIR("B")="NO"
DO ^DIR
IF $DATA(DTOUT)!$DATA(DUOUT)
SET SDOUT=1
QUIT 0
+1 IF Y
Begin DoDot:1
+2 FOR SDI=SDS1,"X"
KILL SDPAR(SDI,SDS2,5,$PIECE(SDX,U)),SDPAR(SDI,SDS2,4,$PIECE(SDX,U,2),$PIECE(SDX,U))
+3 QUIT
End DoDot:1
WRITE !," ...deleted."
QUIT 1
+4 QUIT 0
+5 ;
LST1 ;List existing item selections
+1 NEW SDOUT,SDL,SDX
SET SDOUT=0
SET SDL=1
SET SDX=""
WRITE !,"Items currently selected:"
+2 FOR
SET SDX=$ORDER(SDPAR("X",SDS2,4,SDX))
if SDX=""!SDOUT
QUIT
SET SDL=SDL+1
WRITE !?5,SDX
if SDL>15
DO WAIT^SCRPW22
+3 QUIT
+4 ;
SEL(SDTYP,SDIRB) ;Select items for list or range
+1 ;Required input: SDTYP=type of data (D, P, F, N, T, C, PP, S)
+2 ;Optional input: SDIRB=value for default prompt
+3 NEW SDX
SET SDX=""
DO @SDTYP
QUIT SDX
+4 ;
D ;Get date values
+1 NEW DIR
MERGE DIR=SDIRQ
SET DIR(0)=$PIECE(SDACT,T,4)
SET DIR("A")="Select "_$PIECE(SDACT,T)
if $LENGTH($GET(SDIRB))
SET DIR("B")=SDIRB
DO ^DIR
IF $DATA(DTOUT)!$DATA(DUOUT)
SET SDOUT=1
QUIT
+2 IF '$LENGTH(Y)
SET SDNUL=1
QUIT
+3 SET SDX=Y
XECUTE ^DD("DD")
SET SDX=SDX_U_Y
if $LENGTH($PIECE(SDACT,T,8))
XECUTE $PIECE(SDACT,T,8)
QUIT
+4 ;
P ;Get pointer values ;SD*5.3*474 added PSCRN to screen certain status types
+1 NEW DIC
MERGE DIC=SDIRQ
SET DIC=$PIECE(SDACT,T,3)
SET DIC(0)="AEMQ"
SET DIC("S")=$PIECE(SDACT,T,4)
if '$LENGTH(DIC("S"))
KILL DIC("S")
DO PSCRN
DO ^DIC
IF $DATA(DTOUT)!$DATA(DUOUT)
SET SDOUT=1
QUIT
+2 IF Y'>0
SET SDNUL=1
QUIT
+3 SET SDX=Y
if $LENGTH($PIECE(SDACT,T,8))
XECUTE $PIECE(SDACT,T,8)
QUIT
+4 ;
PSCRN ;screen out the 4 cancellation type status' SD*5.3*474
+1 IF DIC="^SD(409.63,"
SET DIC("S")="I $P(^(0),U,2)'=""C"",$P(^(0),U,2)'=""CA"",$P(^(0),U,2)'=""PC"",$P(^(0),U,2)'=""PCA"""
+2 IF DIC="^ICD9("
SET DIC("S")="I $$CSI^SCRPWICD(80,Y)="_SDCSYS
+3 QUIT
+4 ;
F ;Get field values
+1 NEW DIR
MERGE DIR=SDIRQ
SET DIR(0)=$PIECE(SDACT,T,3)
if $LENGTH($GET(SDIRB))
SET DIR("B")=SDIRB
DO ^DIR
IF $DATA(DTOUT)!$DATA(DUOUT)
SET SDOUT=1
QUIT
+2 IF '$DATA(DIR("B"))
IF X=""
SET SDNUL=1
QUIT
+3 SET SDX=Y_U_$GET(Y(0))
if $LENGTH($PIECE(SDACT,T,8))
XECUTE $PIECE(SDACT,T,8)
QUIT
+4 ;
N ;Get number value
+1 NEW DIR
MERGE DIR=SDIRQ
SET DIR(0)=$PIECE(SDACT,T,4)
SET DIR("A")="Select "_$PIECE(SDACT,T)
if $LENGTH($GET(SDIRB))
SET DIR("B")=SDIRB
DO ^DIR
IF $DATA(DTOUT)!$DATA(DUOUT)
SET SDOUT=1
QUIT
+2 IF Y'?1.N
SET SDNUL=1
QUIT
+3 SET SDX=Y_U_Y
if $LENGTH($PIECE(SDACT,T,8))
XECUTE $PIECE(SDACT,T,8)
QUIT
+4 ;
T ;Get text value
+1 NEW DIR
MERGE DIR=SDIRQ
SET DIR(0)=$PIECE(SDACT,T,4)
SET DIR("A")="Select "_$PIECE(SDACT,T)
if $LENGTH($GET(SDIRB))
SET DIR("B")=SDIRB
DO ^DIR
IF $DATA(DTOUT)!$DATA(DUOUT)
SET SDOUT=1
QUIT
+2 IF '$LENGTH(Y)
SET SDNUL=1
QUIT
+3 SET SDX=Y_U_Y
if $LENGTH($PIECE(SDACT,T,8))
XECUTE $PIECE(SDACT,T,8)
QUIT
+4 ;
C ;Get computed value
+1 DO @($PIECE(SDACT,T,4))
if $LENGTH($PIECE(SDACT,T,8))
XECUTE $PIECE(SDACT,T,8)
QUIT
+2 ;
PP ;Get pointer value from file multiple
+1 NEW DIC
MERGE DIC=SDIRQ
SET DIC=$PIECE($PIECE(SDACT,T,3),";")
SET DIC(0)="AEMQ"
SET DIC("B")=$PIECE($GET(SDIRB),";")
if '$LENGTH(DIC("B"))
KILL DIC("B")
DO ^DIC
IF $DATA(DTOUT)!$DATA(DUOUT)
SET SDOUT=1
QUIT
+2 IF Y<1
SET SDNUL=1
QUIT
+3 SET SDX=Y
SET DIC=DIC_+SDX_$PIECE($PIECE(SDACT,T,3),";",2)
SET DIC("B")=$PIECE($GET(SDIRB),";",2)
if '$LENGTH(DIC("B"))
KILL DIC("B")
DO ^DIC
IF $DATA(DTOUT)!$DATA(DUOUT)
SET SDX=""
SET SDOUT=1
QUIT
+4 IF Y<1
SET SDX=""
SET SDNUL=1
QUIT
+5 SET SDX=+SDX_";"_+Y_U_$PIECE(SDX,U,2)_" / "_$PIECE(Y,U,2)
if $LENGTH($PIECE(SDACT,T,8))
XECUTE $PIECE(SDACT,T,8)
QUIT
+6 ;
S ;Get set-of-codes value
+1 NEW DIR
MERGE DIR=SDIRQ
XECUTE $PIECE(SDACT,T,3)
SET DIR("A")="Select "_$PIECE(SDACT,T)
if $LENGTH($GET(SDIRB))
SET DIR("B")=SDIRB
DO ^DIR
IF $DATA(DTOUT)!$DATA(DUOUT)
SET SDOUT=1
QUIT
+2 IF '$LENGTH(Y)
SET SDNUL=1
QUIT
+3 SET SDX=Y_U_Y(0)
if $LENGTH($PIECE(SDACT,T,8))
XECUTE $PIECE(SDACT,T,8)
QUIT
+4 ;
VCP(SDX) ;Validate Stop Code credit pair
+1 ;Required input: SDX=6 digit numeric value
+2 ;Output: 1=valid credit pair, 0=invalid credit pair
+3 if SDX'?6N
GOTO VCPQ
if '$DATA(^DIC(40.7,"C",$EXTRACT(SDX,1,3)))
GOTO VCPQ
if '$DATA(^DIC(40.7,"C",$EXTRACT(SDX,4,6)))&($EXTRACT(SDX,4,6)'="000")
GOTO VCPQ
+4 QUIT 1
+5 ;
VCPQ WRITE $CHAR(7)," ??",!,"This response must be a 6 digit numeric value",!,"that represents two valid stop codes!"
QUIT 0
+1 ;
PLIST ;Print category list
+1 NEW ZTSAVE
DO EN^XUTMDEVQ("PLST^SCRPW23","CATEGORY LIST",.ZTSAVE)
QUIT
PLST ;Print category list
+1 if '$DATA(^TMP("SCRPW",$JOB,"SEL"))
DO BLD^SCRPW21
+2 SET I=0
FOR
SET I=$ORDER(^TMP("SCRPW",$JOB,"SEL",1,I))
if 'I
QUIT
SET X1=$ORDER(^TMP("SCRPW",$JOB,"SEL",1,I,""))
WRITE !!,$PIECE(^TMP("SCRPW",$JOB,"SEL",1,I,X1),"~")
DO PLST1
+3 KILL I,II,X1,X2,^TMP("SCRPW",$JOB)
QUIT
+4 ;
PLST1 SET II=0
FOR
SET II=$ORDER(^TMP("SCRPW",$JOB,"SEL",2,X1,II))
if 'II
QUIT
SET X2=$ORDER(^TMP("SCRPW",$JOB,"SEL",2,X1,II,""))
WRITE !?4,$PIECE(^TMP("SCRPW",$JOB,"SEL",2,X1,II,X2),"~")
+1 QUIT
+2 ;
DISP0 ;Return to full screen scrolling
+1 if $EXTRACT(IOST)'="C"
QUIT
+2 DO ENS^%ZISS
SET SDRM=^%ZOSF("RM")
SET SDXY=^%ZOSF("XY")
SET (IOTM,IOBM)=0
WRITE $$XY(IOSTBM,1),@IOF
NEW DX,DY,X
SET (DX,DY)=0
XECUTE SDXY
SET X=IOM
XECUTE SDRM
QUIT
+3 ;
DISP(SDTOP,SDBOT) ;Create centered scrolling region
+1 ;Required input: SDTOP=text to center at top of screen
+2 ;Required input: SDBOT(n)=numbered array of text to display at bottom of screen
+3 NEW X
DO DISP0
SET X=0
XECUTE SDRM
WRITE $$XY(IORVON)
FOR I=1:1:(78-$LENGTH(SDTOP)\2)
WRITE "-"
+4 WRITE " ",SDTOP," "
FOR
WRITE "-"
if $X>79
QUIT
+5 WRITE $$XY(IORVOFF)
SET IOTM=3
WRITE $$XY(IOSTBM,1)
SET (C,I)=""
FOR
SET I=$ORDER(SDBOT(I))
if I=""
QUIT
SET C=C+1
+6 FOR
WRITE !
if $Y>(IOSL-C)
QUIT
+7 SET II=$ORDER(SDBOT(""))
if II=""
QUIT
WRITE $$XY(IORVON)
FOR I=1:1:(78-$LENGTH(SDBOT(II))\2)
WRITE "-"
+8 WRITE " ",SDBOT(II)," "
FOR
WRITE "-"
if $X>79
QUIT
+9 WRITE $$XY(IORVOFF)
FOR
SET II=$ORDER(SDBOT(II))
if II=""
QUIT
WRITE !,$EXTRACT(SDBOT(II),1,80)
+10 SET IOBM=(IOSL-C-1)
WRITE $$XY(IOSTBM,1)
QUIT
+11 ;
XY(X,SDI) ;Maintain $X, $Y
+1 ;Required input: X=screen handling variable to write
+2 ;Optional input: SDI=1 (to specify the use of indirection)
+3 NEW DX,DY
SET DX=$X
SET DY=$Y
+4 IF $GET(SDI)
WRITE @X
XECUTE SDXY
QUIT ""
+5 WRITE X
XECUTE SDXY
QUIT ""
+6 ;
DIR(DIR,SDLEV,SDEXE,SDS,SDO,SDPFL,SDA) ;Ask questions!
+1 ;Required input: DIR array (pass by reference)
+2 ;Required input: SDLEV=level to build DIR(0) for large sets
+3 ;Optional input: SDEXE=code to execute prior to ^DIR
+4 ;Optional input: SDS=subscript lookup value for level 2 (required for level 2)
+5 ;Optional input: SDO="O" to indicate input is optional
+6 ;Optional input: SDPFL=print field level (1,2) for print field prompts
+7 ;Optional input: SDA=1 to force single item selection prompt
+8 if $LENGTH($GET(SDEXE))
XECUTE SDEXE
IF '$DATA(DIR(0))
DO @("DIR"_SDLEV)
+9 IF '$GET(SDA)
IF $EXTRACT(DIR(0))="S"
IF $LENGTH(DIR(0),":")=2
QUIT $PIECE($PIECE(DIR(0),U,2),":")_U_$PIECE(DIR(0),":",2)
+10 DO ^DIR
IF $DATA(DTOUT)!$DATA(DUOUT)
SET SDOUT=1
QUIT ""
+11 IF X=""
SET SDNUL=1
QUIT ""
+12 QUIT Y_U_$SELECT($LENGTH($GET(Y(0))):Y(0),1:Y)
+13 ;
DIR1 NEW X,I,II
SET X=""
SET I=0
FOR
SET I=$ORDER(^TMP("SCRPW",$JOB,"SEL",1,I))
if 'I
QUIT
SET II=""
FOR
SET II=$ORDER(^TMP("SCRPW",$JOB,"SEL",1,I,II))
if II=""
QUIT
if $$PFL1()
SET X=X_";"_II_":"_$PIECE(^TMP("SCRPW",$JOB,"SEL",1,I,II),T)
+1 SET DIR(0)="S"_$GET(SDO)_"^"_$EXTRACT(X,2,245)
QUIT
+2 ;
DIR2 NEW X,I,II
SET X=""
SET I=0
FOR
SET I=$ORDER(^TMP("SCRPW",$JOB,"SEL",2,SDS,I))
if 'I
QUIT
SET II=""
FOR
SET II=$ORDER(^TMP("SCRPW",$JOB,"SEL",2,SDS,I,II))
if II=""
QUIT
if $$PFL2()
SET X=X_";"_II_":"_$PIECE(^TMP("SCRPW",$JOB,"SEL",2,SDS,I,II),T)
+1 SET DIR(0)="S"_$GET(SDO)_"^"_$EXTRACT(X,2,245)
QUIT
+2 ;
PFL1() ;Print field level 1 evaluator
+1 if '$GET(SDPFL)
QUIT 1
+2 QUIT $PIECE(^TMP("SCRPW",$JOB,"SEL",1,I,II),T,2)>(SDPFL-1)
+3 ;
PFL2() ;Print field level 2 evaluator
+1 if '$GET(SDPFL)
QUIT 1
+2 QUIT $PIECE(^TMP("SCRPW",$JOB,"SEL",2,SDS,I,II),T,2)>(SDPFL-1)
+3 ;
DIRB1(S1,S2,SDEF) ;Set DIR("B")
+1 ;Required input: S1, S2=subscript values
+2 ;Optional input: SDEF=default value
+3 SET DIR("B")=$SELECT($DATA(SDPAR(S1,S2)):$PIECE(SDPAR(S1,S2),U,2),1:$GET(SDEF))
+4 if '$LENGTH(DIR("B"))
KILL DIR("B")
QUIT
