PRPFARC ;CTB/ALTOONA PATIENT FUNDS ARCHIVE ;1/7/98 12:25 PM
V ;;3.0;PATIENT FUNDS;**6,7,9**;JUNE 1, 1989
N X,MTIO,NAME,PGCOUNT,XPDNM,ZTQUEUED
S X="This option will cause all transactions of all cards to be written to tape in alphabetical order" D MSG^PRPFU1
K ^TMP($J,"PRPFARC")
S PGCOUNT=0
S %A="Are You Ready to Begin",%B="",%=1 D ^PRPFYN Q:%'=1
S MESSAGE="BUILDING ALPHABETIC CROSS REFERENCE IN ^TMP. ITEMS=PATIENTS"
S TREC=$P(^PRPF(470,0),"^",4)
G DONE:TREC<1 ; By REW 3*9 QUIT:TREC=0
D BEGIN^PRPFU
S DA=0 F D S XCOUNT=XCOUNT+COUNT D:'$D(ZTQUEUED) PERCENT^PRPFU Q:'DA
. F COUNT=1:1:LREC S DA=$O(^PRPF(470,DA)) Q:'DA S:$D(^DPT(DA,0)) ^TMP($J,"PRPFARC",$P(^DPT(DA,0),"^"),DA)=""
. QUIT
K X S $P(X," ",40)=""
W !!!!,"100% complete."_$P(X," ",1,40),!
D:$G(XPDNM)="" KILL^%ZISS
HDR W !!,"You now need to enter the header information:"
S DIR(0)="FA^3:30",DIR("A")="Select Header Line 1: ",DIR("B")=$S($D(LINE(1)):LINE(1),1:"VA MEDICAL CENTER"),DIR("?")="Enter the first line of the header to be printed on the archive record tape or an '^' to quit"
D ^DIR K DIR I $$DIR^PRPFU2 D TERM QUIT
S LINE(1)=Y
S DIR(0)="FA^3:30",DIR("A")="Select Header Line 2: ",DIR("?")="Enter the second line of the header to be printed on the archive record tape or an '^' to quit" S:$D(LINE(2)) DIR("B")=LINE(2)
D ^DIR K DIR I $$DIR^PRPFU2 D TERM QUIT
S LINE(2)=Y
S DIR(0)="FOA^3:30",DIR("A")="Select Header Line 3: ",DIR("?")="Enter the third line of the header to be printed on the archive record tape or an '^' to quit" S:$D(LINE(3)) DIR("B")=LINE(3)
D ^DIR K DIR I Y]"",$$DIR^PRPFU2 D TERM QUIT
S LINE(3)=Y
W !! F I=1:1:3 W LINE(I),!
D NOW^PRPFQ S LINE(4)=%X
S DIR("A")="IS THIS OK",DIR(0)="Y" D ^DIR I $$DIR^PRPFU2 D TERM QUIT
I 'Y W !!,"OK, you may now edit this information.",! G HDR
S %ZIS("A")="Select Tape/HFS Device: "
D ^%ZIS I POP D TERM QUIT
S MTIO=IO D HOME^%ZIS
S PRPF("ARCHIVE")=""
U MTIO W "1^PATIENT FUNDS ARCHIVE^"_$$DATE^PRPFU1(DT),!,"2^"_LINE(1),!,"2^"_LINE(2)
U MTIO I $G(LINE(3))]"" W !,"2^"_LINE(3)
U MTIO W !,"3^~~PRPF~~^"_$P(^PRPF(470,0),"^",4)_"^^"
U MTIO W !,"4^NAME^CLAIM^SSN"
U MTIO W !,"5^LANDSCAPE^COURIER NEW^24",!
S MESSAGE="ARCHIVING PATIENT FUNDS CARDS. ITEMS=PATIENT NAME"
S NAME="" F I=0:1 S NAME=$O(^TMP($J,"PRPFARC",NAME)) Q:NAME=""
S TREC=I
QUIT:TREC=0
U IO D BEGIN^PRPFU
S NAME="" F U MTIO D S XCOUNT=XCOUNT+COUNT U IO D:'$D(ZTQUEUED) PERCENT^PRPFU Q:NAME=""
. F COUNT=1:1:LREC S NAME=$O(^TMP($J,"PRPFARC",NAME)) Q:NAME="" D
. . S DA=0 F S DA=$O(^TMP($J,"PRPFARC",NAME,DA)) Q:'DA D
. . . S DFN=DA
. . . U MTIO D EN2^PRPFCD
. . . QUIT
. . QUIT
. QUIT
U MTIO W !!,"ARCHIVE COMPLETED*^^*"
D:$G(XPDNM)="" KILL^%ZISS
D CLOSE^PRPFU,END^PRPFU
DONE D ADD("ARCHIVE",DT)
U IO W !!,"ARCHIVE COMPLETED",$C(7)
QUIT
TERM ;
U IO W " OPTION TERMINATED",$C(7) Q
ADD(TYPE,THRU) ;ADD ENTRY TO ARCHIVE HISTORY FILE
NEW DIC,X,%,%H,%I,DA,DR,DLAYGO
D NOW^%DTC S X=%
K DD,D0 S DIC="^PRPF(470.9,",DIC(0)="ML",DLAYGO=470.9
S DIC("DR")="1///"_TYPE I $D(THRU) S DIC("DR")=DIC("DR")_";2///"_THRU
D FILE^DICN
QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRPFARC 3152 printed Dec 13, 2024@02:01:25 Page 2
PRPFARC ;CTB/ALTOONA PATIENT FUNDS ARCHIVE ;1/7/98 12:25 PM
V ;;3.0;PATIENT FUNDS;**6,7,9**;JUNE 1, 1989
+1 NEW X,MTIO,NAME,PGCOUNT,XPDNM,ZTQUEUED
+2 SET X="This option will cause all transactions of all cards to be written to tape in alphabetical order"
DO MSG^PRPFU1
+3 KILL ^TMP($JOB,"PRPFARC")
+4 SET PGCOUNT=0
+5 SET %A="Are You Ready to Begin"
SET %B=""
SET %=1
DO ^PRPFYN
if %'=1
QUIT
+6 SET MESSAGE="BUILDING ALPHABETIC CROSS REFERENCE IN ^TMP. ITEMS=PATIENTS"
+7 SET TREC=$PIECE(^PRPF(470,0),"^",4)
+8 ; By REW 3*9 QUIT:TREC=0
if TREC<1
GOTO DONE
+9 DO BEGIN^PRPFU
+10 SET DA=0
FOR
Begin DoDot:1
+11 FOR COUNT=1:1:LREC
SET DA=$ORDER(^PRPF(470,DA))
if 'DA
QUIT
if $DATA(^DPT(DA,0))
SET ^TMP($JOB,"PRPFARC",$PIECE(^DPT(DA,0),"^"),DA)=""
+12 QUIT
End DoDot:1
SET XCOUNT=XCOUNT+COUNT
if '$DATA(ZTQUEUED)
DO PERCENT^PRPFU
if 'DA
QUIT
+13 KILL X
SET $PIECE(X," ",40)=""
+14 WRITE !!!!,"100% complete."_$PIECE(X," ",1,40),!
+15 if $GET(XPDNM)=""
DO KILL^%ZISS
HDR WRITE !!,"You now need to enter the header information:"
+1 SET DIR(0)="FA^3:30"
SET DIR("A")="Select Header Line 1: "
SET DIR("B")=$SELECT($DATA(LINE(1)):LINE(1),1:"VA MEDICAL CENTER")
SET DIR("?")="Enter the first line of the header to be printed on the archive record tape or an '^' to quit"
+2 DO ^DIR
KILL DIR
IF $$DIR^PRPFU2
DO TERM
QUIT
+3 SET LINE(1)=Y
+4 SET DIR(0)="FA^3:30"
SET DIR("A")="Select Header Line 2: "
SET DIR("?")="Enter the second line of the header to be printed on the archive record tape or an '^' to quit"
if $DATA(LINE(2))
SET DIR("B")=LINE(2)
+5 DO ^DIR
KILL DIR
IF $$DIR^PRPFU2
DO TERM
QUIT
+6 SET LINE(2)=Y
+7 SET DIR(0)="FOA^3:30"
SET DIR("A")="Select Header Line 3: "
SET DIR("?")="Enter the third line of the header to be printed on the archive record tape or an '^' to quit"
if $DATA(LINE(3))
SET DIR("B")=LINE(3)
+8 DO ^DIR
KILL DIR
IF Y]""
IF $$DIR^PRPFU2
DO TERM
QUIT
+9 SET LINE(3)=Y
+10 WRITE !!
FOR I=1:1:3
WRITE LINE(I),!
+11 DO NOW^PRPFQ
SET LINE(4)=%X
+12 SET DIR("A")="IS THIS OK"
SET DIR(0)="Y"
DO ^DIR
IF $$DIR^PRPFU2
DO TERM
QUIT
+13 IF 'Y
WRITE !!,"OK, you may now edit this information.",!
GOTO HDR
+14 SET %ZIS("A")="Select Tape/HFS Device: "
+15 DO ^%ZIS
IF POP
DO TERM
QUIT
+16 SET MTIO=IO
DO HOME^%ZIS
+17 SET PRPF("ARCHIVE")=""
+18 USE MTIO
WRITE "1^PATIENT FUNDS ARCHIVE^"_$$DATE^PRPFU1(DT),!,"2^"_LINE(1),!,"2^"_LINE(2)
+19 USE MTIO
IF $GET(LINE(3))]""
WRITE !,"2^"_LINE(3)
+20 USE MTIO
WRITE !,"3^~~PRPF~~^"_$PIECE(^PRPF(470,0),"^",4)_"^^"
+21 USE MTIO
WRITE !,"4^NAME^CLAIM^SSN"
+22 USE MTIO
WRITE !,"5^LANDSCAPE^COURIER NEW^24",!
+23 SET MESSAGE="ARCHIVING PATIENT FUNDS CARDS. ITEMS=PATIENT NAME"
+24 SET NAME=""
FOR I=0:1
SET NAME=$ORDER(^TMP($JOB,"PRPFARC",NAME))
if NAME=""
QUIT
+25 SET TREC=I
+26 if TREC=0
QUIT
+27 USE IO
DO BEGIN^PRPFU
+28 SET NAME=""
FOR
USE MTIO
Begin DoDot:1
+29 FOR COUNT=1:1:LREC
SET NAME=$ORDER(^TMP($JOB,"PRPFARC",NAME))
if NAME=""
QUIT
Begin DoDot:2
+30 SET DA=0
FOR
SET DA=$ORDER(^TMP($JOB,"PRPFARC",NAME,DA))
if 'DA
QUIT
Begin DoDot:3
+31 SET DFN=DA
+32 USE MTIO
DO EN2^PRPFCD
+33 QUIT
End DoDot:3
+34 QUIT
End DoDot:2
+35 QUIT
End DoDot:1
SET XCOUNT=XCOUNT+COUNT
USE IO
if '$DATA(ZTQUEUED)
DO PERCENT^PRPFU
if NAME=""
QUIT
+36 USE MTIO
WRITE !!,"ARCHIVE COMPLETED*^^*"
+37 if $GET(XPDNM)=""
DO KILL^%ZISS
+38 DO CLOSE^PRPFU
DO END^PRPFU
DONE DO ADD("ARCHIVE",DT)
+1 USE IO
WRITE !!,"ARCHIVE COMPLETED",$CHAR(7)
+2 QUIT
TERM ;
+1 USE IO
WRITE " OPTION TERMINATED",$CHAR(7)
QUIT
ADD(TYPE,THRU) ;ADD ENTRY TO ARCHIVE HISTORY FILE
+1 NEW DIC,X,%,%H,%I,DA,DR,DLAYGO
+2 DO NOW^%DTC
SET X=%
+3 KILL DD,D0
SET DIC="^PRPF(470.9,"
SET DIC(0)="ML"
SET DLAYGO=470.9
+4 SET DIC("DR")="1///"_TYPE
IF $DATA(THRU)
SET DIC("DR")=DIC("DR")_";2///"_THRU
+5 DO FILE^DICN
+6 QUIT
