- DENTDCN1 ;WASH ISC/TJK-MODIFIED DICN1 ROUTINE ;6/29/92 14:36
- ;;1.2;DENTAL;***15**;Oct 08, 1992
- K DICRS,Y,DENTDRCR
- F Y="I","J","X","DO","DC","DA","DE","DG","DIE","DR","DIC","D","D0","D1","D2","D3","D4","D5","D6","DI","DH","DIA","DICR","DK","DIK","DL","DLAYGO","DM","DP","DQ","DU","DW","DIEL","DOV","DIOV","DIEC","DB","DV","DIFLD" S DENTDRCR(Y)=""
- S DZ="W !?3,$S("""_$P(DO,U,1)_"""'=$P(DQ(DQ),U,1):"""_$P(DO,U,1)_""",1:"""")_"" ""_$P(DQ(DQ),U,1)_"": """
- I $D(DIC("DR")) S DD=DIC("DR")
- E S DD="",%=0 F Y=0:0 S Y=$O(^DD(+DO(2),0,"ID",Y)) S:Y="" Y=-1 Q:Y'>0 D CKID I '$D(%) D G BAD
- . ; Naked redernce in DENTCN1+8 refs to DENTDCN1+6
- . W !,"SORRY! A VALUE FOR '"_$P(^(0),U,1)_"' MUST BE ENTERED,"
- . W !?6,"BUT YOU DON'T HAVE 'WRITE ACCESS' FOR THIS FIELD"
- . S DENTDRCR="D^DENTDCN1"
- . D STORLIST
- . Q
- ;END IF
- ;
- S DENTDRCR="RCR^DENTDCN1" D STORLIST G D^DENTDCN:$D(Y)<9
- BAD S:$D(D)#2 DA=D K Y I '$D(DO(1)) S Y=-1 G Q^DENTDC
- K DO G A^DENTDC
- ;
- CKID I $D(DUZ(0)),DUZ(0)'="@",$D(^DD(+DO(2),Y,9)),^(9)]"" F %=1:1 I DUZ(0)[$E(^(9),%) Q:$L(^(9))'<% K:$P(^(0),U,2)["R" % G Q
- S DD=DD_Y_";"
- Q Q
- ;
- RCR ;
- K DR,DQ,DG,DE,DO S DIE=DIC,DR=DD,DIE("W")=DZ K DIC I $D(DIE("NO^")) S DENTDRCR("DIE(""NO^"")")=DIE("NO^")
- S DIE("NO^")="OUTOK" D ^DIE K DIE("W"),DIE("NO^") I '$D(DA) S Y(0)=0 Q
- Q:$D(Y)<9
- ZAP S DIK=DIE W !?6,"<'",*7,$P(@(DIK_"DA,0)"),U,1),"' DELETED>" D ^DIK S Y(0)=0 K DIK Q
- D S DIE=DIC G ZAP
- ;
- RIX ;
- K DENTDRCR F %="D0","Y","DIC","DIU","DIV","DO","D","DD","DICR","X" S DENTDRCR(%)=""
- S DENTDRCR="RR^DENTDCN1",DZ=^DD(+DO(2),.01,1,1) D STORLIST G IX^DENTDCN
- ;
- RR X DZ Q
- ;
- NUM ;
- I '$D(DD),DIC="^DIC(",$D(^DD("SITE",1)),X\1000'=^(1) S X=^(1)*1000 G F2^DENTDCN
- S %=$P(^DD(+Y,.001,0),U,2),X=$S(%'["N"!(%["O"):0,1:X),%Y=X I X F %=1:1 D N Q:$D(X) S X=0 Q:%>50 S X=%Y+DIY,%Y=X
- W !?3,$P(DO,U,1)_" "_$P(^DD(+Y,.001,0),U,1),": " W:X X,"// " R Y:DTIME E S DTOUT=1,Y=U W *7
- I Y="?" W:$D(^DD(+$P(D0,U,2),.001,3)) !,^(3) X:$D(^(4)) ^(4) G F1^DENTDCN
- G BAD^DENTDC1:Y[U S:Y]"" X=Y D N I '$D(X) W *7,"??" W:$D(^DD(+DO(2),.001,3)) !,^(3) X:$D(^(4)) ^(4) G F1^DENTDCN
- G LOCK^DENTDCN
- ;
- N X:$D(^DD(+$P(DO,U,2),.001,0)) $P(^(0),U,5,99) I $D(X),$L(X)<15,+X=X,X>0,X>1!(DIC'="^DIC(") Q
- K X
- STORLIST D INIT
- O S DENTDJD=$O(DENTDRCR(DENTDJD)) S:DENTDJD="" DENTDJD=-1 G CALL:DENTDJD<0
- I $D(@DENTDJD)#2 S @(DENTDJE_")="_DENTDJD) G O:$D(@DENTDJD)=1
- S DENTDJX=DENTDJD_"(" D DENTDJXY G O
- ;
- CALL S DENTDJE=DENTDRCR K DENTDRCR,DENTDJX,DENTDJY D @DENTDJE
- S DENTDJE="^TMP(""DENTDRCR"",$J,"_^TMP("DENTDRCR",$J)_",DENTDJD",^($J)=^($J)-1,DENTDJD=0,DENTDJX=DENTDJE_","
- G S DENTDJD=$O(@(DENTDJE_")")) S:DENTDJD="" DENTDJD=-1 K:DENTDJD<0 DENTDJD,DENTDJE,DENTDJX,DENTDJY,^($J,^TMP("DENTDRCR",$J)+1) Q:'$D(DENTDJD) I $D(^(DENTDJD))#2 S @DENTDJD=^(DENTDJD) G G:$D(^(DENTDJD))=1
- S DENTDJY=DENTDJD_"(" D DENTDJXY G G
- ;
- DENTDJXY ;
- S DENTDJZ=1,DENTDJA="",DENTDJC(0)=0
- S S DENTDJB=-1
- N1 S DENTDJB=$O(@(DENTDJX_DENTDJA_"DENTDJB)")) S:DENTDJB="" DENTDJB=-1 S DENTDJC(DENTDJZ)=DENTDJC(DENTDJZ-1)
- I DENTDJB["," F DENTDJC=0:0 S DENTDJC=$F(DENTDJB,",",DENTDJC) Q:'DENTDJC S DENTDJC(DENTDJZ)=DENTDJC(DENTDJZ)+1
- I DENTDJB=-1 G Q1:DENTDJZ=1 S DENTDJZ=DENTDJZ-1,@("DENTDJB="_$P(DENTDJA,",",DENTDJZ+DENTDJC(DENTDJZ-1),DENTDJZ+DENTDJC(DENTDJZ))),DENTDJA=$P(DENTDJA,",",1,DENTDJZ-1+DENTDJC(DENTDJZ-1))_$E(",",DENTDJZ>1) G N1
- I $D(@(DENTDJX_DENTDJA_"DENTDJB)"))#10=1 S @(DENTDJY_DENTDJA_"DENTDJB)="_DENTDJX_DENTDJA_"DENTDJB)")
- I $D(@(DENTDJX_DENTDJA_"DENTDJB)"))<9 G N1
- G DOWN:+DENTDJB=DENTDJB F DENTDJC=0:0 S DENTDJC=$F(DENTDJB,"""",DENTDJC) Q:'DENTDJC S DENTDJB=$E(DENTDJB,1,DENTDJC-1)_""""_$E(DENTDJB,DENTDJC,999),DENTDJC=DENTDJC+1
- S DENTDJB=""""_DENTDJB_""""
- DOWN S DENTDJA=DENTDJA_DENTDJB_",",DENTDJZ=DENTDJZ+1 G S
- ;
- Q1 K DENTDJA,DENTDJB,DENTDJC,DENTDJZ Q
- ;
- INIT I $D(^TMP("DENTDRCR",$J))[0 S ^TMP("DENTDRCR",$J)=0
- S ^TMP("DENTDRCR",$J)=^($J)+1,DENTDJD="%Z",DENTDJE="^TMP(""DENTDRCR"",$J,"_^($J)_",DENTDJD",DENTDJY=DENTDJE_"," K ^($J,^($J))
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDENTDCN1 4005 printed Mar 13, 2025@20:50:59 Page 2
- DENTDCN1 ;WASH ISC/TJK-MODIFIED DICN1 ROUTINE ;6/29/92 14:36
- +1 ;;1.2;DENTAL;***15**;Oct 08, 1992
- +2 KILL DICRS,Y,DENTDRCR
- +3 FOR Y="I","J","X","DO","DC","DA","DE","DG","DIE","DR","DIC","D","D0","D1","D2","D3","D4","D5","D6","DI","DH","DIA","DICR","DK","DIK","DL","DLAYGO","DM","DP","DQ","DU","DW","DIEL","DOV","DIOV","DIEC","DB","DV","DIFLD"
- SET DENTDRCR(Y)=""
- +4 SET DZ="W !?3,$S("""_$PIECE(DO,U,1)_"""'=$P(DQ(DQ),U,1):"""_$PIECE(DO,U,1)_""",1:"""")_"" ""_$P(DQ(DQ),U,1)_"": """
- +5 IF $DATA(DIC("DR"))
- SET DD=DIC("DR")
- +6 IF '$TEST
- SET DD=""
- SET %=0
- FOR Y=0:0
- SET Y=$ORDER(^DD(+DO(2),0,"ID",Y))
- if Y=""
- SET Y=-1
- if Y'>0
- QUIT
- DO CKID
- IF '$DATA(%)
- Begin DoDot:1
- +7 ; Naked redernce in DENTCN1+8 refs to DENTDCN1+6
- +8 WRITE !,"SORRY! A VALUE FOR '"_$PIECE(^(0),U,1)_"' MUST BE ENTERED,"
- +9 WRITE !?6,"BUT YOU DON'T HAVE 'WRITE ACCESS' FOR THIS FIELD"
- +10 SET DENTDRCR="D^DENTDCN1"
- +11 DO STORLIST
- +12 QUIT
- End DoDot:1
- GOTO BAD
- +13 ;END IF
- +14 ;
- +15 SET DENTDRCR="RCR^DENTDCN1"
- DO STORLIST
- if $DATA(Y)<9
- GOTO D^DENTDCN
- BAD if $DATA(D)#2
- SET DA=D
- KILL Y
- IF '$DATA(DO(1))
- SET Y=-1
- GOTO Q^DENTDC
- +1 KILL DO
- GOTO A^DENTDC
- +2 ;
- CKID IF $DATA(DUZ(0))
- IF DUZ(0)'="@"
- IF $DATA(^DD(+DO(2),Y,9))
- IF ^(9)]""
- FOR %=1:1
- IF DUZ(0)[$EXTRACT(^(9),%)
- if $LENGTH(^(9))'<%
- QUIT
- if $PIECE(^(0),U,2)["R"
- KILL %
- GOTO Q
- +1 SET DD=DD_Y_";"
- Q QUIT
- +1 ;
- RCR ;
- +1 KILL DR,DQ,DG,DE,DO
- SET DIE=DIC
- SET DR=DD
- SET DIE("W")=DZ
- KILL DIC
- IF $DATA(DIE("NO^"))
- SET DENTDRCR("DIE(""NO^"")")=DIE("NO^")
- +2 SET DIE("NO^")="OUTOK"
- DO ^DIE
- KILL DIE("W"),DIE("NO^")
- IF '$DATA(DA)
- SET Y(0)=0
- QUIT
- +3 if $DATA(Y)<9
- QUIT
- ZAP SET DIK=DIE
- WRITE !?6,"<'",*7,$PIECE(@(DIK_"DA,0)"),U,1),"' DELETED>"
- DO ^DIK
- SET Y(0)=0
- KILL DIK
- QUIT
- D SET DIE=DIC
- GOTO ZAP
- +1 ;
- RIX ;
- +1 KILL DENTDRCR
- FOR %="D0","Y","DIC","DIU","DIV","DO","D","DD","DICR","X"
- SET DENTDRCR(%)=""
- +2 SET DENTDRCR="RR^DENTDCN1"
- SET DZ=^DD(+DO(2),.01,1,1)
- DO STORLIST
- GOTO IX^DENTDCN
- +3 ;
- RR XECUTE DZ
- QUIT
- +1 ;
- NUM ;
- +1 IF '$DATA(DD)
- IF DIC="^DIC("
- IF $DATA(^DD("SITE",1))
- IF X\1000'=^(1)
- SET X=^(1)*1000
- GOTO F2^DENTDCN
- +2 SET %=$PIECE(^DD(+Y,.001,0),U,2)
- SET X=$SELECT(%'["N"!(%["O"):0,1:X)
- SET %Y=X
- IF X
- FOR %=1:1
- DO N
- if $DATA(X)
- QUIT
- SET X=0
- if %>50
- QUIT
- SET X=%Y+DIY
- SET %Y=X
- +3 WRITE !?3,$PIECE(DO,U,1)_" "_$PIECE(^DD(+Y,.001,0),U,1),": "
- if X
- WRITE X,"// "
- READ Y:DTIME
- IF '$TEST
- SET DTOUT=1
- SET Y=U
- WRITE *7
- +4 IF Y="?"
- if $DATA(^DD(+$PIECE(D0,U,2),.001,3))
- WRITE !,^(3)
- if $DATA(^(4))
- XECUTE ^(4)
- GOTO F1^DENTDCN
- +5 if Y[U
- GOTO BAD^DENTDC1
- if Y]""
- SET X=Y
- DO N
- IF '$DATA(X)
- WRITE *7,"??"
- if $DATA(^DD(+DO(2),.001,3))
- WRITE !,^(3)
- if $DATA(^(4))
- XECUTE ^(4)
- GOTO F1^DENTDCN
- +6 GOTO LOCK^DENTDCN
- +7 ;
- N if $DATA(^DD(+$PIECE(DO,U,2),.001,0))
- XECUTE $PIECE(^(0),U,5,99)
- IF $DATA(X)
- IF $LENGTH(X)<15
- IF +X=X
- IF X>0
- IF X>1!(DIC'="^DIC(")
- QUIT
- +1 KILL X
- STORLIST DO INIT
- O SET DENTDJD=$ORDER(DENTDRCR(DENTDJD))
- if DENTDJD=""
- SET DENTDJD=-1
- if DENTDJD<0
- GOTO CALL
- +1 IF $DATA(@DENTDJD)#2
- SET @(DENTDJE_")="_DENTDJD)
- if $DATA(@DENTDJD)=1
- GOTO O
- +2 SET DENTDJX=DENTDJD_"("
- DO DENTDJXY
- GOTO O
- +3 ;
- CALL SET DENTDJE=DENTDRCR
- KILL DENTDRCR,DENTDJX,DENTDJY
- DO @DENTDJE
- +1 SET DENTDJE="^TMP(""DENTDRCR"",$J,"_^TMP("DENTDRCR",$JOB)_",DENTDJD"
- SET ^($JOB)=^($JOB)-1
- SET DENTDJD=0
- SET DENTDJX=DENTDJE_","
- G SET DENTDJD=$ORDER(@(DENTDJE_")"))
- if DENTDJD=""
- SET DENTDJD=-1
- if DENTDJD<0
- KILL DENTDJD,DENTDJE,DENTDJX,DENTDJY,^($JOB,^TMP("DENTDRCR",$JOB)+1)
- if '$DATA(DENTDJD)
- QUIT
- IF $DATA(^(DENTDJD))#2
- SET @DENTDJD=^(DENTDJD)
- if $DATA(^(DENTDJD))=1
- GOTO G
- +1 SET DENTDJY=DENTDJD_"("
- DO DENTDJXY
- GOTO G
- +2 ;
- DENTDJXY ;
- +1 SET DENTDJZ=1
- SET DENTDJA=""
- SET DENTDJC(0)=0
- S SET DENTDJB=-1
- N1 SET DENTDJB=$ORDER(@(DENTDJX_DENTDJA_"DENTDJB)"))
- if DENTDJB=""
- SET DENTDJB=-1
- SET DENTDJC(DENTDJZ)=DENTDJC(DENTDJZ-1)
- +1 IF DENTDJB[","
- FOR DENTDJC=0:0
- SET DENTDJC=$FIND(DENTDJB,",",DENTDJC)
- if 'DENTDJC
- QUIT
- SET DENTDJC(DENTDJZ)=DENTDJC(DENTDJZ)+1
- +2 IF DENTDJB=-1
- if DENTDJZ=1
- GOTO Q1
- SET DENTDJZ=DENTDJZ-1
- SET @("DENTDJB="_$PIECE(DENTDJA,",",DENTDJZ+DENTDJC(DENTDJZ-1),DENTDJZ+DENTDJC(DENTDJZ)))
- SET DENTDJA=$PIECE(DENTDJA,",",1,DENTDJZ-1+DENTDJC(DENTDJZ-1))_$EXTRACT(",",DENTDJZ>1)
- GOTO N1
- +3 IF $DATA(@(DENTDJX_DENTDJA_"DENTDJB)"))#10=1
- SET @(DENTDJY_DENTDJA_"DENTDJB)="_DENTDJX_DENTDJA_"DENTDJB)")
- +4 IF $DATA(@(DENTDJX_DENTDJA_"DENTDJB)"))<9
- GOTO N1
- +5 if +DENTDJB=DENTDJB
- GOTO DOWN
- FOR DENTDJC=0:0
- SET DENTDJC=$FIND(DENTDJB,"""",DENTDJC)
- if 'DENTDJC
- QUIT
- SET DENTDJB=$EXTRACT(DENTDJB,1,DENTDJC-1)_""""_$EXTRACT(DENTDJB,DENTDJC,999)
- SET DENTDJC=DENTDJC+1
- +6 SET DENTDJB=""""_DENTDJB_""""
- DOWN SET DENTDJA=DENTDJA_DENTDJB_","
- SET DENTDJZ=DENTDJZ+1
- GOTO S
- +1 ;
- Q1 KILL DENTDJA,DENTDJB,DENTDJC,DENTDJZ
- QUIT
- +1 ;
- INIT IF $DATA(^TMP("DENTDRCR",$JOB))[0
- SET ^TMP("DENTDRCR",$JOB)=0
- +1 SET ^TMP("DENTDRCR",$JOB)=^($JOB)+1
- SET DENTDJD="%Z"
- SET DENTDJE="^TMP(""DENTDRCR"",$J,"_^($JOB)_",DENTDJD"
- SET DENTDJY=DENTDJE_","
- KILL ^($JOB,^($JOB))
