source: FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR4C2.m@ 1014

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

initial load of FOIAVistA 6/30/08 version
File size: 5.5 KB
Line 
1RMPR4C2 ;;HINES-OI/HNC - PURCHASE CARD VERIFY PC# FOR RECONCILIATION;10/29/2001
2 ;;3.0;PROSTHETICS;**67**;Feb 09, 1996
3 ;
4 ;Match on Visa Level II, Old Card, New Card, Card Holder
5 ;HNC 11-6-01
6 ;
7 ;IFCAP Integration Agreement for file #442: DBIA282-H, ref #803
8 ;IFCAP Integration Agreement for file #440.6: ref #3427
9 ;
10 Q
11EN ;Entry Point
12 W !,?5,"Verify and Repair Purchase Card Number Associated with the"
13 W !,?5,"ORACLE Document for Reconciliation"
14 W !,?5,"You Must Be the Card Holder of both OLD and NEW Cards!",!!
15 K ^TMP($J) D DIV4^RMPRSIT G:$D(X) EXIT
16 D HOME^%ZIS
17 S RMPRCOUN=0
18 S %DT("A")="Starting Date: ",%DT="AEPX" D ^%DT
19 S RMPRBDT=Y G:Y<0 EXIT
20 S %DT("A")="Ending Date: ",%DT="AEX" D ^%DT G:Y<0 EXIT
21 S RMPREDT=Y
22 I RMPRBDT>RMPREDT W !,$C(7),"Invalid Date Range Selection!!" G EN
23 ;
24 S Y=RMPRBDT D DD^%DT S RMPRX=Y,Y=RMPREDT D DD^%DT S RMPRY=Y
25PCRD ;ask purchase card number
26 K DIR S DIR(0)="FO",DIR("A")="Enter OLD Purchase Card Number"
27 S DIR("?")="Enter the 16-Digit Purchase Card #, no dashes or spaces."
28 D ^DIR K DIR
29 I $D(DTOUT)!($D(DUOUT)) W !,$C(7),$C(7),"Try Later!" G EXIT
30 I $L(X)>16!($L(X)<16)!(X'?.N) W !,"Must be 16-Digit Number." G PCRD
31 S RMPRPCRD=Y
32PCRDN K DIR S DIR(0)="FO",DIR("A")="Enter NEW Purchase Card Number"
33 S DIR("?")="Enter the NEW 16-Digit Purchase Card #, no dashes or spaces."
34 D ^DIR K DIR
35 I $D(DTOUT)!($D(DUOUT)) W !,$C(7),$C(7),"Try Later!" G EXIT
36 I $L(X)>16!($L(X)<16)!(X'?.N) W !,"Must be 16-Digit Number." G PCRDN
37 S RMPRPCNW=Y
38 ;
39 ;taskman
40 S %ZIS="MQ" K IOP D ^%ZIS G:POP EXIT
41 I '$D(IO("Q")) U IO G PRINT
42 K IO("Q")
43 S ZTDESC="PURCHASE CARD VERIFY",ZTRTN="PRINT^RMPR4C2"
44 S ZTSAVE("RMPRBDT")="",ZTSAVE("RMPREDT")=""
45 S ZTSAVE("RMPRY")="",ZTSAVE("RMPR(")="",ZTSAVE("RMPRPCRD")=""
46 S ZTSAVE("RMPRX")="",ZTSAVE("RMPRPCNW")="",ZTIO=ION
47 D ^%ZTLOAD W:$D(ZTSK) !,"REQUEST QUEUED!" H 1 G EXIT
48 ;
49PRINT S X1=RMPRBDT,X2=-1 D C^%DTC S PAGE=1,RMPREND="",RMPRFLG=""
50 I $E(IOST)["C" W @IOF
51 S RO=RMPRBDT-1
52 F S RO=$O(^RMPR(664,"B",RO)) Q:RO'>0 Q:RO>RMPREDT S RP=0 F S RP=$O(^RMPR(664,"B",RO,RP)) Q:RP'>0 D CK
53 S RMPRFLG="",RMPREND=""
54 D HDR,ST
55 G EXIT
56CK ;set tmp of list to compare with 440.6
57 Q:'$D(^RMPR(664,RP,0))
58 ;Vendor must not be null,PC number not null,no cancellation date
59 ;and station must be station selected
60 ;must have no close out date
61 ;
62 Q:$P(^RMPR(664,RP,0),U,4)=""!($P($G(^(4)),U,1)="")!($P(^(0),U,5)'="")
63 Q:$P(^RMPR(664,RP,0),U,14)'=""&($P(^(0),U,14)'=RMPR("STA"))
64 ;close out date
65 Q:$P(^RMPR(664,RP,0),U,8)'=""
66 ;decrypt PC number - rmprobl is decrypted card number, rmprpcrd what
67 ;user typed as 16 dig number
68 S ROBL=$P($G(^RMPR(664,RP,4)),U,1)
69 S RMPROBL=$$DEC^RMPR4LI($P(^RMPR(664,RP,4),U,1),$P(^RMPR(664,RP,0),U,9),RP)
70 Q:RMPROBL'=RMPRPCRD
71 S RMPRODR=$P($G(^RMPR(664,RP,4)),U,6)
72 Q:RMPRODR=""
73 S ^TMP($J,RMPRODR,RMPROBL,RP)=""
74 Q
75 ;
76COMP ;Enter RETURN to continue or '^' to exit:
77 ;
78 S RMPRFLG=1
79 I $Y>(IOSL-6) S RMPRFLG=""
80 ;
81 Q
82ST ;continue if user didn't want out, or time out
83 ;
84 I '$D(^TMP($J)) W !!,"*** NO DATA TO PRINT ***",!! Q
85 S PO=0
86 F S PO=$O(^TMP($J,PO)) Q:PO'>0 Q:RMPREND=1 D
87 .S POE=$P($G(^PRC(442,PO,0)),U,1)
88 .Q:POE=""
89 .;I ($X>14)&($X<65) W ?63,"|"
90 .;PSPC is psas card number
91 .S PSPC=0
92 .F S PSPC=$O(^TMP($J,PO,PSPC)) Q:PSPC'>0 Q:RMPREND=1 D
93 . .S RD=0,VISA2=""
94 . .F S RD=$O(^TMP($J,PO,PSPC,RD)) Q:RD'>0 Q:RMPREND=1 D
95 . . .S ORDATE=$$DAT1^RMPRUTL1($P(^RMPR(664,RD,0),U,1))
96 . . .W !,ORDATE
97 . . .W ?14,POE,?28,"|"
98 . . .S BDT=RMPRBDT
99 . . .F S BDT=$O(^PRCH(440.6,"D",BDT)) Q:BDT'>0 D
100 . . . .S (REC440,RCNT)=0
101 . . . .F S REC440=$O(^PRCH(440.6,"D",BDT,REC440)) Q:REC440'>0 Q:RMPREND=1 D
102 . . . . .;only look at current users records
103 . . . . .I $P(^PRCH(440.6,REC440,0),U,17)'=DUZ Q
104 . . . . .K RM440 S RM440="",RECIEN40=REC440_","
105 . . . . .D GETS^DIQ(440.6,RECIEN40,"**","","RM440")
106 . . . . .S PC=RM440(440.6,RECIEN40,3),IFST=RM440(440.6,RECIEN40,14),VISA2=RM440(440.6,RECIEN40,20)
107 . . . . .;S PC=$P(^PRCH(440.6,REC440,0),U,4),IFST=$P(^(0),U,15),VISA2=$P(^(0),U,21)
108 . . . . .S VISA2=$TR(VISA2,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTVWXYZ")
109 . . . . .;W ?50,$S(IFST="R":"Reconciled",IFST="N":"None",IFST="D":"Disputed",1:""),?63,"|"
110 . . . . .S PSASV2=$P(POE,"-",2)
111 . . . . .;match on visa 2 string from vendor
112 . . . . .I VISA2'[PSASV2 Q
113 . . . . .S RCNT=RCNT+1
114 . . . . .W:RCNT>1 !,?28,"|"
115 . . . . .W ?30,PC
116 . . . . .W ?50,VISA2,?63,"|"
117 . . . . .;verify both files same
118 . . . . .I PC=PSPC W ?65,"Okay"
119 . . . . .I $E(IOST,1,2)["C-"&($Y>(IOSL-6)) S DIR(0)="E" D ^DIR S:(Y<1)!($D(DTOUT)) RMPREND=1 Q:$G(RMPREND) D HDR
120 . . . . .I $E(IOST,1,2)'="C-"&($Y>(IOSL-6)) D HDR
121 . . . . .I PC=PSPC Q
122 . . . . .;check to make sure it is the new card number
123 . . . . .I PC'=RMPRPCNW W ?65,"Diff Card #" Q
124 . . . . .;update prosthetic file 664
125 . . . . .S $P(^RMPR(664,RD,4),U,7)=PC,$P(^(4),U,8)=REC440,$P(^(4),U,9)=DT
126 . . . . .;
127 . . . . .;update file 440.6 with original PC number
128 . . . . .S DIE="^PRCH(440.6,",DR="3////^S X=PSPC",DA=REC440
129 . . . . .L +^PRCH(440.6,DA,0):2 I '$T W !,"Record in use by another user. Try Later!" K DIE S RMPREND=1 Q
130 . . . . .D ^DIE
131 . . . . .L -^PRCH(440.6,DA,0)
132 . . . . .K DA,DIE,DR
133 . . . . .W ?65,"Repaired"
134 Q
135 ;
136HDR ;header
137 I RMPREND=1 Q
138 I PAGE'=1 W @IOF
139 W !,RMPRX_"-",RMPRY," Verify PC# "_RMPRPCRD_" STA "_$$STA^RMPRUTIL,?72,"PAGE ",PAGE,!
140 S PAGE=PAGE+1
141 W !,"Order Date",?14,"Order Number",?28,"|",?30,"ORACLE PC #",?50,"VISA II",?63,"|",?65,"Record Status",!,RMPR("L")
142 Q
143EXIT ;Common Exit
144 I $E(IOST)["C",'$G(RMPREND),$D(^TMP($J)) W ! S DIR(0)="E" D ^DIR
145 D ^%ZISC N RMPR,RMPRSITE
146 D KILL^XUSCLEAN K ^TMP($J)
147 Q
Note: See TracBrowser for help on using the repository browser.