source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHCS.m@ 619

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

initial load of WorldVistAEHR
File size: 4.3 KB
Line 
1PRCHCS ;WISC/RSD,RHD-EDIT LOG CODE SHEETS ;9/16/94 12:23 PM
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4EN S PRCHN("PO")=$P($P(^PRC(442,PRCHPO,0),"-",2),U,1)
5 S:'$D(PRCFA("SYS")) PRCFA("SYS")="LOG"
6 S PRCFA("REF")=PRCHN("PO"),PRCHAUTO="" W !," Now creating "_PRCFA("SYS")_" code sheets ."
7 S PRCHLI=0,PRCHLCNT=0 F PRCHI=1:1 S PRCHLI=$O(^PRC(442,PRCHPO,2,PRCHLI)) Q:'PRCHLI D SET I PRCHOK S:$D(DA) PRCHLCNT=PRCHLCNT+1 I '$D(DA) D ^PRCHCS1 Q:'$D(PRCFA)!($D(PRCHISMS)) W "." I $D(DA),DA S PRCHLCNT=PRCHLCNT+1
8 I PRCHLCNT'>0,'$D(PRCHISMS) W !,"No code sheets created !",$C(7) K PRCHPO G Q
9 ;
101 D:'$D(IOF) HOME^%ZIS
11 G:$D(PRCHISMS) TRAN1
12 W !! D HDR^PRCHCS0
13 S PRCHLI=0 F PRCHI=1:1 S PRCHLI=$O(^PRC(442,PRCHPO,2,PRCHLI)) Q:'PRCHLI S PRCH="" D CHK I PRCHOK S:$D(DA) PRCH=DA D:'PRCH ERR1 D:PRCH 11
14 G 2
15 ;
1611 I '$D(^PRCF(423,PRCH,300))!('$D(^("CODE",1,0))) D ERR1 Q
17 S X=+^PRCF(423,PRCH,300),Y=^("CODE",1,0) W !," Line Item: ",X,!,Y D ERR^PRCHCS0:$L(Y)'=80!($O(^PRCF(423,PRCH,"CODE",1))),ASK^PRCHCS0:'(PRCHLI#9)
18 Q
19 ;
202 W ! S %A="Do you want to mark these code sheets for transmission",%B="'YES' will mark the code sheets for transmission.",%B(1)="'NO' will give you a chance to edit code sheets."
21 S %B(2)="'^' will delete code sheets." D ^PRCFYN G TRAN:%=1,DEL1:%<0
223 S %A="Do you want to edit any code sheets",%B="'YES' to edit any code sheet.",%B(1)="'NO' or '^' for chance to delete code sheets." D ^PRCFYN G DEL:%'=1
234 D LI G:Y<0 2 K PRCHLOG S DIE="^PRCF(423,",DR=PRCFA("EDIT") D ^DIE S PRCHLOG=1 D ^PRCFACX1,DSP^PRCHCS0 L -^PRCF(423,DA)
24 G 4
25 ;
26TRAN I '$D(DT) D NOW^%DTC S DT=$P(%,".",1)
27 S %DT="AEXF",%DT("A")="TRANSMISSION DATE: ",%DT("B")="TODAY",%DT(0)=DT D ^%DT G:Y<0 3 S PRCHDT=Y
28 D SIG^PRCHCS0 I '$D(PRCHNM) D:$D(PRCHLOG) DEL1 K PRCHPO G Q
29TRAN1 S PRCHLI=0,PRCHBTYP=5 S:PRCFA("TT")=100 PRCHBTYP=7 F PRCHI=1:1 S PRCHLI=$O(^PRC(442,PRCHPO,2,PRCHLI)) Q:'PRCHLI D CHK I PRCHOK,$D(DA) D MRK
30 W !!,$C(7),"CODE SHEETS MARKED FOR TRANSMISSION!"
31 L -^PRC(442,PRCHPO)
32 S DA=PRCH,PRCFA("CSDA")=DA D UNLCK1^PRCHDEP3
33 G Q
34 ;
35QQ S:'$D(ROUTINE) ROUTINE=$T(+0) W !!,$$ERR^PRCHQQ(ROUTINE,PRCSIG) W:PRCSIG=0!(PRCSIG=-3) !,"Notify Application Coordinator!",$C(7) S DIR(0)="EAO",DIR("A")="Press <return> to continue" D ^DIR
36Q D Q^PRCHCS0 K ROUTINE Q
37 ;
38MRK ;MARK CODE SHEET FOR TRANSMISSION
39 S PRCSIG="" D ENCODE^PRCFES1(DA,DUZ,.PRCSIG) S ROUTINE=$T(+0) G:PRCSIG<1 QQ S DIE="^PRCF(423,",DR="999////"_+PRC("PER")_";.5///"_PRCHDT_";.6///"_PRCHBTYP_";.8///3;300.1///"_PRCHKEY D ^DIE Q
40SET S PRCH0=^PRC(442,PRCHPO,2,PRCHLI,0),I=+$P(^(0),U,5),PRCH2=$G(^(2)),PRCH4=$G(^(4)),PRCHI0=$G(^PRC(441,I,0)),PRCHIV0=$G(^PRC(441,I,2,+^PRC(442,PRCHPO,1),0))
41 I PRCHI0="" S PRCHI0=$O(^PRC(442,PRCHPO,2,PRCHLI,1,0)) I $D(^(+PRCHI0,0)) S PRCHI0="^"_$E(^(0),1,60)
42CHK ;SEE WHETHER CODE SHEET ALREADY ON FILE
43 S PRCHOK=0 K DA I PRCHTYP="R" S PRCHRRI=$O(^PRC(442,PRCHPO,2,"AB",PRCHRD,PRCHLI,0)) Q:'PRCHRRI S PRCHR0=$G(^PRC(442,PRCHPO,2,PRCHLI,3,PRCHRRI,0)) I PRCHR0=""!('$P(PRCHR0,U,2)) Q
44 S PRCHOK=1 I PRCHTYP="R" S DA=$P($G(^PRC(442,PRCHPO,2,PRCHLI,3,PRCHRRI,0)),U,6)
45 I PRCHTYP="A" S DA=$P($G(^PRC(442,PRCHPO,2,PRCHLI,4)),U,8)
46 I PRCHTYP="I" S DA=$G(^PRC(442,PRCHPO,21,1))
47 I $D(DA),$D(^PRCF(423,+DA,0)) Q
48 K DA Q
49 ;
50ERR1 D ERR1^PRCHCS0,^PRCFYN Q:%'=1
51 D SET,^PRCHCS1 Q:'$D(PRCFA) I $D(DA),DA S PRCH=DA
52 Q
53 ;
54LI K DA,DIC,PRCHDA S D0=PRCHPO,DIC="^PRC(442,PRCHPO,2,",DIC(0)="AEMQ" S:PRCHTYP="A" DIC("S")="I $D(^(4)) S PRCHDA=$P(^(4),U,8) I PRCHDA"
55 S:PRCHTYP="R" DIC("S")="S PRCHRRI=$O(^PRC(442,PRCHPO,2,""AB"",PRCHRD,Y,0)) I $D(^PRC(442,PRCHPO,2,Y,3,+PRCHRRI,0)) S PRCHDA=$P(^(0),U,6) I PRCHDA"
56 D ^DIC K DIC Q:Y<0 S PRCHLI=+Y S:$D(PRCHDA) DA=PRCHDA K PRCHDA Q
57DEL S %A="Delete all code sheets for this "_$S(PRCHTYP="R":"Partial",1:"Order"),%B="'YES' or '^' to delete all code sheets.",%B(1)="'NO' to delete selected Line Item code sheets." D ^PRCFYN G:%'=2 DEL1
58DEL0 W !?3,"Delete selected Line Item Code Sheets:" D LI G:'$D(DA) 1 S DIK="^PRCF(423," D ^DIK S DA="" D SETR^PRCHCS1 G DEL0
59 ;
60DEL1 ;DELETES ALL CODE SHEETS
61 S DIK="^PRCF(423," D WAIT^DICD
62 I $D(PRCFA("CSDA")) S DA=PRCFA("CSDA")
63 I $G(PRCH)>0 S DA=PRCH
64 D UNLCK1^PRCHDEP3
65 L -^PRC(442,PRCHPO)
66 S PRCHLI=0 F PRCHI=1:1 S PRCHLI=$O(^PRC(442,PRCHPO,2,PRCHLI)) Q:'PRCHLI D CHK I $D(DA) D ^DIK S DA="" D SETR^PRCHCS1
67 K DIK W !,"ALL CODE SHEETS DELETED FOR THIS "_$S(PRCHTYP="R":"PARTIAL",1:"ORDER")_" !",$C(7) K PRCHPO G Q
Note: See TracBrowser for help on using the repository browser.