ADEMDEL.m

ADEMDEL ; IHS/HQT/MJL  - FOLLOWUP LIST DELETION ;06:50 PM  [ 03/24/1999   9:04 AM ]

 ;;6.0;ADE;;APRIL 1999

 ;CALLED AT EN WITH ADEPAT AND ADEMDFN WILL DELETE ENTRY ADEMDFN

 ;FROM ^ADEFOL AND UPDATE ^ADEPAT

 ;------->INITIALIZE

 Q:'$D(ADEREF)!'$D(ADEREC)!'$D(ADEWAI)  S $P(ADELIN,"*",79)=""

 S ADETYP=$S(ADEREF:"rf",ADEREC:"rc",ADEWAI:"w")

 S ADEFUNC=" DELETION "

 D ^XBKVAR I '$D(DUZ(2)) W !,"DIVISION NOT SET IN USER FILE -- CONTACT SITE MANAGER OR ISC" Q

 I DUZ(2)=0 W !,"DIVISION SET TO ZERO (UNIVERSAL). DIVISION MUST BE SET TO ONE OF THE ",!,"SITES IN THE DENTAL SITE PARAMETER FILE. -- CONTACT SITE MANAGER" Q

ONE ;------->RESET CONSTANT FOLLOWUP SUBTYPE IF CALLED EXTERNALLY

 ;        TYPE SET BY CALLING OPTION

 ;        RETURN ADESUB=DFN IN ^ADETYP(

 D RESET^ADEMNG1 G:Y<1 END

TWO ;------->LOOK UP A PATIENT

 S ADEINT=0,ADEMDEL=1 D PTLOOK^ADEMNG1 K ADEINT,ADEMDEL G:Y<1 ONE

 ;------->DELETION

 K ADEMDFN D DEL

 I ADEMDFN="NO" W !?5,"--No changes made" H 2 G THREE

 I 'ADEMDFN W !,"***PATIENT NOT ON ",ADESUBN," LIST***",*7 H 2

 E  W !?5,"--DELETED" H 1

 ;------->GET ANOTHER PATIENT

THREE K ADEMDFN K ^ADEUTL("ADELOCK",ADEPAT) G TWO ;^ADEUTL is a transient working global

END K ADEADAT,ADEFUNC,ADELIN,ADEMDFN,ADENOD,ADEPAT,ADEREC,ADEREF,ADESUB,ADESUBN,ADETYP,ADEWAI,ADENEWM Q

EN D DEL Q

DEL ;EP

 ;------->GET ENTRY ADEMDFN IN ^ADEFOL

 I '$D(ADEMDFN) S ADEMDFN=0 D D1 Q:'ADEMDFN

 ;------->GET INFO ABOUT ENTRY

 S ADENOD=^ADEFOL(ADEMDFN,0)

 S ADEADAT=$P(ADENOD,U,3)

 ;------->CREATE ENTRY IN ^ADEPAT

 D CRE

 ;------->DELETE ENTRY FROM ^ADEFOL

 D DEST

 ;------->QUIT

 Q

D1 Q:'$D(^ADEFOL("TYPE",ADEPAT,ADETYP,ADESUB))

 S ADEMDFN=$O(^ADEFOL("TYPE",ADEPAT,ADETYP,ADESUB,0)) Q:'+ADEMDFN

 W !,"ARE YOU SURE YOU WANT TO DELETE?" S %=1 D YN^DICN S:%'=1 ADEMDFN="NO"

 Q

CRE ;CREATE ENTRY IN PATIENT FILE IF DOESN'T EXIST

 I '$D(^ADEPAT(ADEPAT)) S DIC="^ADEPAT(",DIC(0)="LZ",X=ADEPAT,DINUM=X K DD,DO D FILE^DICN

 ;CREATE SUBENTRY

 K DIC,DIE,DA,DR,X,Y

 S DA(1)=ADEPAT

 S DIE="^ADEPAT(DA(1),""FOL"","

 I $D(^ADEPAT(ADEPAT,"FOL",0)) S DA=$P(^ADEPAT(ADEPAT,"FOL",0),U,3)+1

 E  S ^ADEPAT(ADEPAT,"FOL",0)="^9002010.21PA^^",DA=1 ;DIE requires that the Zeroeth node of a subfile be set before adding the first subentry

 S DR=".01///`"_ADESUB_";2///"_ADEADAT_";3///"_DT

 D ^DIE

 S $P(^ADEPAT(ADEPAT,"FOL",0),U,3)=DA,$P(^ADEPAT(ADEPAT,"FOL",0),U,4)=$P(^ADEPAT(ADEPAT,"FOL",0),U,4)+1 ;Fileman requires the programmer to update the zeroeth node of a subfile after adding a subentry via DIE.

 Q

DEST S DIE="^ADEFOL(",DA=ADEMDFN,DR=".01///@" D ^DIE Q

ADEMDEL   ; IHS/HQT/MJL  - FOLLOWUP LIST DELETION ;06:50 PM  [ 03/24/1999   9:04 AM ]

 +1       ;;6.0;ADE;;APRIL 1999

 +2       ;CALLED AT EN WITH ADEPAT AND ADEMDFN WILL DELETE ENTRY ADEMDFN

 +3       ;FROM ^ADEFOL AND UPDATE ^ADEPAT

 +4       ;------->INITIALIZE

 +5        IF '$DATA(ADEREF)!'$DATA(ADEREC)!'$DATA(ADEWAI)

               QUIT 

           SET $PIECE(ADELIN,"*",79)=""

 +6        SET ADETYP=$SELECT(ADEREF:"rf",ADEREC:"rc",ADEWAI:"w")

 +7        SET ADEFUNC=" DELETION "

 +8        DO ^XBKVAR

           IF '$DATA(DUZ(2))

               WRITE !,"DIVISION NOT SET IN USER FILE -- CONTACT SITE MANAGER OR ISC"

               QUIT 

 +9        IF DUZ(2)=0

               WRITE !,"DIVISION SET TO ZERO (UNIVERSAL). DIVISION MUST BE SET TO ONE OF THE ",!,"SITES IN THE DENTAL SITE PARAMETER FILE. -- CONTACT SITE MANAGER"

               QUIT 

ONE       ;------->RESET CONSTANT FOLLOWUP SUBTYPE IF CALLED EXTERNALLY

 +1       ;        TYPE SET BY CALLING OPTION

 +2       ;        RETURN ADESUB=DFN IN ^ADETYP(

 +3        DO RESET^ADEMNG1

           IF Y<1

               GOTO END

TWO       ;------->LOOK UP A PATIENT

 +1        SET ADEINT=0

           SET ADEMDEL=1

           DO PTLOOK^ADEMNG1

           KILL ADEINT,ADEMDEL

           IF Y<1

               GOTO ONE

 +2       ;------->DELETION

 +3        KILL ADEMDFN

           DO DEL

 +4        IF ADEMDFN="NO"

               WRITE !?5,"--No changes made"

               HANG 2

               GOTO THREE

 +5        IF 'ADEMDFN

               WRITE !,"***PATIENT NOT ON ",ADESUBN," LIST***",*7

               HANG 2

 +6       IF '$TEST

               WRITE !?5,"--DELETED"

               HANG 1

 +7       ;------->GET ANOTHER PATIENT

THREE     ;^ADEUTL is a transient working global

           KILL ADEMDFN

           KILL ^ADEUTL("ADELOCK",ADEPAT)

           GOTO TWO

END        KILL ADEADAT,ADEFUNC,ADELIN,ADEMDFN,ADENOD,ADEPAT,ADEREC,ADEREF,ADESUB,ADESUBN,ADETYP,ADEWAI,ADENEWM

           QUIT 

EN         DO DEL

           QUIT 

DEL       ;EP

 +1       ;------->GET ENTRY ADEMDFN IN ^ADEFOL

 +2        IF '$DATA(ADEMDFN)

               SET ADEMDFN=0

               DO D1

               IF 'ADEMDFN

                   QUIT 

 +3       ;------->GET INFO ABOUT ENTRY

 +4        SET ADENOD=^ADEFOL(ADEMDFN,0)

 +5        SET ADEADAT=$PIECE(ADENOD,U,3)

 +6       ;------->CREATE ENTRY IN ^ADEPAT

 +7        DO CRE

 +8       ;------->DELETE ENTRY FROM ^ADEFOL

 +9        DO DEST

 +10      ;------->QUIT

 +11       QUIT 

D1         IF '$DATA(^ADEFOL("TYPE",ADEPAT,ADETYP,ADESUB))

               QUIT 

 +1        SET ADEMDFN=$ORDER(^ADEFOL("TYPE",ADEPAT,ADETYP,ADESUB,0))

           IF '+ADEMDFN

               QUIT 

 +2        WRITE !,"ARE YOU SURE YOU WANT TO DELETE?"

           SET %=1

           DO YN^DICN

           IF %'=1

               SET ADEMDFN="NO"

 +3        QUIT 

CRE       ;CREATE ENTRY IN PATIENT FILE IF DOESN'T EXIST

 +1        IF '$DATA(^ADEPAT(ADEPAT))

               SET DIC="^ADEPAT("

               SET DIC(0)="LZ"

               SET X=ADEPAT

               SET DINUM=X

               KILL DD,DO

               DO FILE^DICN

 +2       ;CREATE SUBENTRY

 +3        KILL DIC,DIE,DA,DR,X,Y

 +4        SET DA(1)=ADEPAT

 +5        SET DIE="^ADEPAT(DA(1),""FOL"","

 +6        IF $DATA(^ADEPAT(ADEPAT,"FOL",0))

               SET DA=$PIECE(^ADEPAT(ADEPAT,"FOL",0),U,3)+1

 +7       ;DIE requires that the Zeroeth node of a subfile be set before adding the first subentry

          IF '$TEST

               SET ^ADEPAT(ADEPAT,"FOL",0)="^9002010.21PA^^"

               SET DA=1

 +8        SET DR=".01///`"_ADESUB_";2///"_ADEADAT_";3///"_DT

 +9        DO ^DIE

 +10      ;Fileman requires the programmer to update the zeroeth node of a subfile after adding a subentry via DIE.

           SET $PIECE(^ADEPAT(ADEPAT,"FOL",0),U,3)=DA

           SET $PIECE(^ADEPAT(ADEPAT,"FOL",0),U,4)=$PIECE(^ADEPAT(ADEPAT,"FOL",0),U,4)+1

 +11       QUIT 

DEST       SET DIE="^ADEFOL("

           SET DA=ADEMDFN

           SET DR=".01///@"

           DO ^DIE

           QUIT