- 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
