AGADDR.m

AGADDR ; IHS/ASDS/EFG - REGISTRATION MAILING LIST PRINT/EDIT (1 OF 2) ; 

 ;;7.1;PATIENT REGISTRATION;;AUG 25,2005

 ;PROGRAMMER NOTE:  THIS ROUTINE IS CALLED BY A CHS OPTION.

 ;

VAR S AGV("TOT")=0,AGV("LINE")="IHSIHSIHSIHSIHSIHSIHSIHS" K IOP,AG,DFN

 D:'$D(DUZ(2)) SET^XBSITE I DUZ(2)<1 S DUZ(2)=$P(^AUTTSITE(1,0),U)

 W !?5,"1)  Print an Existing List",!!?5,"2)  Add/Edit a List",!!?9,"Select Option (1-2) '^' to Exit " D READ^AG G END1:$D(DFOUT)!$D(DUOUT)!$D(DTOUT)!$D(DLOUT),PEXIST:Y?1"1".E,END1:Y'?1"2"

GNEW LOCK  W ! S DIC="^AGADLIST(",DIC(0)="QAZEML",DLAYGO=9009065,DIC("S")="I $P(^(0),U,5)=DUZ" D ^DIC G VAR:+Y<1

 S (AGLIST,DA)=+Y,DIE=DIC,DR=.01 D ^DIE K DIC,DIE,DR,DA

 I '$D(^AGADLIST(AGLIST)) G VAR

 LOCK ^AGADLIST(AGLIST):1 I '$T W *7,!!,"MAILING LIST IN USE BY ANOTHER USER  -- TRY LATER" H 3 G VAR

 I $P(^AGADLIST(AGLIST,0),U,2)="" K DIC,DR S DA=AGLIST,DIE="^AGADLIST(",DR="2////"_DT_";4////"_DUZ D ^DIE

 D NEWLST^AGADDR1

GNEW2 S DIC("W")="D ^AGSCANP" D SET^AUPNLKZ,PTLK^AG,RESET^AUPNLKZ G VAR:'$D(DFN)

 I $D(^AGADLIST(AGLIST,1,"B",DFN)) W !,*7,"Already on File  -- Want to Delete (Y/N) NO//" D READ^AG G VAR:$D(DFOUT)!$D(DUOUT)!$D(DTOUT),DEL:Y?1"Y".E,GNEW2

 S AGV("P3")=AGV("P3")+1,AGV("P4")=AGV("P4")+1

 S:'($D(^AGADLIST(AGLIST,1,0))) ^AGADLIST(AGLIST,1,0)="^9009065.05P^^"

 K DIC S DIC(0)="AEQML",DIC="^AGADLIST("_AGLIST_",1,",DA(1)=AGLIST,X=DFN K DD,DO D FILE^DICN

 G GNEW2

DEL S X="",X=$O(^AGADLIST(AGLIST,1,"B",DFN,X))

 G:+X'>0 GNEW2

 S DA=X,DIK="^AGADLIST("_AGLIST_",1,",DA(1)=AGLIST D ^DIK

 W !,*7,?5,"Patient Deleted"

 G GNEW2

PEXIST W ! S DIC="^AGADLIST(",DIC(0)="QAZEM",DIC("A")="Enter the NAME of the list to Print ",DIC("S")="I $P(^(0),U,5)=DUZ"

 D ^DIC G VAR:+Y<1 S AGLIST=+Y K DIC D NEWLST^AGADDR1

 I AGV("P4")<1 W !!,"Enter <RETURN> to Continue" D READ^AG G VAR

 G VAROLD^AGADDR1

END ;EP

 D ^%ZISC

END1 ;EP

 LOCK

 K AG,AGADRS1,AGADRS2,AGLIST,AGNAME,DA,DFN,DIC,DR,G,AGL,I,AGV,AG("LKDATA"),AG("LKPRINT"),AGV,R,AGV,X,Y D:$D(ZTQUEUED) KILL^%ZTLOAD

 Q

AGADDR    ; IHS/ASDS/EFG - REGISTRATION MAILING LIST PRINT/EDIT (1 OF 2) ; 

 +1       ;;7.1;PATIENT REGISTRATION;;AUG 25,2005

 +2       ;PROGRAMMER NOTE:  THIS ROUTINE IS CALLED BY A CHS OPTION.

 +3       ;

VAR        SET AGV("TOT")=0

           SET AGV("LINE")="IHSIHSIHSIHSIHSIHSIHSIHS"

           KILL IOP,AG,DFN

 +1        IF '$DATA(DUZ(2))

               DO SET^XBSITE

           IF DUZ(2)<1

               SET DUZ(2)=$PIECE(^AUTTSITE(1,0),U)

 +2        WRITE !?5,"1)  Print an Existing List",!!?5,"2)  Add/Edit a List",!!?9,"Select Option (1-2) '^' to Exit "

           DO READ^AG

           IF $DATA(DFOUT)!$DATA(DUOUT)!$DATA(DTOUT)!$DATA(DLOUT)

               GOTO END1

           IF Y?1"1".E

               GOTO PEXIST

           IF Y'?1"2"

               GOTO END1

GNEW       LOCK 

           WRITE !

           SET DIC="^AGADLIST("

           SET DIC(0)="QAZEML"

           SET DLAYGO=9009065

           SET DIC("S")="I $P(^(0),U,5)=DUZ"

           DO ^DIC

           IF +Y<1

               GOTO VAR

 +1        SET (AGLIST,DA)=+Y

           SET DIE=DIC

           SET DR=.01

           DO ^DIE

           KILL DIC,DIE,DR,DA

 +2        IF '$DATA(^AGADLIST(AGLIST))

               GOTO VAR

 +3        LOCK ^AGADLIST(AGLIST):1

           IF '$TEST

               WRITE *7,!!,"MAILING LIST IN USE BY ANOTHER USER  -- TRY LATER"

               HANG 3

               GOTO VAR

 +4        IF $PIECE(^AGADLIST(AGLIST,0),U,2)=""

               KILL DIC,DR

               SET DA=AGLIST

               SET DIE="^AGADLIST("

               SET DR="2////"_DT_";4////"_DUZ

               DO ^DIE

 +5        DO NEWLST^AGADDR1

GNEW2      SET DIC("W")="D ^AGSCANP"

           DO SET^AUPNLKZ

           DO PTLK^AG

           DO RESET^AUPNLKZ

           IF '$DATA(DFN)

               GOTO VAR

 +1        IF $DATA(^AGADLIST(AGLIST,1,"B",DFN))

               WRITE !,*7,"Already on File  -- Want to Delete (Y/N) NO//"

               DO READ^AG

               IF $DATA(DFOUT)!$DATA(DUOUT)!$DATA(DTOUT)

                   GOTO VAR

               IF Y?1"Y".E

                   GOTO DEL

               GOTO GNEW2

 +2        SET AGV("P3")=AGV("P3")+1

           SET AGV("P4")=AGV("P4")+1

 +3        IF '($DATA(^AGADLIST(AGLIST,1,0)))

               SET ^AGADLIST(AGLIST,1,0)="^9009065.05P^^"

 +4        KILL DIC

           SET DIC(0)="AEQML"

           SET DIC="^AGADLIST("_AGLIST_",1,"

           SET DA(1)=AGLIST

           SET X=DFN

           KILL DD,DO

           DO FILE^DICN

 +5        GOTO GNEW2

DEL        SET X=""

           SET X=$ORDER(^AGADLIST(AGLIST,1,"B",DFN,X))

 +1        IF +X'>0

               GOTO GNEW2

 +2        SET DA=X

           SET DIK="^AGADLIST("_AGLIST_",1,"

           SET DA(1)=AGLIST

           DO ^DIK

 +3        WRITE !,*7,?5,"Patient Deleted"

 +4        GOTO GNEW2

PEXIST     WRITE !

           SET DIC="^AGADLIST("

           SET DIC(0)="QAZEM"

           SET DIC("A")="Enter the NAME of the list to Print "

           SET DIC("S")="I $P(^(0),U,5)=DUZ"

 +1        DO ^DIC

           IF +Y<1

               GOTO VAR

           SET AGLIST=+Y

           KILL DIC

           DO NEWLST^AGADDR1

 +2        IF AGV("P4")<1

               WRITE !!,"Enter <RETURN> to Continue"

               DO READ^AG

               GOTO VAR

 +3        GOTO VAROLD^AGADDR1

END       ;EP

 +1        DO ^%ZISC

END1      ;EP

 +1        LOCK 

 +2        KILL AG,AGADRS1,AGADRS2,AGLIST,AGNAME,DA,DFN,DIC,DR,G,AGL,I,AGV,AG("LKDATA"),AG("LKPRINT"),AGV,R,AGV,X,Y

           IF $DATA(ZTQUEUED)

               DO KILL^%ZTLOAD

 +3        QUIT