ADEMP.m

ADEMP ; IHS/HQT/MJL  - DENTAL FOLLOWUP OUTPUT ;08:04 PM  [ 03/24/1999   9:04 AM ]

 ;;6.0;ADE;;APRIL 1999

 ;CALL AT EN TO GET OUTPUT FOR INDIVIDUAL PATIENT

INIT ;ADEMCAT="rc" set in Calling option

 G:'$D(ADEMCAT) END

 ;------->GET TYPE - ENDO,PROS,ETC

 D TYPE G:Y<1 END S ADEMTYP=+Y,ADEMTYPN=Y(0,0)

 ;------->LETTERS OR SORTED LIST?

 D FORM G:Y<1 END

 ;------->SET SCREENS

 D SCR G:Y<1 END

 ;------->CALL DIS

 D DIS G END

END ;------->END

 K ADEMCAT,ADEMTYP,ADEMTYPN Q

TYPE K DIC S DIC="^ADETYP(",DIC("S")="I $P(^(0),U,4)=ADEMCAT",DIC(0)="AEQMZ",DIC("A")="Select "_$S(ADEMCAT="w":"WAITING ",ADEMCAT="rc":"RECALL",1:"REFERRAL")_" LIST: " D ^DIC K DIC

 Q

DIBT K DIC S DIC="^DIBT(",X=ADETEM,DIC(0)="LZ",DIC("DR")="4///9002003.2"

 K DD,DO D FILE^DICN S ADETDFN=+Y K DIC

 Q

DELDBT I '$D(^DIBT("B",ADETEM)) Q

 S DA=$O(^DIBT("B",ADETEM,0))

 S DR=".01///@",DIE="^DIBT("

 D ^DIE K DR,DA,DIE

 Q

PRINT K DIC S DIC="^ADEFOL(",BY="["_ADETEM_"]",FR="",TO=""

 D EN1^DIP

 K DIC

 Q

FORM S FLDS="[ADEMLST]"

 S Y=1,L=0,BY=".01",DHD=ADEMTYPN_" "_$S(ADEMCAT="w":"WAITING",ADEMCAT="rc":"RECALL",ADEMCAT="rf":"RECALL",1:"")_" LIST"

 Q

SCR S DIS(0)="I $P(^ADEFOL(D0,0),U,2)=ADEMTYP"

 S Y=1 Q

DIS K DIC S DIC="^ADEFOL(" S DICS="I $P(^(0),U)'=""CATEGORY"",$P(^(0),U)'=""TYPE""" D EN^DIS K DIC,DICS,DIS(0)

 Q

EN ;EP -    INTERNAL ENTRY POINT WITH ENTRY IN ^ADEFOL DEFINED AS ADEMDFN

 ;        TO PRINT LETTER FOR INDIVIDUALLY SELECTED PT.

 ;ADEMDFN=19 set in calling option

 S ADETEM="ADEMP"_$J D DELDBT,DIBT

 ;------->SET DIBT NODE

E2 S ^DIBT(ADETDFN,1,ADEMDFN)=""

 ;------->OUTPUT

E3 G:'$D(^DIBT(ADETDFN,1)) E4

 S FLDS="[ADEMLET]"

 S DHIT="S $P(^ADEFOL(D0,0),U,6)=$E(DT,4,5)_""/""_$E(DT,6,7)_""/""_$E(DT,2,3)_"_$C(34)_" LETTER PRINTED"_$C(34)

 D PRINT

 ;------->DELETE ENTRY IN ^DIBT

E4 D DELDBT

 ;------->END

 K ADEMDFN,ADETEM,ADETDFN Q

ADEMP     ; IHS/HQT/MJL  - DENTAL FOLLOWUP OUTPUT ;08:04 PM  [ 03/24/1999   9:04 AM ]

 +1       ;;6.0;ADE;;APRIL 1999

 +2       ;CALL AT EN TO GET OUTPUT FOR INDIVIDUAL PATIENT

INIT      ;ADEMCAT="rc" set in Calling option

 +1        IF '$DATA(ADEMCAT)

               GOTO END

 +2       ;------->GET TYPE - ENDO,PROS,ETC

 +3        DO TYPE

           IF Y<1

               GOTO END

           SET ADEMTYP=+Y

           SET ADEMTYPN=Y(0,0)

 +4       ;------->LETTERS OR SORTED LIST?

 +5        DO FORM

           IF Y<1

               GOTO END

 +6       ;------->SET SCREENS

 +7        DO SCR

           IF Y<1

               GOTO END

 +8       ;------->CALL DIS

 +9        DO DIS

           GOTO END

END       ;------->END

 +1        KILL ADEMCAT,ADEMTYP,ADEMTYPN

           QUIT 

TYPE       KILL DIC

           SET DIC="^ADETYP("

           SET DIC("S")="I $P(^(0),U,4)=ADEMCAT"

           SET DIC(0)="AEQMZ"

           SET DIC("A")="Select "_$SELECT(ADEMCAT="w":"WAITING ",ADEMCAT="rc":"RECALL",1:"REFERRAL")_" LIST: "

           DO ^DIC

           KILL DIC

 +1        QUIT 

DIBT       KILL DIC

           SET DIC="^DIBT("

           SET X=ADETEM

           SET DIC(0)="LZ"

           SET DIC("DR")="4///9002003.2"

 +1        KILL DD,DO

           DO FILE^DICN

           SET ADETDFN=+Y

           KILL DIC

 +2        QUIT 

DELDBT     IF '$DATA(^DIBT("B",ADETEM))

               QUIT 

 +1        SET DA=$ORDER(^DIBT("B",ADETEM,0))

 +2        SET DR=".01///@"

           SET DIE="^DIBT("

 +3        DO ^DIE

           KILL DR,DA,DIE

 +4        QUIT 

PRINT      KILL DIC

           SET DIC="^ADEFOL("

           SET BY="["_ADETEM_"]"

           SET FR=""

           SET TO=""

 +1        DO EN1^DIP

 +2        KILL DIC

 +3        QUIT 

FORM       SET FLDS="[ADEMLST]"

 +1        SET Y=1

           SET L=0

           SET BY=".01"

           SET DHD=ADEMTYPN_" "_$SELECT(ADEMCAT="w":"WAITING",ADEMCAT="rc":"RECALL",ADEMCAT="rf":"RECALL",1:"")_" LIST"

 +2        QUIT 

SCR        SET DIS(0)="I $P(^ADEFOL(D0,0),U,2)=ADEMTYP"

 +1        SET Y=1

           QUIT 

DIS        KILL DIC

           SET DIC="^ADEFOL("

           SET DICS="I $P(^(0),U)'=""CATEGORY"",$P(^(0),U)'=""TYPE"""

           DO EN^DIS

           KILL DIC,DICS,DIS(0)

 +1        QUIT 

EN        ;EP -    INTERNAL ENTRY POINT WITH ENTRY IN ^ADEFOL DEFINED AS ADEMDFN

 +1       ;        TO PRINT LETTER FOR INDIVIDUALLY SELECTED PT.

 +2       ;ADEMDFN=19 set in calling option

 +3        SET ADETEM="ADEMP"_$JOB

           DO DELDBT

           DO DIBT

 +4       ;------->SET DIBT NODE

E2         SET ^DIBT(ADETDFN,1,ADEMDFN)=""

 +1       ;------->OUTPUT

E3         IF '$DATA(^DIBT(ADETDFN,1))

               GOTO E4

 +1        SET FLDS="[ADEMLET]"

 +2        SET DHIT="S $P(^ADEFOL(D0,0),U,6)=$E(DT,4,5)_""/""_$E(DT,6,7)_""/""_$E(DT,2,3)_"_$CHAR(34)_" LETTER PRINTED"_$CHAR(34)

 +3        DO PRINT

 +4       ;------->DELETE ENTRY IN ^DIBT

E4         DO DELDBT

 +1       ;------->END

 +2        KILL ADEMDFN,ADETEM,ADETDFN

           QUIT