- DENTCRD1 ;ISC2/HCD,SAW-PROCESS DENTAL CARDS (CON'T) ;9/24/99 09:26
- ;;1.2;DENTAL;**3,11,13,16,19,21,24,28**;JAN 26, 1989
- C S:X=" " X="" I X=""&($P(^DD(221,F,0),"^",2)'["R") G A
- X $P(^DD(221,F,0),"^",5,99) I '$D(X) S E1=1 G E
- A Q:E S D2=D2_X_"^" Q
- E S E=1 W !,"ERROR--",$P(^DD(221,F,0),"^",1)," entry is incorrect." Q
- F S X=$S(X=8:10,X=9:20,1:""),X=$S(X1=" ":X,1:X+X1) Q
- CC ;;.01;1;.5;3;4;5;6;7;8;.4;10;11;12;38;14;15;16;17;4.5;19;39;21;22;23;24;25;6.7;27;28;29;30;31;32;33;34;35;36;37;2;.3;7.1;6.2;6.4;6.6;6.8
- DATE ;;31;28;31;30;31;30;31;31;30;31;30;31
- YN Q:$D(E1) W !,"Okay to accept this value" S %=2 D YN^DICN G YN:%=0 K:%'=1 X Q
- EN W !,D S E=0,D2="" F I=1:1:45 S F=$P($T(CC),";",I+2) D @I
- K:E D2 G ^DENTCRD2
- 1 ;
- S L1=$E(D,14),L2=$E(D,15),L3=$E(D,16),L4=$E(D,17),L5=$E(D,18)
- I L1'=" " G:L2 ERR S Z=L1+1 G DAY
- G:L2=" " ERR S Z=L2+3
- DAY G:Z<1!(Z>12) ERR S ZZ=$P($T(DATE),";",Z+2)
- I Z=2 S ZZ=ZZ+$$LEAP^DENTE1(1700+$E(DT,1,3))
- I $L(Z)=1 S Z=0_Z
- S L3=$S(L3=7:10,L3=8:20,L3=9:30,1:0),L4=$S(L4=" "!(L4>8):0,1:L4+1),L4=L3+L4 G:L4<1!(L4>ZZ) ERR I $L(L4)=1 S L4=0_L4
- S L5=$E(DT,2,3),L6=$E(DT,1)_L5_"01" S:DENTY XX1=$$YR(L6),L5=$E(XX1,2,3) S:$L(L5)=1 L5=0_L5 S (D1,Z)=$S(DENTY:$E(XX1,1),1:$E(DT,1))_L5_Z_L4
- I Z'>DT D NOW^%DTC S Z=Z_"."_$P(%,".",2),Z=+Z,Z=$$CHECK^DENTE1(221,Z),(DINUM,D1)=Z G OK
- ERR S D2("B")="" G E
- OK S X=D1 D A S D2("B")=X,D2("B1")=X Q
- YR(DENTX1) ; Get last Year
- S X1=DENTX1_"01",X2=-1 D C^%DTC S ZZ=$E(X,1,3)_$E(DENTX1,4,7)
- Q ZZ
- 2 S X=$E(D,5,13) I X'?9N G E
- I +X=1 D A S D2("D")=X,D1(39)="GROUP" Q
- S Z=$O(^DPT("SSN",X,0)) S:Z="" X=X_"P",Z=$O(^DPT("SSN",X,0))
- D:Z="" E Q:E D A S DFN=Z,DENTI=I,DENTX=X D DEM^VADPT S I=DENTI,X=DENTX,D1(39)=VADM(1),D2("D")=X,(D2("E"),D39)=Z K DENTI,DENTX Q
- ;D A S D2("D")=X Q
- 3 S X=$E(D,1,4),Z=X,X=$O(^DENT(220.5,"C",X,0))
- I $D(^DENT(220.5,+X,0)),$P(^(0),"^",3)="" D A S (D1(10),D2("C"))=Z,(D2("AC"),D2("AC1"))=DENTSTA_","_D2("B")_","_Z Q
- G E
- ;S X=$E(D,1,4) D:X'?4N E Q:E D A S (D1(10),D2("C"))=X,(D2("AC"),D2("AC1"))=DENTSTA_","_D2("B")_","_X Q
- 4 S X=$S($D(D39):D39,1:"") G A
- 5 S X="" G A
- 6 S Z1=$E(D,22),Z2=$E(D,23) I Z1=" "&(Z2=" ") S X="" G A
- S X=$S(Z1'=" "&(Z2'=" "):"",Z1'=" ":Z1+1,Z2'=" ":Z2+8) I X<1!(X>15) S X="" G E
- G A
- 7 S X=$E(D,24),X=$S(X=0:"S",X=1:"C",1:"") G A
- 8 S X=$E(D,31),X=$S(X=4:1,1:"") G A
- 9 S X=$E(D,32) G C
- 10 S X=$S($D(D1(10)):D1(10),1:"") G A
- 11 S X=$E(D,33),X1=$E(D,34) D F G C
- 12 S X=$E(D,35),X=$S(X=1:1,1:"") G A
- 13 S X=$E(D,36),X=$S(X=1:1,1:"") G A
- 14 S X=$E(D,67),X=$S(X=1:1,1:"") G A
- 15 S X=$E(D,37) G C
- 16 S X=$E(D,38) G C
- 17 S X=$E(D,39) G C
- 18 S X=$E(D,40) G C
- 19 S X1=0 F I(1)=19,20,21 I $E(D,I(1))'=" " S X1=X1+1,X=$E(D,I(1)),Z=I(1)
- I X1>1 S E=1 W !,"ERROR-- More than one patient category has been marked." Q
- I X1=0 S E=1 W !,"ERROR-- Patient category is missing." Q
- S X=$S(Z=19:X+1,Z=20:X+8,1:X+13) D:Z=19&((X>8)!(X<1)) E D:Z=20&((X>17)!(X<9)) E D:Z=21&((X>22)!(X<18)) E Q:E G A
- 20 S X=$E(D,41),X1=$E(D,42),X=$S(X=" ":"",1:X*10),X=$S(X1=" ":X,1:X+X1) G C
- 21 S X="" G A
- 22 S X=$E(D,43),X1=$E(D,44),X=$S(X=7:10,X=8:20,X=9:30,1:""),X=$S(X1=" ":X,1:X+X1) G C
- 23 S X=$E(D,45) G C
- 24 S X=$E(D,46) G C
- 25 S X=$E(D,47) G C
- 26 S X=$E(D,48),X=$S(X=1&(+$E(D,5,13)=1):4,X=1&(+$E(D,5,13)'=1):3,1:"") G A
- 27 S X=$E(D,28),X=$S(X=7:1,X=8:3,1:"") G A
- 28 S X=$E(D,49),X1=$E(D,50) D F G C
- 29 S X=$E(D,51),X1=$E(D,52) D F G C
- 30 S X=$E(D,53),X1=$E(D,54) D F G C
- 31 S X=$E(D,55),X1=$E(D,56),X=$S(X=7:0,X=8:10,X=9:20,1:""),X=$S(X1=" ":X,1:X+X1) G C
- 32 S X=$E(D,57) G C
- 33 S X=$E(D,58) G C
- 34 S X=$E(D,59) G C
- 35 S X=$E(D,60),X1=$E(D,61),X=$S(X=" ":"",1:X*10),X=$S(X1=" ":X,1:X+X1) G C
- 36 S X=$E(D,62),X1=$E(D,63) D F G C
- 37 S X=$E(D,64) G C
- 38 S X=$E(D,65),X1=$E(D,66),X=$S(X=7:10,X=8:20,X=9:30,1:""),X=$S(X1=" ":X,1:X+X1) G C
- 39 S X=$S($D(D1(39)):D1(39),1:"") G A
- 40 S X=DENTSTA D A Q:E S (D2("A"),D2("A1"))=DENTSTA_","_D2("B") Q
- 41 S X=$E(D,30),X=$S(X=1:3,X=2:2,1:"") G C
- 42 S X=$E(D,25),X=$S(X=2:1,1:"") G A
- 43 S X=$E(D,26),X=$S(X=3:1,1:"") G A
- 44 S X=$E(D,27),X=$S(X=4:2,1:"") G A
- 45 S X=$E(D,29),X=$S(X>5:X-6,1:X) G C
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDENTCRD1 4096 printed Mar 13, 2025@20:50:47 Page 2
- DENTCRD1 ;ISC2/HCD,SAW-PROCESS DENTAL CARDS (CON'T) ;9/24/99 09:26
- +1 ;;1.2;DENTAL;**3,11,13,16,19,21,24,28**;JAN 26, 1989
- C if X=" "
- SET X=""
- IF X=""&($PIECE(^DD(221,F,0),"^",2)'["R")
- GOTO A
- +1 XECUTE $PIECE(^DD(221,F,0),"^",5,99)
- IF '$DATA(X)
- SET E1=1
- GOTO E
- A if E
- QUIT
- SET D2=D2_X_"^"
- QUIT
- E SET E=1
- WRITE !,"ERROR--",$PIECE(^DD(221,F,0),"^",1)," entry is incorrect."
- QUIT
- F SET X=$SELECT(X=8:10,X=9:20,1:"")
- SET X=$SELECT(X1=" ":X,1:X+X1)
- QUIT
- CC ;;.01;1;.5;3;4;5;6;7;8;.4;10;11;12;38;14;15;16;17;4.5;19;39;21;22;23;24;25;6.7;27;28;29;30;31;32;33;34;35;36;37;2;.3;7.1;6.2;6.4;6.6;6.8
- DATE ;;31;28;31;30;31;30;31;31;30;31;30;31
- YN if $DATA(E1)
- QUIT
- WRITE !,"Okay to accept this value"
- SET %=2
- DO YN^DICN
- if %=0
- GOTO YN
- if %'=1
- KILL X
- QUIT
- EN WRITE !,D
- SET E=0
- SET D2=""
- FOR I=1:1:45
- SET F=$PIECE($TEXT(CC),";",I+2)
- DO @I
- +1 if E
- KILL D2
- GOTO ^DENTCRD2
- 1 ;
- +1 SET L1=$EXTRACT(D,14)
- SET L2=$EXTRACT(D,15)
- SET L3=$EXTRACT(D,16)
- SET L4=$EXTRACT(D,17)
- SET L5=$EXTRACT(D,18)
- +2 IF L1'=" "
- if L2
- GOTO ERR
- SET Z=L1+1
- GOTO DAY
- +3 if L2=" "
- GOTO ERR
- SET Z=L2+3
- DAY if Z<1!(Z>12)
- GOTO ERR
- SET ZZ=$PIECE($TEXT(DATE),";",Z+2)
- +1 IF Z=2
- SET ZZ=ZZ+$$LEAP^DENTE1(1700+$EXTRACT(DT,1,3))
- +2 IF $LENGTH(Z)=1
- SET Z=0_Z
- +3 SET L3=$SELECT(L3=7:10,L3=8:20,L3=9:30,1:0)
- SET L4=$SELECT(L4=" "!(L4>8):0,1:L4+1)
- SET L4=L3+L4
- if L4<1!(L4>ZZ)
- GOTO ERR
- IF $LENGTH(L4)=1
- SET L4=0_L4
- +4 SET L5=$EXTRACT(DT,2,3)
- SET L6=$EXTRACT(DT,1)_L5_"01"
- if DENTY
- SET XX1=$$YR(L6)
- SET L5=$EXTRACT(XX1,2,3)
- if $LENGTH(L5)=1
- SET L5=0_L5
- SET (D1,Z)=$SELECT(DENTY:$EXTRACT(XX1,1),1:$EXTRACT(DT,1))_L5_Z_L4
- +5 IF Z'>DT
- DO NOW^%DTC
- SET Z=Z_"."_$PIECE(%,".",2)
- SET Z=+Z
- SET Z=$$CHECK^DENTE1(221,Z)
- SET (DINUM,D1)=Z
- GOTO OK
- ERR SET D2("B")=""
- GOTO E
- OK SET X=D1
- DO A
- SET D2("B")=X
- SET D2("B1")=X
- QUIT
- YR(DENTX1) ; Get last Year
- +1 SET X1=DENTX1_"01"
- SET X2=-1
- DO C^%DTC
- SET ZZ=$EXTRACT(X,1,3)_$EXTRACT(DENTX1,4,7)
- +2 QUIT ZZ
- 2 SET X=$EXTRACT(D,5,13)
- IF X'?9N
- GOTO E
- +1 IF +X=1
- DO A
- SET D2("D")=X
- SET D1(39)="GROUP"
- QUIT
- +2 SET Z=$ORDER(^DPT("SSN",X,0))
- if Z=""
- SET X=X_"P"
- SET Z=$ORDER(^DPT("SSN",X,0))
- +3 if Z=""
- DO E
- if E
- QUIT
- DO A
- SET DFN=Z
- SET DENTI=I
- SET DENTX=X
- DO DEM^VADPT
- SET I=DENTI
- SET X=DENTX
- SET D1(39)=VADM(1)
- SET D2("D")=X
- SET (D2("E"),D39)=Z
- KILL DENTI,DENTX
- QUIT
- +4 ;D A S D2("D")=X Q
- 3 SET X=$EXTRACT(D,1,4)
- SET Z=X
- SET X=$ORDER(^DENT(220.5,"C",X,0))
- +1 IF $DATA(^DENT(220.5,+X,0))
- IF $PIECE(^(0),"^",3)=""
- DO A
- SET (D1(10),D2("C"))=Z
- SET (D2("AC"),D2("AC1"))=DENTSTA_","_D2("B")_","_Z
- QUIT
- +2 GOTO E
- +3 ;S X=$E(D,1,4) D:X'?4N E Q:E D A S (D1(10),D2("C"))=X,(D2("AC"),D2("AC1"))=DENTSTA_","_D2("B")_","_X Q
- 4 SET X=$SELECT($DATA(D39):D39,1:"")
- GOTO A
- 5 SET X=""
- GOTO A
- 6 SET Z1=$EXTRACT(D,22)
- SET Z2=$EXTRACT(D,23)
- IF Z1=" "&(Z2=" ")
- SET X=""
- GOTO A
- +1 SET X=$SELECT(Z1'=" "&(Z2'=" "):"",Z1'=" ":Z1+1,Z2'=" ":Z2+8)
- IF X<1!(X>15)
- SET X=""
- GOTO E
- +2 GOTO A
- 7 SET X=$EXTRACT(D,24)
- SET X=$SELECT(X=0:"S",X=1:"C",1:"")
- GOTO A
- 8 SET X=$EXTRACT(D,31)
- SET X=$SELECT(X=4:1,1:"")
- GOTO A
- 9 SET X=$EXTRACT(D,32)
- GOTO C
- 10 SET X=$SELECT($DATA(D1(10)):D1(10),1:"")
- GOTO A
- 11 SET X=$EXTRACT(D,33)
- SET X1=$EXTRACT(D,34)
- DO F
- GOTO C
- 12 SET X=$EXTRACT(D,35)
- SET X=$SELECT(X=1:1,1:"")
- GOTO A
- 13 SET X=$EXTRACT(D,36)
- SET X=$SELECT(X=1:1,1:"")
- GOTO A
- 14 SET X=$EXTRACT(D,67)
- SET X=$SELECT(X=1:1,1:"")
- GOTO A
- 15 SET X=$EXTRACT(D,37)
- GOTO C
- 16 SET X=$EXTRACT(D,38)
- GOTO C
- 17 SET X=$EXTRACT(D,39)
- GOTO C
- 18 SET X=$EXTRACT(D,40)
- GOTO C
- 19 SET X1=0
- FOR I(1)=19,20,21
- IF $EXTRACT(D,I(1))'=" "
- SET X1=X1+1
- SET X=$EXTRACT(D,I(1))
- SET Z=I(1)
- +1 IF X1>1
- SET E=1
- WRITE !,"ERROR-- More than one patient category has been marked."
- QUIT
- +2 IF X1=0
- SET E=1
- WRITE !,"ERROR-- Patient category is missing."
- QUIT
- +3 SET X=$SELECT(Z=19:X+1,Z=20:X+8,1:X+13)
- if Z=19&((X>8)!(X<1))
- DO E
- if Z=20&((X>17)!(X<9))
- DO E
- if Z=21&((X>22)!(X<18))
- DO E
- if E
- QUIT
- GOTO A
- 20 SET X=$EXTRACT(D,41)
- SET X1=$EXTRACT(D,42)
- SET X=$SELECT(X=" ":"",1:X*10)
- SET X=$SELECT(X1=" ":X,1:X+X1)
- GOTO C
- 21 SET X=""
- GOTO A
- 22 SET X=$EXTRACT(D,43)
- SET X1=$EXTRACT(D,44)
- SET X=$SELECT(X=7:10,X=8:20,X=9:30,1:"")
- SET X=$SELECT(X1=" ":X,1:X+X1)
- GOTO C
- 23 SET X=$EXTRACT(D,45)
- GOTO C
- 24 SET X=$EXTRACT(D,46)
- GOTO C
- 25 SET X=$EXTRACT(D,47)
- GOTO C
- 26 SET X=$EXTRACT(D,48)
- SET X=$SELECT(X=1&(+$EXTRACT(D,5,13)=1):4,X=1&(+$EXTRACT(D,5,13)'=1):3,1:"")
- GOTO A
- 27 SET X=$EXTRACT(D,28)
- SET X=$SELECT(X=7:1,X=8:3,1:"")
- GOTO A
- 28 SET X=$EXTRACT(D,49)
- SET X1=$EXTRACT(D,50)
- DO F
- GOTO C
- 29 SET X=$EXTRACT(D,51)
- SET X1=$EXTRACT(D,52)
- DO F
- GOTO C
- 30 SET X=$EXTRACT(D,53)
- SET X1=$EXTRACT(D,54)
- DO F
- GOTO C
- 31 SET X=$EXTRACT(D,55)
- SET X1=$EXTRACT(D,56)
- SET X=$SELECT(X=7:0,X=8:10,X=9:20,1:"")
- SET X=$SELECT(X1=" ":X,1:X+X1)
- GOTO C
- 32 SET X=$EXTRACT(D,57)
- GOTO C
- 33 SET X=$EXTRACT(D,58)
- GOTO C
- 34 SET X=$EXTRACT(D,59)
- GOTO C
- 35 SET X=$EXTRACT(D,60)
- SET X1=$EXTRACT(D,61)
- SET X=$SELECT(X=" ":"",1:X*10)
- SET X=$SELECT(X1=" ":X,1:X+X1)
- GOTO C
- 36 SET X=$EXTRACT(D,62)
- SET X1=$EXTRACT(D,63)
- DO F
- GOTO C
- 37 SET X=$EXTRACT(D,64)
- GOTO C
- 38 SET X=$EXTRACT(D,65)
- SET X1=$EXTRACT(D,66)
- SET X=$SELECT(X=7:10,X=8:20,X=9:30,1:"")
- SET X=$SELECT(X1=" ":X,1:X+X1)
- GOTO C
- 39 SET X=$SELECT($DATA(D1(39)):D1(39),1:"")
- GOTO A
- 40 SET X=DENTSTA
- DO A
- if E
- QUIT
- SET (D2("A"),D2("A1"))=DENTSTA_","_D2("B")
- QUIT
- 41 SET X=$EXTRACT(D,30)
- SET X=$SELECT(X=1:3,X=2:2,1:"")
- GOTO C
- 42 SET X=$EXTRACT(D,25)
- SET X=$SELECT(X=2:1,1:"")
- GOTO A
- 43 SET X=$EXTRACT(D,26)
- SET X=$SELECT(X=3:1,1:"")
- GOTO A
- 44 SET X=$EXTRACT(D,27)
- SET X=$SELECT(X=4:2,1:"")
- GOTO A
- 45 SET X=$EXTRACT(D,29)
- SET X=$SELECT(X>5:X-6,1:X)
- GOTO C
