RMPR4C2 ;;HINES-OI/HNC - PURCHASE CARD VERIFY PC# FOR RECONCILIATION;10/29/2001
;;3.0;PROSTHETICS;**67**;Feb 09, 1996
;
;Match on Visa Level II, Old Card, New Card, Card Holder
;HNC 11-6-01
;
;IFCAP Integration Agreement for file #442: DBIA282-H, ref #803
;IFCAP Integration Agreement for file #440.6: ref #3427
;
Q
EN ;Entry Point
W !,?5,"Verify and Repair Purchase Card Number Associated with the"
W !,?5,"ORACLE Document for Reconciliation"
W !,?5,"You Must Be the Card Holder of both OLD and NEW Cards!",!!
K ^TMP($J) D DIV4^RMPRSIT G:$D(X) EXIT
D HOME^%ZIS
S RMPRCOUN=0
S %DT("A")="Starting Date: ",%DT="AEPX" D ^%DT
S RMPRBDT=Y G:Y<0 EXIT
S %DT("A")="Ending Date: ",%DT="AEX" D ^%DT G:Y<0 EXIT
S RMPREDT=Y
I RMPRBDT>RMPREDT W !,$C(7),"Invalid Date Range Selection!!" G EN
;
S Y=RMPRBDT D DD^%DT S RMPRX=Y,Y=RMPREDT D DD^%DT S RMPRY=Y
PCRD ;ask purchase card number
K DIR S DIR(0)="FO",DIR("A")="Enter OLD Purchase Card Number"
S DIR("?")="Enter the 16-Digit Purchase Card #, no dashes or spaces."
D ^DIR K DIR
I $D(DTOUT)!($D(DUOUT)) W !,$C(7),$C(7),"Try Later!" G EXIT
I $L(X)>16!($L(X)<16)!(X'?.N) W !,"Must be 16-Digit Number." G PCRD
S RMPRPCRD=Y
PCRDN K DIR S DIR(0)="FO",DIR("A")="Enter NEW Purchase Card Number"
S DIR("?")="Enter the NEW 16-Digit Purchase Card #, no dashes or spaces."
D ^DIR K DIR
I $D(DTOUT)!($D(DUOUT)) W !,$C(7),$C(7),"Try Later!" G EXIT
I $L(X)>16!($L(X)<16)!(X'?.N) W !,"Must be 16-Digit Number." G PCRDN
S RMPRPCNW=Y
;
;taskman
S %ZIS="MQ" K IOP D ^%ZIS G:POP EXIT
I '$D(IO("Q")) U IO G PRINT
K IO("Q")
S ZTDESC="PURCHASE CARD VERIFY",ZTRTN="PRINT^RMPR4C2"
S ZTSAVE("RMPRBDT")="",ZTSAVE("RMPREDT")=""
S ZTSAVE("RMPRY")="",ZTSAVE("RMPR(")="",ZTSAVE("RMPRPCRD")=""
S ZTSAVE("RMPRX")="",ZTSAVE("RMPRPCNW")="",ZTIO=ION
D ^%ZTLOAD W:$D(ZTSK) !,"REQUEST QUEUED!" H 1 G EXIT
;
PRINT S X1=RMPRBDT,X2=-1 D C^%DTC S PAGE=1,RMPREND="",RMPRFLG=""
I $E(IOST)["C" W @IOF
S RO=RMPRBDT-1
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
S RMPRFLG="",RMPREND=""
D HDR,ST
G EXIT
CK ;set tmp of list to compare with 440.6
Q:'$D(^RMPR(664,RP,0))
;Vendor must not be null,PC number not null,no cancellation date
;and station must be station selected
;must have no close out date
;
Q:$P(^RMPR(664,RP,0),U,4)=""!($P($G(^(4)),U,1)="")!($P(^(0),U,5)'="")
Q:$P(^RMPR(664,RP,0),U,14)'=""&($P(^(0),U,14)'=RMPR("STA"))
;close out date
Q:$P(^RMPR(664,RP,0),U,8)'=""
;decrypt PC number - rmprobl is decrypted card number, rmprpcrd what
;user typed as 16 dig number
S ROBL=$P($G(^RMPR(664,RP,4)),U,1)
S RMPROBL=$$DEC^RMPR4LI($P(^RMPR(664,RP,4),U,1),$P(^RMPR(664,RP,0),U,9),RP)
Q:RMPROBL'=RMPRPCRD
S RMPRODR=$P($G(^RMPR(664,RP,4)),U,6)
Q:RMPRODR=""
S ^TMP($J,RMPRODR,RMPROBL,RP)=""
Q
;
COMP ;Enter RETURN to continue or '^' to exit:
;
S RMPRFLG=1
I $Y>(IOSL-6) S RMPRFLG=""
;
Q
ST ;continue if user didn't want out, or time out
;
I '$D(^TMP($J)) W !!,"*** NO DATA TO PRINT ***",!! Q
S PO=0
F S PO=$O(^TMP($J,PO)) Q:PO'>0 Q:RMPREND=1 D
.S POE=$P($G(^PRC(442,PO,0)),U,1)
.Q:POE=""
.;I ($X>14)&($X<65) W ?63,"|"
.;PSPC is psas card number
.S PSPC=0
.F S PSPC=$O(^TMP($J,PO,PSPC)) Q:PSPC'>0 Q:RMPREND=1 D
. .S RD=0,VISA2=""
. .F S RD=$O(^TMP($J,PO,PSPC,RD)) Q:RD'>0 Q:RMPREND=1 D
. . .S ORDATE=$$DAT1^RMPRUTL1($P(^RMPR(664,RD,0),U,1))
. . .W !,ORDATE
. . .W ?14,POE,?28,"|"
. . .S BDT=RMPRBDT
. . .F S BDT=$O(^PRCH(440.6,"D",BDT)) Q:BDT'>0 D
. . . .S (REC440,RCNT)=0
. . . .F S REC440=$O(^PRCH(440.6,"D",BDT,REC440)) Q:REC440'>0 Q:RMPREND=1 D
. . . . .;only look at current users records
. . . . .I $P(^PRCH(440.6,REC440,0),U,17)'=DUZ Q
. . . . .K RM440 S RM440="",RECIEN40=REC440_","
. . . . .D GETS^DIQ(440.6,RECIEN40,"**","","RM440")
. . . . .S PC=RM440(440.6,RECIEN40,3),IFST=RM440(440.6,RECIEN40,14),VISA2=RM440(440.6,RECIEN40,20)
. . . . .;S PC=$P(^PRCH(440.6,REC440,0),U,4),IFST=$P(^(0),U,15),VISA2=$P(^(0),U,21)
. . . . .S VISA2=$TR(VISA2,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTVWXYZ")
. . . . .;W ?50,$S(IFST="R":"Reconciled",IFST="N":"None",IFST="D":"Disputed",1:""),?63,"|"
. . . . .S PSASV2=$P(POE,"-",2)
. . . . .;match on visa 2 string from vendor
. . . . .I VISA2'[PSASV2 Q
. . . . .S RCNT=RCNT+1
. . . . .W:RCNT>1 !,?28,"|"
. . . . .W ?30,PC
. . . . .W ?50,VISA2,?63,"|"
. . . . .;verify both files same
. . . . .I PC=PSPC W ?65,"Okay"
. . . . .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
. . . . .I $E(IOST,1,2)'="C-"&($Y>(IOSL-6)) D HDR
. . . . .I PC=PSPC Q
. . . . .;check to make sure it is the new card number
. . . . .I PC'=RMPRPCNW W ?65,"Diff Card #" Q
. . . . .;update prosthetic file 664
. . . . .S $P(^RMPR(664,RD,4),U,7)=PC,$P(^(4),U,8)=REC440,$P(^(4),U,9)=DT
. . . . .;
. . . . .;update file 440.6 with original PC number
. . . . .S DIE="^PRCH(440.6,",DR="3////^S X=PSPC",DA=REC440
. . . . .L +^PRCH(440.6,DA,0):2 I '$T W !,"Record in use by another user. Try Later!" K DIE S RMPREND=1 Q
. . . . .D ^DIE
. . . . .L -^PRCH(440.6,DA,0)
. . . . .K DA,DIE,DR
. . . . .W ?65,"Repaired"
Q
;
HDR ;header
I RMPREND=1 Q
I PAGE'=1 W @IOF
W !,RMPRX_"-",RMPRY," Verify PC# "_RMPRPCRD_" STA "_$$STA^RMPRUTIL,?72,"PAGE ",PAGE,!
S PAGE=PAGE+1
W !,"Order Date",?14,"Order Number",?28,"|",?30,"ORACLE PC #",?50,"VISA II",?63,"|",?65,"Record Status",!,RMPR("L")
Q
EXIT ;Common Exit
I $E(IOST)["C",'$G(RMPREND),$D(^TMP($J)) W ! S DIR(0)="E" D ^DIR
D ^%ZISC N RMPR,RMPRSITE
D KILL^XUSCLEAN K ^TMP($J)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPR4C2 5743 printed Nov 22, 2024@17:42:42 Page 2
RMPR4C2 ;;HINES-OI/HNC - PURCHASE CARD VERIFY PC# FOR RECONCILIATION;10/29/2001
+1 ;;3.0;PROSTHETICS;**67**;Feb 09, 1996
+2 ;
+3 ;Match on Visa Level II, Old Card, New Card, Card Holder
+4 ;HNC 11-6-01
+5 ;
+6 ;IFCAP Integration Agreement for file #442: DBIA282-H, ref #803
+7 ;IFCAP Integration Agreement for file #440.6: ref #3427
+8 ;
+9 QUIT
EN ;Entry Point
+1 WRITE !,?5,"Verify and Repair Purchase Card Number Associated with the"
+2 WRITE !,?5,"ORACLE Document for Reconciliation"
+3 WRITE !,?5,"You Must Be the Card Holder of both OLD and NEW Cards!",!!
+4 KILL ^TMP($JOB)
DO DIV4^RMPRSIT
if $DATA(X)
GOTO EXIT
+5 DO HOME^%ZIS
+6 SET RMPRCOUN=0
+7 SET %DT("A")="Starting Date: "
SET %DT="AEPX"
DO ^%DT
+8 SET RMPRBDT=Y
if Y<0
GOTO EXIT
+9 SET %DT("A")="Ending Date: "
SET %DT="AEX"
DO ^%DT
if Y<0
GOTO EXIT
+10 SET RMPREDT=Y
+11 IF RMPRBDT>RMPREDT
WRITE !,$CHAR(7),"Invalid Date Range Selection!!"
GOTO EN
+12 ;
+13 SET Y=RMPRBDT
DO DD^%DT
SET RMPRX=Y
SET Y=RMPREDT
DO DD^%DT
SET RMPRY=Y
PCRD ;ask purchase card number
+1 KILL DIR
SET DIR(0)="FO"
SET DIR("A")="Enter OLD Purchase Card Number"
+2 SET DIR("?")="Enter the 16-Digit Purchase Card #, no dashes or spaces."
+3 DO ^DIR
KILL DIR
+4 IF $DATA(DTOUT)!($DATA(DUOUT))
WRITE !,$CHAR(7),$CHAR(7),"Try Later!"
GOTO EXIT
+5 IF $LENGTH(X)>16!($LENGTH(X)<16)!(X'?.N)
WRITE !,"Must be 16-Digit Number."
GOTO PCRD
+6 SET RMPRPCRD=Y
PCRDN KILL DIR
SET DIR(0)="FO"
SET DIR("A")="Enter NEW Purchase Card Number"
+1 SET DIR("?")="Enter the NEW 16-Digit Purchase Card #, no dashes or spaces."
+2 DO ^DIR
KILL DIR
+3 IF $DATA(DTOUT)!($DATA(DUOUT))
WRITE !,$CHAR(7),$CHAR(7),"Try Later!"
GOTO EXIT
+4 IF $LENGTH(X)>16!($LENGTH(X)<16)!(X'?.N)
WRITE !,"Must be 16-Digit Number."
GOTO PCRDN
+5 SET RMPRPCNW=Y
+6 ;
+7 ;taskman
+8 SET %ZIS="MQ"
KILL IOP
DO ^%ZIS
if POP
GOTO EXIT
+9 IF '$DATA(IO("Q"))
USE IO
GOTO PRINT
+10 KILL IO("Q")
+11 SET ZTDESC="PURCHASE CARD VERIFY"
SET ZTRTN="PRINT^RMPR4C2"
+12 SET ZTSAVE("RMPRBDT")=""
SET ZTSAVE("RMPREDT")=""
+13 SET ZTSAVE("RMPRY")=""
SET ZTSAVE("RMPR(")=""
SET ZTSAVE("RMPRPCRD")=""
+14 SET ZTSAVE("RMPRX")=""
SET ZTSAVE("RMPRPCNW")=""
SET ZTIO=ION
+15 DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !,"REQUEST QUEUED!"
HANG 1
GOTO EXIT
+16 ;
PRINT SET X1=RMPRBDT
SET X2=-1
DO C^%DTC
SET PAGE=1
SET RMPREND=""
SET RMPRFLG=""
+1 IF $EXTRACT(IOST)["C"
WRITE @IOF
+2 SET RO=RMPRBDT-1
+3 FOR
SET RO=$ORDER(^RMPR(664,"B",RO))
if RO'>0
QUIT
if RO>RMPREDT
QUIT
SET RP=0
FOR
SET RP=$ORDER(^RMPR(664,"B",RO,RP))
if RP'>0
QUIT
DO CK
+4 SET RMPRFLG=""
SET RMPREND=""
+5 DO HDR
DO ST
+6 GOTO EXIT
CK ;set tmp of list to compare with 440.6
+1 if '$DATA(^RMPR(664,RP,0))
QUIT
+2 ;Vendor must not be null,PC number not null,no cancellation date
+3 ;and station must be station selected
+4 ;must have no close out date
+5 ;
+6 if $PIECE(^RMPR(664,RP,0),U,4)=""!($PIECE($GET(^(4)),U,1)="")!($PIECE(^(0),U,5)'="")
QUIT
+7 if $PIECE(^RMPR(664,RP,0),U,14)'=""&($PIECE(^(0),U,14)'=RMPR("STA"))
QUIT
+8 ;close out date
+9 if $PIECE(^RMPR(664,RP,0),U,8)'=""
QUIT
+10 ;decrypt PC number - rmprobl is decrypted card number, rmprpcrd what
+11 ;user typed as 16 dig number
+12 SET ROBL=$PIECE($GET(^RMPR(664,RP,4)),U,1)
+13 SET RMPROBL=$$DEC^RMPR4LI($PIECE(^RMPR(664,RP,4),U,1),$PIECE(^RMPR(664,RP,0),U,9),RP)
+14 if RMPROBL'=RMPRPCRD
QUIT
+15 SET RMPRODR=$PIECE($GET(^RMPR(664,RP,4)),U,6)
+16 if RMPRODR=""
QUIT
+17 SET ^TMP($JOB,RMPRODR,RMPROBL,RP)=""
+18 QUIT
+19 ;
COMP ;Enter RETURN to continue or '^' to exit:
+1 ;
+2 SET RMPRFLG=1
+3 IF $Y>(IOSL-6)
SET RMPRFLG=""
+4 ;
+5 QUIT
ST ;continue if user didn't want out, or time out
+1 ;
+2 IF '$DATA(^TMP($JOB))
WRITE !!,"*** NO DATA TO PRINT ***",!!
QUIT
+3 SET PO=0
+4 FOR
SET PO=$ORDER(^TMP($JOB,PO))
if PO'>0
QUIT
if RMPREND=1
QUIT
Begin DoDot:1
+5 SET POE=$PIECE($GET(^PRC(442,PO,0)),U,1)
+6 if POE=""
QUIT
+7 ;I ($X>14)&($X<65) W ?63,"|"
+8 ;PSPC is psas card number
+9 SET PSPC=0
+10 FOR
SET PSPC=$ORDER(^TMP($JOB,PO,PSPC))
if PSPC'>0
QUIT
if RMPREND=1
QUIT
Begin DoDot:2
+11 SET RD=0
SET VISA2=""
+12 FOR
SET RD=$ORDER(^TMP($JOB,PO,PSPC,RD))
if RD'>0
QUIT
if RMPREND=1
QUIT
Begin DoDot:3
+13 SET ORDATE=$$DAT1^RMPRUTL1($PIECE(^RMPR(664,RD,0),U,1))
+14 WRITE !,ORDATE
+15 WRITE ?14,POE,?28,"|"
+16 SET BDT=RMPRBDT
+17 FOR
SET BDT=$ORDER(^PRCH(440.6,"D",BDT))
if BDT'>0
QUIT
Begin DoDot:4
+18 SET (REC440,RCNT)=0
+19 FOR
SET REC440=$ORDER(^PRCH(440.6,"D",BDT,REC440))
if REC440'>0
QUIT
if RMPREND=1
QUIT
Begin DoDot:5
+20 ;only look at current users records
+21 IF $PIECE(^PRCH(440.6,REC440,0),U,17)'=DUZ
QUIT
+22 KILL RM440
SET RM440=""
SET RECIEN40=REC440_","
+23 DO GETS^DIQ(440.6,RECIEN40,"**","","RM440")
+24 SET PC=RM440(440.6,RECIEN40,3)
SET IFST=RM440(440.6,RECIEN40,14)
SET VISA2=RM440(440.6,RECIEN40,20)
+25 ;S PC=$P(^PRCH(440.6,REC440,0),U,4),IFST=$P(^(0),U,15),VISA2=$P(^(0),U,21)
+26 SET VISA2=$TRANSLATE(VISA2,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTVWXYZ")
+27 ;W ?50,$S(IFST="R":"Reconciled",IFST="N":"None",IFST="D":"Disputed",1:""),?63,"|"
+28 SET PSASV2=$PIECE(POE,"-",2)
+29 ;match on visa 2 string from vendor
+30 IF VISA2'[PSASV2
QUIT
+31 SET RCNT=RCNT+1
+32 if RCNT>1
WRITE !,?28,"|"
+33 WRITE ?30,PC
+34 WRITE ?50,VISA2,?63,"|"
+35 ;verify both files same
+36 IF PC=PSPC
WRITE ?65,"Okay"
+37 IF $EXTRACT(IOST,1,2)["C-"&($Y>(IOSL-6))
SET DIR(0)="E"
DO ^DIR
if (Y<1)!($DATA(DTOUT))
SET RMPREND=1
if $GET(RMPREND)
QUIT
DO HDR
+38 IF $EXTRACT(IOST,1,2)'="C-"&($Y>(IOSL-6))
DO HDR
+39 IF PC=PSPC
QUIT
+40 ;check to make sure it is the new card number
+41 IF PC'=RMPRPCNW
WRITE ?65,"Diff Card #"
QUIT
+42 ;update prosthetic file 664
+43 SET $PIECE(^RMPR(664,RD,4),U,7)=PC
SET $PIECE(^(4),U,8)=REC440
SET $PIECE(^(4),U,9)=DT
+44 ;
+45 ;update file 440.6 with original PC number
+46 SET DIE="^PRCH(440.6,"
SET DR="3////^S X=PSPC"
SET DA=REC440
+47 LOCK +^PRCH(440.6,DA,0):2
IF '$TEST
WRITE !,"Record in use by another user. Try Later!"
KILL DIE
SET RMPREND=1
QUIT
+48 DO ^DIE
+49 LOCK -^PRCH(440.6,DA,0)
+50 KILL DA,DIE,DR
+51 WRITE ?65,"Repaired"
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+52 QUIT
+53 ;
HDR ;header
+1 IF RMPREND=1
QUIT
+2 IF PAGE'=1
WRITE @IOF
+3 WRITE !,RMPRX_"-",RMPRY," Verify PC# "_RMPRPCRD_" STA "_$$STA^RMPRUTIL,?72,"PAGE ",PAGE,!
+4 SET PAGE=PAGE+1
+5 WRITE !,"Order Date",?14,"Order Number",?28,"|",?30,"ORACLE PC #",?50,"VISA II",?63,"|",?65,"Record Status",!,RMPR("L")
+6 QUIT
EXIT ;Common Exit
+1 IF $EXTRACT(IOST)["C"
IF '$GET(RMPREND)
IF $DATA(^TMP($JOB))
WRITE !
SET DIR(0)="E"
DO ^DIR
+2 DO ^%ZISC
NEW RMPR,RMPRSITE
+3 DO KILL^XUSCLEAN
KILL ^TMP($JOB)
+4 QUIT
