| [613] | 1 | PRCHINQ ;WISC/AKS-Add/Edit Surrogate Users and inquire Card Info ;6/8/96 13:38
|
|---|
| 2 | ;;5.1;IFCAP;**18**;Oct 20, 2000
|
|---|
| 3 | ;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | QUIT
|
|---|
| 5 | ;
|
|---|
| 6 | INQ ;Display purchase card information and allow add/editting of users
|
|---|
| 7 | ;
|
|---|
| 8 | N PRCHDA
|
|---|
| 9 | S DIC="^PRC(440.5,",DIC(0)="AEQM"
|
|---|
| 10 | S DIC("S")="I $P(^PRC(440.5,+Y,0),U,8)=DUZ"
|
|---|
| 11 | D ^DIC W !
|
|---|
| 12 | S (PRCHDA,DA)=+Y,DR="0:49" D EN^DIQ,EN^DDIOL("REPLACEMENT CHARGE CARD NUMBER: "_$P($G(^PRC(440.5,DA,50)),"^")):$P($G(^PRC(440.5,DA,50)),"^")]"" G:Y=-1 EXIT
|
|---|
| 13 | S %A="Would you like to add/delete a surrogate",%B="",%=2
|
|---|
| 14 | D ^PRCFYN G:%<1!(%=2) EXIT
|
|---|
| 15 | MORE S DA(1)=PRCHDA,DIC="^PRC(440.5,"_DA(1)_",1,",DIC(0)="AEQLM"
|
|---|
| 16 | S DIC("S")="I +Y'=DUZ"
|
|---|
| 17 | D ^DIC K DIC
|
|---|
| 18 | I $P(Y,U,3)'=1 D
|
|---|
| 19 | . S DA=+Y,DIK="^PRC(440.5,"_DA(1)_",1,"
|
|---|
| 20 | . D ^DIK K Y,DA,DIK
|
|---|
| 21 | S %A="Would you like to add/delete another surrogate",%B="",%=2
|
|---|
| 22 | D ^PRCFYN G:%<1!(%=2) EXIT G MORE
|
|---|
| 23 | QUIT
|
|---|
| 24 | STAT ;Amendment/Adjustment statuses from the dd, called from field #50, sub-
|
|---|
| 25 | ;field #9 of file #443.6
|
|---|
| 26 | S DIC("S")="S Z1=$P(^(0),U,2) I $S(Z1=21:1,Z1=23:1,Z1=26:1,Z1=29:1,Z1=31:1,Z1=34:1,Z1=41:1,Z1=44:1,Z1=47:1,Z1=49:1,1:0)"
|
|---|
| 27 | ;I $G(PRCHAUTH)=1 S DIC("S")="S Z1=$P(^(0),U,2) I $S(Z1=21:1,Z1=23:1,Z1=26:1,Z1=29:1,Z1=31:1,Z1=34:1,Z1=41:1,Z1=44:1,Z1=47:1,Z1=49:1,Z1=51:1,1:0)"
|
|---|
| 28 | I $G(PRCHAUTH)=1 D
|
|---|
| 29 | . S DIC("S")="S Z1=$P(^(0),U,2) I $S(Z1=23:1,Z1=26:1,Z1=31:1,Z1=41:1,1:0)"
|
|---|
| 30 | . S PRCHOLD=$P($G(^PRC(443.6,PRCHPO,7)),U)
|
|---|
| 31 | . I $P($G(^PRCD(442.3,PRCHOLD,0)),"(")="Paid " D
|
|---|
| 32 | . . S DIC("S")="S Z1=$P(^(0),U,2) I $S(Z1=29:1,Z1=34:1,Z1=38:1,1:0)"
|
|---|
| 33 | . I $P($G(^PRCD(442.3,PRCHOLD,0)),"(")="Partial Payment " D
|
|---|
| 34 | . . S DIC("S")="S Z1=$P(^(0),U,2) I $S(Z1=44:1,Z1=47:1,Z1=49:1,1:0)"
|
|---|
| 35 | D ^DIC K DIC,PRCHOLD S DIC=DIE,X=+Y K:Y<0 X
|
|---|
| 36 | QUIT
|
|---|
| 37 | EXIT ;Kill variables and quit
|
|---|
| 38 | K Y,%A,%B,%,DIC
|
|---|
| 39 | QUIT
|
|---|
| 40 | STAT1 ;Called from field #50, subfield #9, file #443.6
|
|---|
| 41 | S DIC("S")="S Z1=$P(^(0),U,2) I $S(Z1=21:1,Z1=23:1,Z1=26:1,Z1=29:1,Z1=31:1,Z1=34:1,Z1=41:1,Z1=44:1,Z1=47:1,Z1=49:1,1:0)"
|
|---|
| 42 | ;I $G(PRCHAUTH)=1 S DIC("S")="S Z1=$P(^(0),U,2) I $S(Z1=21:1,Z1=23:1,Z1=26:1,Z1=29:1,Z1=31:1,Z1=34:1,Z1=41:1,Z1=44:1,Z1=47:1,Z1=49:1,Z1=51:1,1:0)"
|
|---|
| 43 | I $G(PRCHAUTH)=1 D
|
|---|
| 44 | . S DIC("S")="S Z1=$P(^(0),U,2) I $S(Z1=23:1,Z1=26:1,Z1=31:1,Z1=41:1,1:0)"
|
|---|
| 45 | . S PRCHOLD=$P($G(^PRC(443.6,PRCHPO,7)),U)
|
|---|
| 46 | . I $P($G(^PRCD(442.3,PRCHOLD,0)),"(")="Paid " D
|
|---|
| 47 | . . S DIC("S")="S Z1=$P(^(0),U,2) I $S(Z1=29:1,Z1=34:1,Z1=38:1,1:0)"
|
|---|
| 48 | . I $P($G(^PRCD(442.3,PRCHOLD,0)),"(")="Partial Payment " D
|
|---|
| 49 | . . S DIC("S")="S Z1=$P(^(0),U,2) I $S(Z1=44:1,Z1=47:1,Z1=49:1,1:0)"
|
|---|
| 50 | K PRCHOLD
|
|---|
| 51 | QUIT
|
|---|
| 52 | PAID ;To check if there is any payment made for this PO
|
|---|
| 53 | I $G(PRCHAUTH)=1 D
|
|---|
| 54 | . S PRCHOLD=$P($G(^PRC(443.6,PRCHPO,7)),U)
|
|---|
| 55 | . I $P($G(^PRCD(442.3,PRCHOLD,0)),"(")="Paid " S PAID=1
|
|---|
| 56 | . I $P($G(^PRCD(442.3,PRCHOLD,0)),"(")="Partial Payment " S PAID=1
|
|---|
| 57 | QUIT
|
|---|
