DENTDCM2 ;WASH ISC/TJK-MODIFIED DICM2 ROUTINE ; 2-Jul-1987 4:59 pm;12/16/91 4:15 PM
;;1.2;DENTAL;***15**;Oct 08, 1992
;VAR PNTR
S DIVDO=+DO(2),DIVDS=DS,DIVDIC=DIC F %="DR","S","A","V" I $D(DIC(%)) S @("DIV"_%)=DIC(%)
K DIC("W"),DIC("S"),DIC("DR"),DO,DUOUT S DIEX=X G ALL:X'["." I $P(X,".",2)="" S Y=-1 G Q
V S DIVP=$P(DIEX,".",1),X=$P(DIEX,".",2) I DIVP]"",$D(^DD(DIVDO,.01,"V","P",DIVP)) S (DIVP,DIVPDIC)=+$O(^(DIVP,0)),DIVPDIC=$S($D(^DD(DIVDO,.01,"V",DIVP,0)):^(0),1:"") G Q:'DIVPDIC D DIC G Q
S X="",DIVP=$P(DIEX,".",1) F %=0:0 S X=$O(^DD(DIVDO,.01,"V","M",X)) Q:X="" I $P(X,DIVP,1)="" S (DIVP,DIVPDIC)=+$O(^(X,0)),DIVPDIC=$S($D(^DD(DIVDO,.01,"V",DIVP,0)):^(0),1:""),X=$P(DIEX,".",2) G Q:'DIVPDIC D DIC G Q:Y>0 S X=DIEX
F DIVP=0:0 S DIVP=$O(^DD(DIVDO,.01,"V",DIVP)) S:DIVP="" DIVP=-1 Q:DIVP'>0 I $D(^(DIVP,0)) S DIVPDIC=^(0) I $D(^DIC(+DIVPDIC,0)) S %=$P(^(0),U,1) I $P(%,$P(DIEX,".",1),1)="" S X=$P(DIEX,".",2) D DIC G Q:Y>0 S X=DIEX
K X G Q
ALL F DIVP1=0:0 S DIVP1=$O(^DD(DIVDO,.01,"V","O",DIVP1)) S:DIVP1="" DIVP1=-1 Q:DIVP1'>0 S DIVP=$O(^(DIVP1,0)) S:DIVP="" DIVP=-1 I $D(^DD(DIVDO,.01,"V",DIVP,0)) S DIVPDIC=^(0) D DIC G Q:Y>0!(%<0)!$D(DUOUT) S X=DIEX
G Q:DICR>1!$D(DICR(DICR,"V")) S DICR(DICR,"V")=1 K DIVP G ALL
;
DIC ;
Q:$D(DIVP(+DIVPDIC)) I $D(DIC("V")) S Y=DIVP,Y(0)=DIVPDIC X DIC("V") I '$T K Y S Y=-1 G DQ
I '$D(^DIC(+DIVPDIC,0,"GL")) S Y=-1 G DQ
S DIC=^DIC(+DIVPDIC,0,"GL"),%="DIC"_DICR
IF DIC(0)'["L"!'$D(DICR(DICR,"V")) D
. S DIC("S")="X ""I 0"" F "_%_"=0:0 S "_%_"=$O("_DIVDIC_"""B"",(+Y_"";"_$E(DIC,2,99)_"""),"_%_")) S:"_%_"="""" "_%_"=-1 Q:"_%_"'>0 I $D("_DIVDIC_%_",0))"_$S($D(DIVS):" S %YV=Y,Y="_%_" X DIVS S Y=%YV I ",1:"")_" Q"
. Q
;END IF
;
S %=DIC(0),DIC(0)="DM"_$E("E",%["E")_$E("O",%["O") I $P(DIVPDIC,U,6)="y",$D(DICR(DICR,"V")),%["L" S DIC(0)=DIC(0)_"L"
I $D(DICR(DICR,"V")),$P(DIVPDIC,U,5)="y",$D(^DD(DIVDO,.01,"V",DIVP,1)),^(1)]"" S %=$S($D(DIC("S")):DIC("S"),1:"") X ^(1) S DIC("S")=DIC("S")_" "_%
I DIC(0)["E",$D(DIVP1),$D(DICR(DICR,"V")) W !!?5,"Searching for a "_$P(DIVPDIC,U,2)
I X?."?" S DZ=X_$E("?",'$D(DICR(DICR,"V"))) D DQ^DENTDCQ S X=$S($D(DZ):DZ,1:"?"),Y=-1 G DQ
D DO^DENTDC1,X^DENTDC G DQ:$D(DUOUT) S X=+Y_";"_$E(DIC,2,99),%=1 K:Y<0 X I '$D(DICR(DICR,"V")) K DICR("^",+DIVPDIC) S DIVP(+DIVPDIC)=0
I Y>0,$D(DIVP1),DIC(0)["E",'$P(Y,U,3),$P(^DIC(+DIVPDIC,0),U,2)'["O" W !?9,"...OK" D YN^DENTDCN S:%=2!(%<0) Y=-1
DQ K DIC,DO S DIC=DIVDIC,D=$S($D(DICR(DICR,4)):DICR(DICR,4),1:"B"),DIC(0)=DICR(DICR,0) I $D(DIVV) S DIC("V")=DIVV
Q
;
Q I '$D(DUOUT),Y<0,DICR<2,'$D(DICR(DICR,"V")) S DICR(DICR,"V")=1 K DIVP G V
K:Y<0 X S DS=DIVDS,DICR(DICR,"V")=1 S:$D(DIVDR) DIC("DR")=DIVDR S:$D(DIVA) DIC("A")=DIVA S:$D(DIVS) DIC("S")=DIVS
QQ K:Y DICR(DICR,6) K DUOUT,DIVV,DIVP,DIVDIC,DO,DIVDO,DIVDS,DIVS,DIVPDIC,DIEX,DIVP1,DIVDR,DIVA Q
;
NAME ;DETERMINE EXTERNAL FORM FROM INTERNAL FOR VP
S DINAME=DIY Q:'DIY S %=$P(DIY,";",2),DINAME="^"_%_+DIY_",0)",DINAME=$S($D(@DINAME)#2:$P(^(0),U,1),1:DIY),%=$S($D(@("^"_%_"0)")):$P(^(0),U,2),1:"") Q:%=""
I %["P"!(%["S")!(%["D") S DJC=%,%YYY=DIY,%YY=Y,Y=DINAME D Y K DJC S DINAME=Y,DIY=%YYY,Y=%YY,C="," K %YY,%YYY
Q
Y S C=$P(^DD(+DJC,.01,0),U,2) I C["O",$D(^(2)) X ^(2) Q
S I C["S" S C=";"_$P(^DD(+DJC,.01,0),U,3),%=$F(C,";"_Y_":") S:% Y=$P($E(C,%,999),";",1) Q
I C["P",$D(@("^"_$P(^DD(+DJC,.01,0),U,3)_"0)")) S (C,DJC)=$P(^(0),U,2) I $D(^(+Y,0)) S Y=$P(^(0),U,1) I $D(^DD(+C,.01,0)) S C=$P(^(0),U,2) G S
I C["V",+Y,$D(@("^"_$P(Y,";",2)_"0)")) S C=$P(^(0),U,2) I $D(^(+Y,0)) S Y=$P(^(0),U,1) I $D(^DD(+C,.01,0)) S C=$P(^(0),U,2) G S
Q:C'["D" Q:'Y
D S %=$E(Y,4,5)*3,Y=$E("JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC",%-2,%)_" "_$S($E(Y,6,7):$J(+$E(Y,6,7),2)_", ",1:"")_($E(Y,1,3)+1700)_$S(Y[".":" "_$E(Y_0,9,10)_":"_$E(Y_"000",11,12),1:"") Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDENTDCM2 3786 printed Dec 13, 2024@01:46:18 Page 2
DENTDCM2 ;WASH ISC/TJK-MODIFIED DICM2 ROUTINE ; 2-Jul-1987 4:59 pm;12/16/91 4:15 PM
+1 ;;1.2;DENTAL;***15**;Oct 08, 1992
+2 ;VAR PNTR
+3 SET DIVDO=+DO(2)
SET DIVDS=DS
SET DIVDIC=DIC
FOR %="DR","S","A","V"
IF $DATA(DIC(%))
SET @("DIV"_%)=DIC(%)
+4 KILL DIC("W"),DIC("S"),DIC("DR"),DO,DUOUT
SET DIEX=X
if X'["."
GOTO ALL
IF $PIECE(X,".",2)=""
SET Y=-1
GOTO Q
V SET DIVP=$PIECE(DIEX,".",1)
SET X=$PIECE(DIEX,".",2)
IF DIVP]""
IF $DATA(^DD(DIVDO,.01,"V","P",DIVP))
SET (DIVP,DIVPDIC)=+$ORDER(^(DIVP,0))
SET DIVPDIC=$SELECT($DATA(^DD(DIVDO,.01,"V",DIVP,0)):^(0),1:"")
if 'DIVPDIC
GOTO Q
DO DIC
GOTO Q
+1 SET X=""
SET DIVP=$PIECE(DIEX,".",1)
FOR %=0:0
SET X=$ORDER(^DD(DIVDO,.01,"V","M",X))
if X=""
QUIT
IF $PIECE(X,DIVP,1)=""
SET (DIVP,DIVPDIC)=+$ORDER(^(X,0))
SET DIVPDIC=$SELECT($DATA(^DD(DIVDO,.01,"V",DIVP,0)):^(0),1:"")
SET X=$PIECE(DIEX,".",2)
if 'DIVPDIC
GOTO Q
DO DIC
if Y>0
GOTO Q
SET X=DIEX
+2 FOR DIVP=0:0
SET DIVP=$ORDER(^DD(DIVDO,.01,"V",DIVP))
if DIVP=""
SET DIVP=-1
if DIVP'>0
QUIT
IF $DATA(^(DIVP,0))
SET DIVPDIC=^(0)
IF $DATA(^DIC(+DIVPDIC,0))
SET %=$PIECE(^(0),U,1)
IF $PIECE(%,$PIECE(DIEX,".",1),1)=""
SET X=$PIECE(DIEX,".",2)
DO DIC
if Y>0
GOTO Q
SET X=DIEX
+3 KILL X
GOTO Q
ALL FOR DIVP1=0:0
SET DIVP1=$ORDER(^DD(DIVDO,.01,"V","O",DIVP1))
if DIVP1=""
SET DIVP1=-1
if DIVP1'>0
QUIT
SET DIVP=$ORDER(^(DIVP1,0))
if DIVP=""
SET DIVP=-1
IF $DATA(^DD(DIVDO,.01,"V",DIVP,0))
SET DIVPDIC=^(0)
DO DIC
if Y>0!(%<0)!$DATA(DUOUT)
GOTO Q
SET X=DIEX
+1 if DICR>1!$DATA(DICR(DICR,"V"))
GOTO Q
SET DICR(DICR,"V")=1
KILL DIVP
GOTO ALL
+2 ;
DIC ;
+1 if $DATA(DIVP(+DIVPDIC))
QUIT
IF $DATA(DIC("V"))
SET Y=DIVP
SET Y(0)=DIVPDIC
XECUTE DIC("V")
IF '$TEST
KILL Y
SET Y=-1
GOTO DQ
+2 IF '$DATA(^DIC(+DIVPDIC,0,"GL"))
SET Y=-1
GOTO DQ
+3 SET DIC=^DIC(+DIVPDIC,0,"GL")
SET %="DIC"_DICR
+4 IF DIC(0)'["L"!'$DATA(DICR(DICR,"V"))
Begin DoDot:1
+5 SET DIC("S")="X ""I 0"" F "_%_"=0:0 S "_%_"=$O("_DIVDIC_"""B"",(+Y_"";"_$EXTRACT(DIC,2,99)_"""),"_%_")) S:"_%_"="""" "_%_"=-1 Q:"_%_"'>0 I $D("_DIVDIC_%_",0))"_$SELECT($DATA(DIVS):" S %YV=Y,Y="_%_" X DIVS S Y=%YV I ",1:"")_" Q"
+6 QUIT
End DoDot:1
+7 ;END IF
+8 ;
+9 SET %=DIC(0)
SET DIC(0)="DM"_$EXTRACT("E",%["E")_$EXTRACT("O",%["O")
IF $PIECE(DIVPDIC,U,6)="y"
IF $DATA(DICR(DICR,"V"))
IF %["L"
SET DIC(0)=DIC(0)_"L"
+10 IF $DATA(DICR(DICR,"V"))
IF $PIECE(DIVPDIC,U,5)="y"
IF $DATA(^DD(DIVDO,.01,"V",DIVP,1))
IF ^(1)]""
SET %=$SELECT($DATA(DIC("S")):DIC("S"),1:"")
XECUTE ^(1)
SET DIC("S")=DIC("S")_" "_%
+11 IF DIC(0)["E"
IF $DATA(DIVP1)
IF $DATA(DICR(DICR,"V"))
WRITE !!?5,"Searching for a "_$PIECE(DIVPDIC,U,2)
+12 IF X?."?"
SET DZ=X_$EXTRACT("?",'$DATA(DICR(DICR,"V")))
DO DQ^DENTDCQ
SET X=$SELECT($DATA(DZ):DZ,1:"?")
SET Y=-1
GOTO DQ
+13 DO DO^DENTDC1
DO X^DENTDC
if $DATA(DUOUT)
GOTO DQ
SET X=+Y_";"_$EXTRACT(DIC,2,99)
SET %=1
if Y<0
KILL X
IF '$DATA(DICR(DICR,"V"))
KILL DICR("^",+DIVPDIC)
SET DIVP(+DIVPDIC)=0
+14 IF Y>0
IF $DATA(DIVP1)
IF DIC(0)["E"
IF '$PIECE(Y,U,3)
IF $PIECE(^DIC(+DIVPDIC,0),U,2)'["O"
WRITE !?9,"...OK"
DO YN^DENTDCN
if %=2!(%<0)
SET Y=-1
DQ KILL DIC,DO
SET DIC=DIVDIC
SET D=$SELECT($DATA(DICR(DICR,4)):DICR(DICR,4),1:"B")
SET DIC(0)=DICR(DICR,0)
IF $DATA(DIVV)
SET DIC("V")=DIVV
+1 QUIT
+2 ;
Q IF '$DATA(DUOUT)
IF Y<0
IF DICR<2
IF '$DATA(DICR(DICR,"V"))
SET DICR(DICR,"V")=1
KILL DIVP
GOTO V
+1 if Y<0
KILL X
SET DS=DIVDS
SET DICR(DICR,"V")=1
if $DATA(DIVDR)
SET DIC("DR")=DIVDR
if $DATA(DIVA)
SET DIC("A")=DIVA
if $DATA(DIVS)
SET DIC("S")=DIVS
QQ if Y
KILL DICR(DICR,6)
KILL DUOUT,DIVV,DIVP,DIVDIC,DO,DIVDO,DIVDS,DIVS,DIVPDIC,DIEX,DIVP1,DIVDR,DIVA
QUIT
+1 ;
NAME ;DETERMINE EXTERNAL FORM FROM INTERNAL FOR VP
+1 SET DINAME=DIY
if 'DIY
QUIT
SET %=$PIECE(DIY,";",2)
SET DINAME="^"_%_+DIY_",0)"
SET DINAME=$SELECT($DATA(@DINAME)#2:$PIECE(^(0),U,1),1:DIY)
SET %=$SELECT($DATA(@("^"_%_"0)")):$PIECE(^(0),U,2),1:"")
if %=""
QUIT
+2 IF %["P"!(%["S")!(%["D")
SET DJC=%
SET %YYY=DIY
SET %YY=Y
SET Y=DINAME
DO Y
KILL DJC
SET DINAME=Y
SET DIY=%YYY
SET Y=%YY
SET C=","
KILL %YY,%YYY
+3 QUIT
Y SET C=$PIECE(^DD(+DJC,.01,0),U,2)
IF C["O"
IF $DATA(^(2))
XECUTE ^(2)
QUIT
S IF C["S"
SET C=";"_$PIECE(^DD(+DJC,.01,0),U,3)
SET %=$FIND(C,";"_Y_":")
if %
SET Y=$PIECE($EXTRACT(C,%,999),";",1)
QUIT
+1 IF C["P"
IF $DATA(@("^"_$PIECE(^DD(+DJC,.01,0),U,3)_"0)"))
SET (C,DJC)=$PIECE(^(0),U,2)
IF $DATA(^(+Y,0))
SET Y=$PIECE(^(0),U,1)
IF $DATA(^DD(+C,.01,0))
SET C=$PIECE(^(0),U,2)
GOTO S
+2 IF C["V"
IF +Y
IF $DATA(@("^"_$PIECE(Y,";",2)_"0)"))
SET C=$PIECE(^(0),U,2)
IF $DATA(^(+Y,0))
SET Y=$PIECE(^(0),U,1)
IF $DATA(^DD(+C,.01,0))
SET C=$PIECE(^(0),U,2)
GOTO S
+3 if C'["D"
QUIT
if 'Y
QUIT
D SET %=$EXTRACT(Y,4,5)*3
SET Y=$EXTRACT("JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC",%-2,%)_" "_$SELECT($EXTRACT(Y,6,7):$JUSTIFY(+$EXTRACT(Y,6,7),2)_", ",1:"")_($EXTRACT(Y,1,3)+1700)_$SELECT(Y[".":" "_$EXTRACT(Y_0,9,10)_":"_$EXTRACT(Y_"000",11,12),1:"")
QUIT
