ADEGRL5.m

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