ADEGRL5 ; IHS/HQT/MJL - DENTAL ENTRY PART 7 ; [ 03/24/1999 9:04 AM ]
;;6.0;ADE;**13**;APRIL 1999
;------->INITIALIZE
S ADEDENT=$P(Y(0),U,2)
S3 ;
S ADEDIC("S")="" ;Remove this variable when you get a chance ***
;IHS/SET/HMW 3-26-2003 **13** Removed following line since CDT-4 codes apply to
; both PRIMARY and PERMANENT teeth
;I ADEDENT["DECID"!(ADEDENT["PRIM") S ADEDIC("S")="I $P(^ADEOPS(Y,0),U)[""DECID"""
W !,"OPSITE: "
S ADEDEF=$S($D(ADEV(ADECOD)):ADEV(ADECOD),1:"")
I ADEDEF]"" S ADEDEF=$$OPDFLT(ADEDEF)
W:ADEDEF]"" ADEDEF_" // "
R ADEOP:DTIME S:('$T)!(ADEOP="^") ADEOP=""
I ADEOP="",ADEDEF]"" Q
I ADEOP=""!(ADEOP["@"),ADEDEF="" K ADEV(ADECOD),ADEDES(ADECOD) Q
I ADEOP["@",ADEDEF'["," K ADEV(ADECOD),ADEDES(ADECOD) Q
I ADEOP["?" S XQH="ADE-DVIS-OPSITE1" D EN^XQH K XQH D LIST^ADEGRL3 W !,"ADA Code: ",ADECOD W:ADECON !,"FEE: ",$P(ADEV(ADECOD),U,3) G S3
I ADEOP["@" S ADEDEL=$P(ADEOP,"@",2) D OPDEL G:$P(ADEV(ADECOD),U,2)="" S3 Q
K ADEADD I ADEOP["+" S ADEOP=$P(ADEOP,"+",2),ADEADD=1
PARSE ;
S ADEOP=$$SPLIT(ADEOP),ADESFC=$P(ADEOP,U,2),ADEOP=$P(ADEOP,U)
F J=1:1:$L(ADEOP,",") S ADEPC=$P(ADEOP,",",J) D VEROP Q:$D(ADENOOP) S $P(ADEOP,",",J)=+Y
I $D(ADENOOP) K ADENOOP W *7,ADEPC," ??" K ADEOP,ADESFC,ADEADD G S3
I $$DUPE^ADEGRL5C(ADEOP) W *7," --DUPE OPSITES NOT ALLOWED" K ADEOP,ADESFC,ADEADD G S3
F J=1:1:$L(ADEOP,",") S ADEPC=$P(ADESFC,",",J) I '$$VERSFC(ADEPC) W *7," '",ADEPC,"' IS NOT A VALID SURFACE" K ADEOP,ADESFC,ADEADD G S3
I $D(ADEADD),$D(ADEV(ADECOD)) D
. S ADEV(ADECOD)=$$ADDOP(ADEOP,ADESFC,ADEV(ADECOD))
E S $P(ADEV(ADECOD),U)=$L(ADEOP,","),$P(ADEV(ADECOD),U,2)=ADEOP,$P(ADEV(ADECOD),U,4)=ADESFC
K ADEOP,ADESFC,ADEADD
Q
;
;***SUBROUTINES***
;
;
VEROP ;B FHL 9/9/98
K DIC S Y=-1,X=ADEPC,DIC="^ADEOPS("
I ADEDIC("S")]"" S DIC(0)="Z",D="C",DIC("S")=ADEDIC("S") D MIX^DIC1 G:Y>0 VQ
I X?1.2N1"D" S DIC(0)="Z",D="C" D MIX^DIC1 G:Y>0 VQ ;IHS/HMW **2,12**
I Y=-1 K Y S DIC(0)="OXZ" S:ADEDIC("S")'="" DIC("S")=ADEDIC("S") D ^DIC
I Y=-1 K Y S DIC(0)="EQZ" S:ADEDIC("S")'="" DIC("S")=ADEDIC("S") W !!,ADEPC D ^DIC
I Y=-1 S ADENOOP=1 K DIC Q
VQ K DIC
Q
;
OPDEL G:ADEDEL'="" OPD1
D LIST^ADEGRL3 K K S $P(K,"-",35)="Delete Opsite",$P(K,"-",66)="" W !,K K K
W !!,?2,ADECOD,?13,"DELETE WHICH OPSITE: " R ADEDEL:DTIME
I '$T W " ??",*7 Q
Q:ADEDEL=""
OPD1 S ADEPC=ADEDEL D VEROP I $D(ADENOOP) K ADENOOP,ADEDEL Q
S ADEDEL=+Y
S ADEV(ADECOD)=$$DELOP^ADEGRL5C(ADEDEL,ADEV(ADECOD))
Q
;
;***FUNCTIONS***
;
SPLIT(ADEOP) ;Splits Opsites and Surfaces from user input string
N ADECNT,ADEJ,ADEPC,ADESFC
S ADESFC="",ADECNT=0
F ADEJ=1:1:$L(ADEOP,",") S ADEPC=$P(ADEOP,",",ADEJ) I ADEPC["/" S ADECNT=ADECNT+1,$P(ADESFC,",",ADECNT)=$P(ADEPC,"/",2)
S ADECNT=1
F ADEJ=1:1:$L(ADEOP,",") S:$P(ADEOP,",",ADEJ)["/" ADECNT=ADECNT+1 S:$P(ADEOP,",",ADEJ)'["/" $P(ADEOP,",",ADEJ)=$P(ADEOP,",",ADEJ)_"/"_$P(ADESFC,",",ADECNT)
S ADESFC=""
F ADEJ=1:1:$L(ADEOP,",") S ADEPC=$P(ADEOP,",",ADEJ),$P(ADEOP,",",ADEJ)=$P(ADEPC,"/"),$P(ADESFC,",",ADEJ)=$P(ADEPC,"/",2)
Q ADEOP_"^"_ADESFC
;
OPDFLT(ADEDEF) ;Creates default user input string from ADEV(ADECOD)
N ADEOPS,ADESFC,ADEJ,ADEPC,ADEOPC
S ADEOPS=$P(ADEDEF,U,2)
S ADESFC=$P(ADEDEF,U,4)
F ADEJ=1:1:$P(ADEDEF,U) D
. I $D(ADEPLET),$P(^ADEOPS($P(ADEOPS,",",ADEJ),0),U,4)]"" S $P(ADEOPS,",",ADEJ)=$P(^ADEOPS($P(ADEOPS,",",ADEJ),0),U,4) Q
. S $P(ADEOPS,",",ADEJ)=^ADEOPS($P(ADEOPS,",",ADEJ),88)
S ADEOPC=0
F ADEJ=$P(ADEDEF,U):-1:1 S ADEPC=$P(ADESFC,",",ADEJ) S:ADEOPC'=ADEPC ADEOPC=ADEPC,$P(ADEOPS,",",ADEJ)=$P(ADEOPS,",",ADEJ)_"/"_ADEOPC
Q ADEOPS
K ADEOPS ;*NE
;
VERSFC(ADEX) ;Verify surface codes - Returns 1 if valid, 0 if not valid
;Need to add additional parameter for ADA CODE
N ADEY,ADEP,ADEI
S ADEY=1
I $L(ADEX)>6 Q 0
I (ADEX["B")&(ADEX["F") Q 0
I (ADEX["I")&(ADEX["O") Q 0
F ADEI=1:1:$L(ADEX) S ADEP=$E(ADEX,ADEI) I '((ADEP="M")!(ADEP="O")!(ADEP="D")!(ADEP="F")!(ADEP="L")!(ADEP="B")!(ADEP="I"))!($F(ADEX,ADEP,$F(ADEX,ADEP)))>0 S ADEY=0 Q
Q ADEY
K ADEP ;*NE
;
ADDOP(ADEOP,ADESFC,ADEVTMP) ;EP - Search for same opsite in existing ADEV(ADECOD).
;If found, delete it. Then add opsite ADEOP and surface ADESFC
N ADEJ,ADEPC,ADEK,ADEPC2
;S ADEVTMP=ADEV(ADECOD)
I ADEVTMP]"" F ADEJ=1:1:$L(ADEOP,",") S ADEPC=$P(ADEOP,",",ADEJ) D ADD1
I ADEVTMP]"" S $P(ADEVTMP,U)=$P(ADEVTMP,U)+$L(ADEOP,","),$P(ADEVTMP,U,2)=$P(ADEVTMP,U,2)_","_ADEOP,$P(ADEVTMP,U,4)=$P(ADEVTMP,U,4)_","_ADESFC
I ADEVTMP="" S $P(ADEVTMP,U)=$L(ADEOP,","),$P(ADEVTMP,U,2)=ADEOP,$P(ADEVTMP,U,4)=ADESFC
Q ADEVTMP
K ADEPC2,ADEVTMP ;*NE
ADD1 F ADEK=1:1:$P(ADEVTMP,U) S ADEPC2=$P($P(ADEVTMP,U,2),",",ADEK) I ADEPC=ADEPC2 S ADEVTMP=$$DELOP^ADEGRL5C(ADEPC2,ADEVTMP)
Q
ADEGRL5 ; IHS/HQT/MJL - DENTAL ENTRY PART 7 ; [ 03/24/1999 9:04 AM ]
+1 ;;6.0;ADE;**13**;APRIL 1999
+2 ;------->INITIALIZE
+3 SET ADEDENT=$PIECE(Y(0),U,2)
S3 ;
+1 ;Remove this variable when you get a chance ***
SET ADEDIC("S")=""
+2 ;IHS/SET/HMW 3-26-2003 **13** Removed following line since CDT-4 codes apply to
+3 ; both PRIMARY and PERMANENT teeth
+4 ;I ADEDENT["DECID"!(ADEDENT["PRIM") S ADEDIC("S")="I $P(^ADEOPS(Y,0),U)[""DECID"""
+5 WRITE !,"OPSITE: "
+6 SET ADEDEF=$SELECT($DATA(ADEV(ADECOD)):ADEV(ADECOD),1:"")
+7 IF ADEDEF]""
SET ADEDEF=$$OPDFLT(ADEDEF)
+8 IF ADEDEF]""
WRITE ADEDEF_" // "
+9 READ ADEOP:DTIME
IF ('$TEST)!(ADEOP="^")
SET ADEOP=""
+10 IF ADEOP=""
IF ADEDEF]""
QUIT
+11 IF ADEOP=""!(ADEOP["@")
IF ADEDEF=""
KILL ADEV(ADECOD),ADEDES(ADECOD)
QUIT
+12 IF ADEOP["@"
IF ADEDEF'[","
KILL ADEV(ADECOD),ADEDES(ADECOD)
QUIT
+13 IF ADEOP["?"
SET XQH="ADE-DVIS-OPSITE1"
DO EN^XQH
KILL XQH
DO LIST^ADEGRL3
WRITE !,"ADA Code: ",ADECOD
IF ADECON
WRITE !,"FEE: ",$PIECE(ADEV(ADECOD),U,3)
GOTO S3
+14 IF ADEOP["@"
SET ADEDEL=$PIECE(ADEOP,"@",2)
DO OPDEL
IF $PIECE(ADEV(ADECOD),U,2)=""
GOTO S3
QUIT
+15 KILL ADEADD
IF ADEOP["+"
SET ADEOP=$PIECE(ADEOP,"+",2)
SET ADEADD=1
PARSE ;
+1 SET ADEOP=$$SPLIT(ADEOP)
SET ADESFC=$PIECE(ADEOP,U,2)
SET ADEOP=$PIECE(ADEOP,U)
+2 FOR J=1:1:$LENGTH(ADEOP,",")
SET ADEPC=$PIECE(ADEOP,",",J)
DO VEROP
IF $DATA(ADENOOP)
QUIT
SET $PIECE(ADEOP,",",J)=+Y
+3 IF $DATA(ADENOOP)
KILL ADENOOP
WRITE *7,ADEPC," ??"
KILL ADEOP,ADESFC,ADEADD
GOTO S3
+4 IF $$DUPE^ADEGRL5C(ADEOP)
WRITE *7," --DUPE OPSITES NOT ALLOWED"
KILL ADEOP,ADESFC,ADEADD
GOTO S3
+5 FOR J=1:1:$LENGTH(ADEOP,",")
SET ADEPC=$PIECE(ADESFC,",",J)
IF '$$VERSFC(ADEPC)
WRITE *7," '",ADEPC,"' IS NOT A VALID SURFACE"
KILL ADEOP,ADESFC,ADEADD
GOTO S3
+6 IF $DATA(ADEADD)
IF $DATA(ADEV(ADECOD))
Begin DoDot:1
+7 SET ADEV(ADECOD)=$$ADDOP(ADEOP,ADESFC,ADEV(ADECOD))
End DoDot:1
+8 IF '$TEST
SET $PIECE(ADEV(ADECOD),U)=$LENGTH(ADEOP,",")
SET $PIECE(ADEV(ADECOD),U,2)=ADEOP
SET $PIECE(ADEV(ADECOD),U,4)=ADESFC
+9 KILL ADEOP,ADESFC,ADEADD
+10 QUIT
+11 ;
+12 ;***SUBROUTINES***
+13 ;
+14 ;
VEROP ;B FHL 9/9/98
+1 KILL DIC
SET Y=-1
SET X=ADEPC
SET DIC="^ADEOPS("
+2 IF ADEDIC("S")]""
SET DIC(0)="Z"
SET D="C"
SET DIC("S")=ADEDIC("S")
DO MIX^DIC1
IF Y>0
GOTO VQ
+3 ;IHS/HMW **2,12**
IF X?1.2N1"D"
SET DIC(0)="Z"
SET D="C"
DO MIX^DIC1
IF Y>0
GOTO VQ
+4 IF Y=-1
KILL Y
SET DIC(0)="OXZ"
IF ADEDIC("S")'=""
SET DIC("S")=ADEDIC("S")
DO ^DIC
+5 IF Y=-1
KILL Y
SET DIC(0)="EQZ"
IF ADEDIC("S")'=""
SET DIC("S")=ADEDIC("S")
WRITE !!,ADEPC
DO ^DIC
+6 IF Y=-1
SET ADENOOP=1
KILL DIC
QUIT
VQ KILL DIC
+1 QUIT
+2 ;
OPDEL IF ADEDEL'=""
GOTO OPD1
+1 DO LIST^ADEGRL3
KILL K
SET $PIECE(K,"-",35)="Delete Opsite"
SET $PIECE(K,"-",66)=""
WRITE !,K
KILL K
+2 WRITE !!,?2,ADECOD,?13,"DELETE WHICH OPSITE: "
READ ADEDEL:DTIME
+3 IF '$TEST
WRITE " ??",*7
QUIT
+4 IF ADEDEL=""
QUIT
OPD1 SET ADEPC=ADEDEL
DO VEROP
IF $DATA(ADENOOP)
KILL ADENOOP,ADEDEL
QUIT
+1 SET ADEDEL=+Y
+2 SET ADEV(ADECOD)=$$DELOP^ADEGRL5C(ADEDEL,ADEV(ADECOD))
+3 QUIT
+4 ;
+5 ;***FUNCTIONS***
+6 ;
SPLIT(ADEOP) ;Splits Opsites and Surfaces from user input string
+1 NEW ADECNT,ADEJ,ADEPC,ADESFC
+2 SET ADESFC=""
SET ADECNT=0
+3 FOR ADEJ=1:1:$LENGTH(ADEOP,",")
SET ADEPC=$PIECE(ADEOP,",",ADEJ)
IF ADEPC["/"
SET ADECNT=ADECNT+1
SET $PIECE(ADESFC,",",ADECNT)=$PIECE(ADEPC,"/",2)
+4 SET ADECNT=1
+5 FOR ADEJ=1:1:$LENGTH(ADEOP,",")
IF $PIECE(ADEOP,",",ADEJ)["/"
SET ADECNT=ADECNT+1
IF $PIECE(ADEOP,",",ADEJ)'["/"
SET $PIECE(ADEOP,",",ADEJ)=$PIECE(ADEOP,",",ADEJ)_"/"_$PIECE(ADESFC,",",ADECNT)
+6 SET ADESFC=""
+7 FOR ADEJ=1:1:$LENGTH(ADEOP,",")
SET ADEPC=$PIECE(ADEOP,",",ADEJ)
SET $PIECE(ADEOP,",",ADEJ)=$PIECE(ADEPC,"/")
SET $PIECE(ADESFC,",",ADEJ)=$PIECE(ADEPC,"/",2)
+8 QUIT ADEOP_"^"_ADESFC
+9 ;
OPDFLT(ADEDEF) ;Creates default user input string from ADEV(ADECOD)
+1 NEW ADEOPS,ADESFC,ADEJ,ADEPC,ADEOPC
+2 SET ADEOPS=$PIECE(ADEDEF,U,2)
+3 SET ADESFC=$PIECE(ADEDEF,U,4)
+4 FOR ADEJ=1:1:$PIECE(ADEDEF,U)
Begin DoDot:1
+5 IF $DATA(ADEPLET)
IF $PIECE(^ADEOPS($PIECE(ADEOPS,",",ADEJ),0),U,4)]""
SET $PIECE(ADEOPS,",",ADEJ)=$PIECE(^ADEOPS($PIECE(ADEOPS,",",ADEJ),0),U,4)
QUIT
+6 SET $PIECE(ADEOPS,",",ADEJ)=^ADEOPS($PIECE(ADEOPS,",",ADEJ),88)
End DoDot:1
+7 SET ADEOPC=0
+8 FOR ADEJ=$PIECE(ADEDEF,U):-1:1
SET ADEPC=$PIECE(ADESFC,",",ADEJ)
IF ADEOPC'=ADEPC
SET ADEOPC=ADEPC
SET $PIECE(ADEOPS,",",ADEJ)=$PIECE(ADEOPS,",",ADEJ)_"/"_ADEOPC
+9 QUIT ADEOPS
+10 ;*NE
KILL ADEOPS
+11 ;
VERSFC(ADEX) ;Verify surface codes - Returns 1 if valid, 0 if not valid
+1 ;Need to add additional parameter for ADA CODE
+2 NEW ADEY,ADEP,ADEI
+3 SET ADEY=1
+4 IF $LENGTH(ADEX)>6
QUIT 0
+5 IF (ADEX["B")&(ADEX["F")
QUIT 0
+6 IF (ADEX["I")&(ADEX["O")
QUIT 0
+7 FOR ADEI=1:1:$LENGTH(ADEX)
SET ADEP=$EXTRACT(ADEX,ADEI)
IF '((ADEP="M")!(ADEP="O")!(ADEP="D")!(ADEP="F")!(ADEP="L")!(ADEP="B")!(ADEP="I"))!($FIND(ADEX,ADEP,$FIND(ADEX,ADEP)))>0
SET ADEY=0
QUIT
+8 QUIT ADEY
+9 ;*NE
KILL ADEP
+10 ;
ADDOP(ADEOP,ADESFC,ADEVTMP) ;EP - Search for same opsite in existing ADEV(ADECOD).
+1 ;If found, delete it. Then add opsite ADEOP and surface ADESFC
+2 NEW ADEJ,ADEPC,ADEK,ADEPC2
+3 ;S ADEVTMP=ADEV(ADECOD)
+4 IF ADEVTMP]""
FOR ADEJ=1:1:$LENGTH(ADEOP,",")
SET ADEPC=$PIECE(ADEOP,",",ADEJ)
DO ADD1
+5 IF ADEVTMP]""
SET $PIECE(ADEVTMP,U)=$PIECE(ADEVTMP,U)+$LENGTH(ADEOP,",")
SET $PIECE(ADEVTMP,U,2)=$PIECE(ADEVTMP,U,2)_","_ADEOP
SET $PIECE(ADEVTMP,U,4)=$PIECE(ADEVTMP,U,4)_","_ADESFC
+6 IF ADEVTMP=""
SET $PIECE(ADEVTMP,U)=$LENGTH(ADEOP,",")
SET $PIECE(ADEVTMP,U,2)=ADEOP
SET $PIECE(ADEVTMP,U,4)=ADESFC
+7 QUIT ADEVTMP
+8 ;*NE
KILL ADEPC2,ADEVTMP
ADD1 FOR ADEK=1:1:$PIECE(ADEVTMP,U)
SET ADEPC2=$PIECE($PIECE(ADEVTMP,U,2),",",ADEK)
IF ADEPC=ADEPC2
SET ADEVTMP=$$DELOP^ADEGRL5C(ADEPC2,ADEVTMP)
+1 QUIT
