source: WorldVistAEHR/trunk/r/DENTAL-DEN/DENTDC.m@ 632

Last change on this file since 632 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 3.2 KB
Line 
1DENTDC ;WASH ISC/TJK-MODIFIED DIC ROUTINE ;9/18/92 13:09
2 ;;1.2;DENTAL;***15**;Oct 08, 1992
3 S D="B" K DF,DS,DFOUT,DTOUT,DUOUT
4EN K DO,DICR S U="^" S:DIC DIC=^DIC(DIC,0,"GL") D PGM I $D(DIPGM) S DIPGM(0)=1 G @DIPGM
5ASK I DIC(0)["A" W ! D ^DENTDC1
6 I $D(DIADD),X'["""",U'[X,X'?."?" S X=""""_X_""""
7X ;
8 D DO^DENTDC1:'$D(DO) I U'[X,X'?."?",$D(^DD(+DO(2),.01,7.5)) X ^(7.5) G:'$D(X) BAD^DENTDC1
9 D PGM I $D(DIPGM) S DIPGM(0)=2 G @DIPGM
10RTN ;
11 G O^DENTDC1:X'?.ANP,N:$L(X)>30 I X?.NP G NO:X="",NUM:+X=X,^DENTDCQ:X?1"?"."?" I X=" ",$L(DIC)<29,$D(^DISV(DUZ,DIC)) S Y=+^(DIC) D S G GOT:$T,BAD^DENTDC1
12F ;
13 S (DD,DS)=0
14T S Y=$O(@(DIC_"D,X,0)")),DIX=X S:Y="" Y=-1
15 ; Naked refernces refs to T. DIC is to ^DENT(xxx where xxx is the file
16 ;numbeR
17 I Y'<0 S YMLH=$O(^(Y)) S:YMLH="" YMLH=-1 G DIY:YMLH'<0!((DIC(0)'["O")&(DIC(0)["E")) D MN I G K:DS S DS=1 G GOT
18DIX I DIC(0)'["X" S:X?.N DIX=DIX_" " S DIX=$O(@(DIC_"D,DIX)")) S:DIX="" DIX=-1 I $P(DIX,X,1)="",DIX'=-1 S Y=$O(^(DIX,0)) S:Y="" Y=-1 G DIY
19M I DIC(0)'["M" G B
20 S D=$S($D(DID):$P(DID,U,DID(1)),1:$O(@(DIC_"D)")))
21 I D="" S D=-1
22 I $D(DID) S DID(1)=DID(1)+1
23 I D+1 G M:$D(@(DIC_"D)"))-10,T:X'?.NP,T:+X'=X D DO^DENTDC1:'$D(DO) S Y=$O(^DD(+DO(2),0,"IX",D,0)) S:Y="" Y=-1 S YY=$O(^(Y,0)) S:YY="" YY=-1 G T:'$D(^DD(Y,YY,0)),M:$P(^(0),U,2)["P",T
24B D D G G:DS=1,Y^DENTDC1:DS
25N I X[U S DUOUT=1 G NO
26 D DO^DENTDC1:'$D(DO) I X?1"`".NP S Y=$E(X,2,30),DZ=0 G A:Y="" D S S DS=1,DD=Y G GOT:$T I DIC(0)'["L" W:DIC(0)["Q" *7," ??" G A
27 G ^DENTDCQ:X?."?",^DENTDCM
28 ;
29NUM D DO^DENTDC1:'$D(DO) G ^DENTDCM:X<0,F:DO(2)<0!$D(DF) S DD=$D(^DD(+DO(2),.001)),DS=$P(^(.01,0),"^",2) I $D(@(DIC_"X)")) G:'DD P:DS["N"!'$O(^("A[")) S Y=X D S G GOT:$T
30P I DS["P"!(DS["V"),DIC(0)'["U" S (DD,DS)=0 G M
31 G F
32 ;
33PGM K DIPGM I DIC(0)'["I",'$D(DF),$D(@(DIC_"0)")),$D(^DD(+$P(^(0),U,2),0,"DIC"))#2,"DI"'[$E(^("DIC"),1,2) S DIPGM=U_^("DIC")
34 Q
351 ;
36 D S G GOT:$T,F
37 ;
38 ;Naked reference in MN refs. to line tag: PGM^D
39MN S DZ=$S(DIC(0)["D":1,$D(^(Y))-1:0,1:^(Y)) D:'$D(DO) DO^DENTDC1 I 'DZ,'$D(DO("SCR")),$L(DIX)<30,D="B",'$D(DIC("S")) S DIY="" Q
40 D S S:D="B"&'DZ&($P(DIY,DIX,1)="") DIY=$P(DIY,DIX,2,9) Q
41 ;
42S D:'$D(DO) DO^DENTDC1 I $D(@(DIC_"Y,0)")) S DIY=$P(^(0),"^",1)
43 E S DIY="" Q
44 X:$D(DIC("S")) DIC("S") Q:'$T!'$D(DO("SCR")) I $D(@(DIC_"Y,0)")) X DO("SCR")
45 Q
46 ;
47Y X DJCP S Y=$O(@(DIC_"D,DIX,Y)"))
48 I Y="" S Y=-1
49DIY I Y<0 G DIX:DIC(0)'["O"&(DIC(0)["E"),G:DS=1&(D="B")&(DIX=X),DIX
50 D MN E G Y
51K F DZ=1:1:DS I $D(DS(DZ)),+DS(DZ)=Y,DIC(0)'["C" G Y
52 D DS^DENTDC1:'$D(DISMN) I $S<DISMN F DZ=1:1:DS-7 K DS(DZ),DIY(DZ)
53 S DS=DS+1,DS(DS)=Y_"^"_$P(DIX,X,2,99),DIY(DS)=DIY G Y:DS#5-1,Y:DS=1,Y:DIC(0)["Y",Y^DENTDC1
54 ;
55G S DIY=1,DIX=X I DIC(0)["E",DIC(0)'["D",'$D(DICRS) W $P(DS(1),"^",2)
56C S Y=+DS(DIY),X=X_$P(DS(DIY),"^",2),DIY=DIY(DIY)
57GOT D WO^DENTDC1:DIC(0)["E" S Y=Y_"^"_$S(DIY="":X,1:DIY) I DIC(0)["E",DO(2)["O" G OK^DENTDC1
58R I DIC(0)'["F",$D(DUZ)#2 S ^DISV(DUZ,$E(DIC,1,28))=$E(DIC,29,999)_+Y
59 I DIC(0)["Z" K D S:$D(C) D=C S Y(0)=@(DIC_"+Y,0)"),DJC=+DO(2),DS=Y,Y=$P(Y(0),U,1) D Y^DENTDCM2 K DJC S Y(0,0)=Y,Y=DS,Y(0)=@(DIC_"+Y,0)") S:$D(D) C=D
60 X:$D(^DD(+DO(2),0,"ACT"))#2 ^("ACT") S:'$D(Y) Y=-1 I $D(@(DIC_"+Y,0)"))
61Q K DID,DISMN,DIC("W"),DINUM,DS,DF,DD,DIX,DIY,DZ,DO,D Q
62 ;
63D S D=$S($D(DF):DF,1:"B") S:$D(DID(1)) DID(1)=2 Q
64 ;
65IX S DF=D G EN
66 ;
67A K DIY,DS I DIC(0)["A" D D G ASK
68NO S Y=-1 G Q
Note: See TracBrowser for help on using the repository browser.