source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHINQ.m@ 1259

Last change on this file since 1259 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 2.7 KB
Line 
1PRCHINQ ;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 ;
6INQ ;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
15MORE 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
24STAT ;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
37EXIT ;Kill variables and quit
38 K Y,%A,%B,%,DIC
39 QUIT
40STAT1 ;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
52PAID ;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
Note: See TracBrowser for help on using the repository browser.