DENTDCN ;WASH ISC/TJK-MODIFIED DICN ROUTINE ;10:24 AM Jul 28, 1987;12/02/91 11:24 AM
;;1.2;DENTAL;***15**;Oct 08, 1992
S DO(1)=1
I $S($D(DLAYGO):DO(2)\1-(DLAYGO\1),1:1),DUZ(0)'="@",$D(^DIC(+DO(2),0,"LAYGO")) F %=1:1 I DUZ(0)[$E(^("LAYGO"),%) G B:%>$L(^("LAYGO")) Q
I $D(DD) S X=DD D N^DENTDCN1 G I:$D(X),B
D DS S DIX=X I X?.NP,X,DIC(0)["E",'$D(DICR),DS'["DINUM",$P(DS,U,2)'["N",DIC(0)["N"!$D(^DD(+DO(2),.001,0)) D N^DENTDCN1 I $D(X) S DD=X G I
S X=DIX D VAL G I:$D(X)
S X=DIX
B K Y(0) G BAD^DENTDC1
;
1 I '$D(DIC("S")) W " (THE ",Y,$S(Y#10=1&(Y#100-11):"ST",Y#10=2&(Y#100-12):"ND",Y#10=3&(Y#100-13):"RD",1:"TH"),$S('$D(^DD(+DO(2),0,"UP")):"",1:" FOR THIS "_$O(^DD(^("UP"),0,"NM",0))),")"
YN ;
W "? ",$P("YES// ^NO// ",U,%)
RX R %Y:DTIME E S DTOUT=1,%Y=U W *7
S:%Y]""!'% %=$A(%Y),%=$S(%=89:1,%=121:1,%=78:2,%=110:2,%=94:-1,1:0)
I '%,%Y'?."?" W *7,"??",!?4,"ANSWER 'YES' OR 'NO': " G RX
W:$X>73 ! W $P(" (YES)^ (NO)",U,%) Q
;
DS S DS=^DD(+DO(2),.01,0) Q
;
VAL I X'?.ANP!($A(X)=45) K X Q
I $P(DS,U,2)["*" S:DS["DINUM" DINUM=X Q
S %=$F(DS,"%DT=""E"),DS=$E(DS,1,%-2)_$E(DS,%,999) X $P(DS,U,5,99) Q
;
I I DIC(0)["E",DO(2)'["A" S DJC=+DO(2),Y=X D Y^DENTDCM2 K DJC X:$Y>20 DJCP W *7,!?3,"ARE YOU ADDING " W:'$D(DD) "'"_Y_"' AS " S %=$P(DO,U,1) W !?7 W "A NEW "_% S %=0,Y=$P(DO,U,4)+1 D 1 G B:%-1
G FILE:'$D(DD)
R D DS W !?3,$P(DS,U,1),": " R X:DTIME S:'$T X=U
G B:X[U,R:X="" D VAL I '$D(X) W *7,"??" W:$D(^DD(+DO(2),.01,3)) !,^(3) G R
FILE D:'$D(DO) DO^DENTDC1 F DIX=0:0 S DIX=$O(^DD(+DO(2),.01,"LAYGO",DIX)) Q:DIX'>0 I $D(^(DIX,0)) X ^(0) I '$T S Y=-1 G A^DENTDC:$D(DO(1)),Q^DENTDC
S DIX=X
F1 S X=$P(DO,U,3) D INCR S X=X\DIY*DIY+DIY
I $D(DINUM) S X=DINUM D INCR
F2 I $D(@(DIC_"X)")) S X=X\DIY*DIY+DIY G B:$D(DINUM),F2
S Y=$P(DO,"^",2) I $D(DD) S X=DD
E I 'Y,DUZ(0)'="@" G LOCK
I DIC(0)["E",$D(^DD(+Y,.001,0)) G NUM^DENTDCN1
LOCK L @(DIC_"X):1") I $D(@(DIC_"X)"))!'$T L W *7 G F1
;Nake reference in LOOK+4 is refs. in Line Tag: LOCK.
;DIC is set to ^DENT(xxx, where xxx is a file number.
S ^(X,0)=DIX,DD=0 L K D S:$D(DA)#2 D=DA S DA=X,X=DIX
I $D(@(DIC_"0)")) S ^(0)=$P(^(0),"^",1,2)_"^"_DA_"^"_($P(^(0),"^",4)+1)
IX S DS=X,DD=$O(^DD(+DO(2),.01,1,DD)) S:DD="" DD=-1 I DD>0 G RIX^DENTDCN1:^(DD,0)["TRIGGER"!(^(0)["BULL") X ^(1) S X=DS G IX
I DIC(0)["E"&($O(^DD(+DO(2),0,"ID",0))>0)!$D(DIC("DR")) G ^DENTDCN1
D ;
S Y=DA_"^"_X_"^"_1 S:$D(D)#2 DA=D G R^DENTDC
;
INCR S DIY=1 I $P(DO,U,2)>1 F %=1:1:$L($P(X,".",2)) S DIY=DIY/10
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDENTDCN 2506 printed Dec 13, 2024@01:46:20 Page 2
DENTDCN ;WASH ISC/TJK-MODIFIED DICN ROUTINE ;10:24 AM Jul 28, 1987;12/02/91 11:24 AM
+1 ;;1.2;DENTAL;***15**;Oct 08, 1992
+2 SET DO(1)=1
+3 IF $SELECT($DATA(DLAYGO):DO(2)\1-(DLAYGO\1),1:1)
IF DUZ(0)'="@"
IF $DATA(^DIC(+DO(2),0,"LAYGO"))
FOR %=1:1
IF DUZ(0)[$EXTRACT(^("LAYGO"),%)
if %>$LENGTH(^("LAYGO"))
GOTO B
QUIT
+4 IF $DATA(DD)
SET X=DD
DO N^DENTDCN1
if $DATA(X)
GOTO I
GOTO B
+5 DO DS
SET DIX=X
IF X?.NP
IF X
IF DIC(0)["E"
IF '$DATA(DICR)
IF DS'["DINUM"
IF $PIECE(DS,U,2)'["N"
IF DIC(0)["N"!$DATA(^DD(+DO(2),.001,0))
DO N^DENTDCN1
IF $DATA(X)
SET DD=X
GOTO I
+6 SET X=DIX
DO VAL
if $DATA(X)
GOTO I
+7 SET X=DIX
B KILL Y(0)
GOTO BAD^DENTDC1
+1 ;
1 IF '$DATA(DIC("S"))
WRITE " (THE ",Y,$SELECT(Y#10=1&(Y#100-11):"ST",Y#10=2&(Y#100-12):"ND",Y#10=3&(Y#100-13):"RD",1:"TH"),$SELECT('$DATA(^DD(+DO(2),0,"UP")):"",1:" FOR THIS "_$ORDER(^DD(^("UP"),0,"NM",0))),")"
YN ;
+1 WRITE "? ",$PIECE("YES// ^NO// ",U,%)
RX READ %Y:DTIME
IF '$TEST
SET DTOUT=1
SET %Y=U
WRITE *7
+1 if %Y]""!'%
SET %=$ASCII(%Y)
SET %=$SELECT(%=89:1,%=121:1,%=78:2,%=110:2,%=94:-1,1:0)
+2 IF '%
IF %Y'?."?"
WRITE *7,"??",!?4,"ANSWER 'YES' OR 'NO': "
GOTO RX
+3 if $X>73
WRITE !
WRITE $PIECE(" (YES)^ (NO)",U,%)
QUIT
+4 ;
DS SET DS=^DD(+DO(2),.01,0)
QUIT
+1 ;
VAL IF X'?.ANP!($ASCII(X)=45)
KILL X
QUIT
+1 IF $PIECE(DS,U,2)["*"
if DS["DINUM"
SET DINUM=X
QUIT
+2 SET %=$FIND(DS,"%DT=""E")
SET DS=$EXTRACT(DS,1,%-2)_$EXTRACT(DS,%,999)
XECUTE $PIECE(DS,U,5,99)
QUIT
+3 ;
I IF DIC(0)["E"
IF DO(2)'["A"
SET DJC=+DO(2)
SET Y=X
DO Y^DENTDCM2
KILL DJC
if $Y>20
XECUTE DJCP
WRITE *7,!?3,"ARE YOU ADDING "
if '$DATA(DD)
WRITE "'"_Y_"' AS "
SET %=$PIECE(DO,U,1)
WRITE !?7
WRITE "A NEW "_%
SET %=0
SET Y=$PIECE(DO,U,4)+1
DO 1
if %-1
GOTO B
+1 if '$DATA(DD)
GOTO FILE
R DO DS
WRITE !?3,$PIECE(DS,U,1),": "
READ X:DTIME
if '$TEST
SET X=U
+1 if X[U
GOTO B
if X=""
GOTO R
DO VAL
IF '$DATA(X)
WRITE *7,"??"
if $DATA(^DD(+DO(2),.01,3))
WRITE !,^(3)
GOTO R
FILE if '$DATA(DO)
DO DO^DENTDC1
FOR DIX=0:0
SET DIX=$ORDER(^DD(+DO(2),.01,"LAYGO",DIX))
if DIX'>0
QUIT
IF $DATA(^(DIX,0))
XECUTE ^(0)
IF '$TEST
SET Y=-1
if $DATA(DO(1))
GOTO A^DENTDC
GOTO Q^DENTDC
+1 SET DIX=X
F1 SET X=$PIECE(DO,U,3)
DO INCR
SET X=X\DIY*DIY+DIY
+1 IF $DATA(DINUM)
SET X=DINUM
DO INCR
F2 IF $DATA(@(DIC_"X)"))
SET X=X\DIY*DIY+DIY
if $DATA(DINUM)
GOTO B
GOTO F2
+1 SET Y=$PIECE(DO,"^",2)
IF $DATA(DD)
SET X=DD
+2 IF '$TEST
IF 'Y
IF DUZ(0)'="@"
GOTO LOCK
+3 IF DIC(0)["E"
IF $DATA(^DD(+Y,.001,0))
GOTO NUM^DENTDCN1
LOCK LOCK @(DIC_"X):1")
IF $DATA(@(DIC_"X)"))!'$TEST
LOCK
WRITE *7
GOTO F1
+1 ;Nake reference in LOOK+4 is refs. in Line Tag: LOCK.
+2 ;DIC is set to ^DENT(xxx, where xxx is a file number.
+3 SET ^(X,0)=DIX
SET DD=0
LOCK
KILL D
if $DATA(DA)#2
SET D=DA
SET DA=X
SET X=DIX
+4 IF $DATA(@(DIC_"0)"))
SET ^(0)=$PIECE(^(0),"^",1,2)_"^"_DA_"^"_($PIECE(^(0),"^",4)+1)
IX SET DS=X
SET DD=$ORDER(^DD(+DO(2),.01,1,DD))
if DD=""
SET DD=-1
IF DD>0
if ^(DD,0)["TRIGGER"!(^(0)["BULL")
GOTO RIX^DENTDCN1
XECUTE ^(1)
SET X=DS
GOTO IX
+1 IF DIC(0)["E"&($ORDER(^DD(+DO(2),0,"ID",0))>0)!$DATA(DIC("DR"))
GOTO ^DENTDCN1
D ;
+1 SET Y=DA_"^"_X_"^"_1
if $DATA(D)#2
SET DA=D
GOTO R^DENTDC
+2 ;
INCR SET DIY=1
IF $PIECE(DO,U,2)>1
FOR %=1:1:$LENGTH($PIECE(X,".",2))
SET DIY=DIY/10
+1 QUIT
