source: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTFM2.m@ 636

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

initial load of FOIAVistA 6/30/08 version
File size: 7.3 KB
Line 
1DGPTFM2 ;ALB/DWS - MASTER PROFESSIONAL SERVICE ENTER/EDIT ;6/16/05 8:33am
2 ;;5.3;Registration;**517,590,606,635**;Aug 13, 1993
3ADD ;ADD CPT RECORD
4 N DGZP S DGZP=0 S:'$D(^DGPT(PTF,"C",0)) ^(0)="^45.06D^^"
5 S DIC="^DGPT("_PTF_",""C"",",DIC(0)="AELQMXZ",DA(1)=PTF,DLAYGO=45
6 D ^DIC K DIC,DLAYGO G ^DGPTFM:Y'>0,^DGPTFM:'$D(^DGPT(PTF,"C",+Y))
7 S DGPSM=+Y
8 I '$P(Y,U,3) S DIR("A")="Do you want to edit this CPT RECORD DATE/TIME?",DIR(0)="Y",DIR("B")="YES" D ^DIR G ^DGPTFM:'Y!$D(DIRUT)
9 D MOB
10 I $P(DGZPRF,U,3) F I=1:1:$P(DGZPRF,U,3) S:DGZPRF(I,0)=DGPSM DGZP=I
11 K I G:'DGZP ^DGPTFM S X="A,B",DGPSM=0
12ED G HELP^DGPTUTL1:X'["A"&(X'["B")&(X'["a")&(X'["b") K DA
13 S DGJUMP=X,DGPRD=+DGZPRF(DGZP)
14 I X["A"!(X["a") D L -^DGPT(PTF) I FLAG D MOB,REQ^DGPTFM3 G EXIT
15 .S DA(1)=PTF,DIE="^DGPT("_PTF_",""C"",",(DA,REC)=DGZPRF(DGZP,0)
16 .S DR=".01;.02;.03;.05;.09////0",DIC(0)="AELQZ" Q:'$$LOCK
17 .D FMDIE S FLAG=$D(Y)>9!$D(DOUT)!'$D(DA) Q:$D(Y)>9!'$D(DA)
18 .S DGPRD=+^DGPT(PTF,"C",DGZPRF(DGZP,0),0) Q:+DGZPRF(DGZP)=DGPRD
19 .S DGI=0 F S DGI=$O(^DGCPT(46,"C",PTF,DGI)) Q:DGI'>0 D Q:$D(Y)>9!'$D(DA)
20 ..Q:+^DGCPT(46,DGI,1)'=+DGZPRF(DGZP) Q:$D(^(9))
21 ..S DR=".14////"_DGPRD,(DA,REC)=DGI,DIE="^DGCPT(46," D FMDIE
22 ..I $D(Y)>9!'$D(DA) S FLAG=1
23 .S $P(DGZPRF(DGZP),U)=DGPRD
24JUMP I DGJUMP["B"!(DGJUMP["b") S DGI=0 D CL^SDCO21(DFN,DGPRD,"",.SDCLY) D
25 .F S DGI=$O(^DGCPT(46,"C",PTF,DGI)) Q:DGI'>0 I +^DGCPT(46,DGI,1)=+DGZPRF(DGZP),'$G(^(9)) D I $D(DUOUT) Q:'DGDIAG K DUOUT S DGI=0
26 ..S (DA,REC)=DGI,DR=".01;",DIE="^DGCPT(46," D GETINFO^DGPTFM21
27 .Q:$D(DUOUT)
28 .F D D ^DIC S A=0 Q:Y'>0 D SED Q:$D(DUOUT)
29 ..S DA=PTF,DIC="^DGCPT(46,",DIC(0)="AELMQZ",DLAYGO=46
30 ..S DIC("S")="D EN6^DGPTFJC I 'DGER"
31 I $D(DUOUT),$G(DGDIAG) K DUOUT G JUMP
32 I $D(DUOUT),$G(DGJUMP)["A"!($G(DGJUMP)["a") S X=DGJUMP K DUOUT G ED
33 K DR,DIE,DIC,DA,DGI,DGJUMP,DGPRD,DLAYGO,XREF
34 D REQ^DGPTFM3,MOB H:RFL 2 K RFL
35 G ^DGPTFM:'$D(DGZPRF(DGZP,0)),^DGPTFM:'$D(^DGPT(PTF,"C",DGZPRF(DGZP,0)))
36SET D MOB:'$D(DGZPRF) S:'$D(DGZP) DGZP=1 I $G(DGZPRF(DGZP,0))="" K DGZPRF(DGZP) G NEXP
37WRT G ^DGPTFM:'$D(^DGPT(PTF,"C",DGZPRF(DGZP,0),0)) S J=DGZP W @IOF,HEAD,?68
38 N DGNUM S Z="<"_DGZP_">" W @DGVI,Z,@DGVO,!! S Y=+DGZPRF(J),Z="A"
39 D D^DGPTUTL,Z^DGPTFM5 W ?5,"CPT Record Date/Time: ",Y
40 I $P(DGZPRF(J),U,8)'="" W ?55,"Visit Service Category: ",$P(DGZPRF(J),U,8)
41 I $P(DGZPRF(J),U,2) W !,?5,"Referring or Ordering Provider: " D
42 .S L=$P(DGZPRF(J),U,2) D PRV^DGPTFM
43 W !,?5,"Rendering Provider: " S L=$P(DGZPRF(J),U,3) D PRV^DGPTFM
44 I $P(DGZPRF(J),U,5) W !,?5,"Rendering Location: ",$P($G(^SC($P(DGZPRF(J),U,5),0)),U)
45 W !! S Z="B" D Z^DGPTFM5 W " Procedures: "
46 F K=$P(DGZPRF,U,2):1 Q:'$D(DGZPRF(J,K)) I '$D(DGZPRF(J,K,9)) D
47 .W ?5 D CPT^DGPTUTL1 W ! Q:$Y>16
48 F I=1:1:(IOSL-$Y-5) W !
49 K I,J,K,L,Z S DGNUM=$S($D(DGZPRF(DGZP+1)):DGZP+1,1:"MAS")
50 G 801^DGPTFJC:DGST
51 S DIR("A")="Enter <RET> to continue, A-B to edit, 'I' to add an 801,"
52 S DIR("A")=DIR("A")_$C(10,13)_"the number of an 801 screen, ?? to list 801 screens,"
53 S DIR("A")=DIR("A")_$C(10,13)_"'S' for Send to PCE,"
54 S DIR("A")=DIR("A")_" '^N' for screen N, or '^' to abort:"
55 S DIR("?")="^D HELP^DGPTUTL1"
56 S DIR(0)="F^OU",DIR("B")=DGNUM,DIR("??")="^D DISP^DGPTUTL1" D ^DIR
57 K DIR G:$D(DIRUT) Q^DGPTF:X="^"
58 I X?1"^".E S DGPTSCRN=801 G ^DGPTFJ
59 I X="MAS" S DGZP=1 G ^DGPTFM
60 G ADD:X="I"!(X="i"),HELP^DGPTUTL1:X["?"
61 I X?1N.N,$D(DGZPRF(X)) S DGZP=X G SET
62 I X["A"!(X["B")!(X["a")!(X["b") G ED
63 I X="S"!(X="s") D PCE G WRT
64 D HELP^DGPTUTL1 R !!,"Enter <RET>: ",X:DTIME G WRT
65PCE L +^DGPT(PTF):2
66 I '$T W !,"CPT Record is being edited by another user" H 2 Q
67 D ICDINFO^DGAPI(DFN,PTF),XREF^DGPTFM21
68 S RES=$$DATA2PCE^DGAPI1(DFN,PTF,DGZP)
69 I RES=1 L -^DGPT(PTF) W !,"PTF Record sent to PCE" H 2 Q
70 W @IOF
71 ;F I=1:1 Q:'$D(^TMP("DGPAPI",$J,"DIERR",$J,1,"TEXT",I)) W !,^(I)
72 W !,"The PTF Record may not have been filed in PCE due to errors."
73 W !,"Press return to continue." R X:DTIME
74 L -^DGPT(PTF) Q
75NEXP S DGZP=DGZP+1
76 I '$D(DGZPRF(DGZP)) W:DGZP=2 !,"NO PROF. SERVICES TO EDIT." G EXIT
77 G SET
78EXIT K DGPSM H 2 S DGZP=1 G ^DGPTFM
79DEL ;DELETE A CPT RECORD
80 I '$P(DGZPRF,U,3) G NOPROC
81ASK S DIR("A")="Select 801 record to Delete"
82 S DIR(0)="NO^1:"_$P(DGZPRF,U,3),DIR("??")="^D DISP^DGPTUTL1"
83 D ^DIR K DIR G ^DGPTFM:$D(DIRUT),^DGPTFM:'Y,^DGPTFM:'$D(^DGPT(PTF,"C",DGZPRF(Y,0),0)) S DGZP=Y,Y=+^(0) D D^DGPTUTL
84 S DIR("A")="Are you sure you want to delete the entire 801 for "_Y
85 S DIR(0)="Y",DIR("B")="No" D ^DIR K DIR G ^DGPTFM:'Y,^DGPTFM:'$$LOCK
86 S DGI=0 D NOW^%DTC
87 F S DGI=$O(^DGCPT(46,"C",PTF,DGI)) Q:DGI'>0 D:+^DGCPT(46,DGI,1)=+DGZPRF(DGZP)&'$G(^(9))
88 .S (DA,REC)=DGI,DIE="^DGCPT(46,",DR="1////^S X=%" D FMDIE
89 S DR=".09////1",DIE="^DGPT("_PTF_",""C"",",DA=DGZPRF(DGZP,0)
90 S DA(1)=PTF D ^DIE L -^DGPT(PTF)
91 W !!,"CPT Records....Deleted" H 2
92 K DIK,DA,DGI,DGPROC,DGPSM,DGPNUM,Y D MOB G ^DGPTFM
93NOPROC W !!,*7,"No procedures to delete",! H 3 G ^DGPTFM
94N ;ADD CPT CODES TO CPT RECORD
95 I '$P(DGZPRF,U,3) W !!,"There are no 801 records that can be added to.",*7 H 2 G ^DGPTFM
96P1 S DIR("A")="Add to 801 record ",DIR(0)="NO^1:"_$P(DGZPRF,U,3)
97 S DIR("??")="^D DISP^DGPTUTL1"
98 D ^DIR K DIR G ^DGPTFM:'Y
99 S DGZP=Y,DGI=0,DGPRD=+DGZPRF(DGZP) D CL^SDCO21(DFN,DGPRD,"",.SDCLY)
100 S DA=PTF,DIC="^DGCPT(46,",DIC(0)="AELQMZ",DLAYGO=46,DIC("S")="D EN6^DGPTFJC I 'DGER"
101 D ^DIC K DIC,DLAYGO D:Y>0 SED,MOB,REQ^DGPTFM3 K DGPRD,Y
102 D PCE^DGPTFQWK G ^DGPTFM
103DC ;DELETE A CPT PROCEDURE
104 I $E($G(ANS),2,99)>0 S DGPZ=+$E(ANS,2,99) G QQ
105 S DIR("A")="Select 801 record to Delete a CPT code in"
106 S DIR(0)="NO^1:"_$P(DGZPRF,U,3),DIR("??")="^D DISP^DGPTUTL1"
107 D ^DIR K DIR G ^DGPTFM:$D(DIRUT),^DGPTFM:'Y,^DGPTFM:'$D(^DGPT(PTF,"C",DGZPRF(Y,0),0)) S DGZP=Y,Y=+^(0) D D^DGPTUTL
108 F PS2=1:1 Q:'$D(DGZPRF(DGZP,PS2)) S PS2(PS2)=DGZP_"^"_PS2
109 S PS2=PS2-1
110QQ S DIR("A")="Select CPT code to Delete <1 - "_PS2_">",DIR(0)="NO^^K:X<1!(X>"_PS2_") X" D ^DIR K DIR G ^DGPTFM:$D(DIRUT),^DGPTFM:'Y
111QQA S A1=Y,DGZP=+PS2(A1),CPT=+DGZPRF(DGZP,$P(PS2(A1),U,2))
112 S DIR("A")="Are you sure you want to delete CPT code '"
113 I $D(^ICPT(CPT)) D
114 .S N=$$CPT^ICPTCOD(CPT,$$GETDATE^ICDGTDRG(PTF))
115 .S N=$S(N>0:$P(N,U,2,99),1:"")
116 .S DIR("A")=DIR("A")_$P(N,U)_" "_$P(N,U,2)_"'"
117 E S DIR("A")=DIR("A")_CPT_" UNKNOWN"
118 S DIR(0)="Y",DIR("B")="No" D ^DIR K DIR G ^DGPTFM:'Y
119 G ^DGPTFM:'$$LOCK
120QEL D NOW^%DTC S DA=DGZPRF(DGZP,$P(PS2(A1),U,2),0),DR="1////^S X=%"
121 S REC=DGZPRF(DGZP,0)
122 S DIE="^DGCPT(46," D FMDIE K A1,DR W !!,"CPT Code....Deleted"
123 I '$D(DGZPRF(DGZP,2)) S DR=".09////1",DIE="^DGPT("_PTF_",""C"",",DA=DGZPRF(DGZP,0),DA(1)=PTF D ^DIE
124 I $D(DGZPRF(DGZP,2)) D PCE^DGPTFQWK
125 L -^DGPT(PTF) W:$X>70 ! D MOB H 2 G ^DGPTFM
126F D MOB S DGZP=$S($E($G(ANS),2,99):+$E($G(ANS),2,99),1:1) G SET
127MOB S (H,I,N)=0 K DGZPRF F M=1:1:6 S:$D(SDCLY(M)) N=N+1
128 F I2=1:1 S H=$O(^DGPT(PTF,"C","B",H)) Q:H'>0 D
129 .F S I=$O(^DGPT(PTF,"C","B",H,I)) Q:I'>0 D
130 ..S DGZPRF(I2)=^DGPT(PTF,"C",I,0),DGZPRF(I2,0)=I,(K,K1)=0,F=1 D
131 ...F S K=$O(^DGCPT(46,"C",PTF,K)),L=N+1\2+3 Q:K'>0 I +DGZPRF(I2)=+$G(^DGCPT(46,K,1)),'$G(^DGCPT(46,K,9)) D
132 ....S K1=K1+1,DGZPRF(I2,K1)=^(0),DGZPRF(I2,K1,0)=K,F=0
133 ....F M=2,3,5,6,7,15,16,17,18 S:$P(DGZPRF(I2,K1),U,M) L=L+1
134 ....S DGZPRF(I2,K1,1)=L
135 ...I F,$G(DGPSM)'=DGZPRF(I2,0) K DGZPRF(I2) S I2=I2-1
136 S DGZPRF="1^1^"_(I2-1) K F,I,K,K1,N Q
137SED S DR=".14////"_DGPRD_";.16////"_PTF_";",(DA,REC)=+Y,DIE="^DGCPT(46," D GETINFO^DGPTFM21 Q
138FMDIE ;Prompt user for questions and file answers (using DIE)
139 D ^DIE Q:$D(Y)>9 S RES=$$DELVFILE^DGAPI1(DFN,PTF,DGZP) K DIE,REC Q
140LOCK() L +^DGPT(PTF):2 I Q 1
141ERR W !,"CPT Record is being edited by another user" K DIE,REC H 2 Q 0
Note: See TracBrowser for help on using the repository browser.