source: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTUTL1.m@ 1651

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

initial load of WorldVistAEHR
File size: 4.9 KB
RevLine 
[613]1DGPTUTL1 ;ALB/MJK - PTF Utility ;2/1/05 2:20pm
2 ;;5.3;Registration;**33,45,54,517,635**;Aug 13, 1993
3 ;
4FLAG ; -- select PTF rec to update xmit flags
5 S DGMAX=25
6 W ! S DIC="^DGPT(",DIC(0)="AEMQ",DIC("S")="I '$P(^(0),U,6),$P(^(0),U,11)=1 D CHK^DGPTUTL1 I $D(DGMTY)>9"
7 D ^DIC K DIC G FLAGQ:+Y<0 S (Y,PTF)=+Y D CHK
8 F DGMTY=501,535 I $D(DGMTY(DGMTY)) D UP Q:$D(DGOUT)
9FLAGQ K DGMAX,DGT,DGADM,DGX,DGA1,DGA,DGMTY,C,DGOUT Q
10 ;
11UP ; -- select mvt and update xmit flag
12 I DGMTY=501 S DIC="^DGPT("_PTF_",""M"",",DIC("S")="I Y'=1,'$D(^(""P""))"
13 I DGMTY=535 S DIC="^DGPT("_PTF_",535,",DIC("S")="I Y'=1"
14 W ! S DIC(0)="AEMQ" D ^DIC S DIE=DIC K DIC
15 K DGOUT I X["^" S DGOUT=""
16 I +Y<0 G UPQ
17 S DA=+Y,DR=17 D ^DIE K DE,DQ G UP
18UPQ K DIE,DR Q
19 ;
20CHK ;
21 N T1,T2,C K DGMTY S T1=0,T2=9999999
22 F DGMTY=501,535 D 501^DGPTFVC2:DGMTY=501,535^DGPTFVC2:DGMTY=535 S:C>DGMAX DGMTY(DGMTY)=""
23 Q
24 ;
25INCOME ;-- load ptf income information
26 ; Use discharge date if available; else use current date/time
27 D NOW^%DTC
28 S X=$S($D(^DGPT(PTF,70)):+^(70),1:%),DGX=$S($D(^DGPT(PTF,101)):^(101),1:"")
29 D INC
30 G INQ:Y=$P(DGX,U,7)
31 S DIE="^DGPT(",DA=PTF,DR="101.07////"_Y
32 D ^DIE
33INQ ;
34 K DGX,DGINCM,DIE,DA,DR,DGI,DG30,DG362,DGT,%
35 Q
36 ;
37INC ;-- load income information Input:X date,Output:Y-income
38 N DGINCM,DGI,DG30,DG362,DGT,DGX
39 I '$D(X) S Y="" G INCQ
40 S Y=+$P($$INCOME^VAFMON(DFN,X),".")
41 I Y<0 S Y=0
42INCQ Q
43 ;
44CHQUES ;-- This function will deterime if the patient has any of the following
45 ; indicated : AO, IR and EC. If so the array DGEXQ will contain
46 ; DGEXQ(1)="" - AO
47 ; DGEXQ(2)="" - IR
48 ; DGEXQ(3)="" - EC
49 ; Otherwise they will be undefined.
50 K DGEXQ
51 S DGEXQ(1)="",DGEXQ(2)="",DGEXQ(3)=""
52 Q
53 ;
54SETTRAN ;-- set transmission if error DGOUT=1, will return XMZ
55 K DGXMZ
56 S DGOUTX=0
57 S Y=$S($P(DGD,".",2)=99:DGSD,1:DGD) X ^DD("DD")
58 S XMSUB=Y_" "_$P(DGRTY0,U)_" TRANSMISSION ",XMDUZ=.5
59 D GET^XMA2
60 I $D(XMZ),XMZ>0 S DGXMZ=XMZ K XMZ G SETQ
61 W !!,"*** ERROR *** Unable to create Mail Message #... Try again later."
62 S DGOUTX=1
63SETQ ;
64 Q
65 ;
66KVAR ; -- clean up for l/e
67 K DA,DFN,A,B,I,ANS,DIE,DR,%,%DT,DGPR,DGREL,DGST,DIC,HEAD,J,K,L,M,MT,NU,PTF,DGPTFE,Y,DGZM0,DGZS0,DOB,L1,PT,SEX,AGE,CC,DAM,DOB,DXLS,EXP,NOR,NO,DRG,DRGCAL,DGZSUR,S1,SUR,M1,MOV,P,P1
68 K DGDX,DGER,DGI,DGINFO,DGLOS,DGNXD,DGP,DGPAS,DGPSV,DGTLOS,DGTY,DIS2,DGJUMP,DGPRD,DGPC,DGDRGNM,DGMOVM,DR,DGQWK,ST1,DGX,DQ,TY,DGRTY,DGRTY0,DGPTFMT,DG,DGA1,DGDC,DGNEXT,RC,DP,POP,DGICD0,DGPROCD,DGPROCI,DGPROCM,DGVAR,DGAD
69 K TAC,TRS,SD,PD,MDC,NDR,NSD,OR,ORG,T,DGZDIAG,DGZPRO,DGZSER,J1,I1,L2,L3,L4,L5,L6,PM,DGFC,S,M2,PROC,SU,ST,NL,DGDD,SD1,D,DFN,DFN1,DFN2,D0,P2,S2,X,DGNUM,DGN,DGERR,DGVI,DGVO,Z,Z1,DGZ,DGADM,DGNODE,^UTILITY($J),DGCFL
70 K DGPM2X,DGPMDA,DGPMDCD,DGPMVI,DGAMY,VAERR,VAIP,DGPTSCRN,DGREC,DGHOLD,DG300,DG300A,DG300B,DG701,DGBPC,DGPTIT,DGMOV,DGSUR
71 K M3,DGLAST,DGMVT
72 Q
73 ;
74ELIG ; shows eligibility and disabilities
75 D ELIG^VADPT W #,!,"Eligibility: "_$P(VAEL(1),"^",2)_$S(+VAEL(3):" SC%: "_$P(VAEL(3),"^",2),1:"")
76 W !,"Disabilities: " F I=0:0 S I=$O(^DPT(DFN,.372,I)) Q:'I S I1=$S($D(^DPT(DFN,.372,I,0)):^(0),1:"") D:+I1
77 .S PSDIS=$S($P($G(^DIC(31,+I1,0)),"^")]""&($P($G(^(0)),"^",4)']""):$P(^(0),"^"),$P($G(^DIC(31,+I1,0)),"^",4)]"":$P(^(0),"^",4),1:""),PSCNT=$P(I1,"^",2)
78 .W:$L(PSDIS_"-"_PSCNT_"% ("_$S($P(I1,"^",3):"SC",1:"NSC")_"), ")+$X>80 !,?15
79 .W $S($G(PSDIS)]"":PSDIS_"-",1:"")_PSCNT_"% ("_$S($P(I1,"^",3):"SC",1:"NSC")_"), "
80 .I $Y>22 W !,"PRESS RETURN TO CONTINUE:" R X:DTIME W #
81 Q
82DATE ;EDIT CPT DATE/TIME TO BE AFTER ADMISSION DATE BUT BEFORE DISCHARGE
83 I X<$P(^DGPT(DA(1),0),U,2) W !,"Not before admission" K X Q
84 I $G(^(70)),X>^(70) W !,"Not after discharge" K X Q
85 S I=0 F S I=$O(^DGPT(PTF,"C",I)) Q:I'>0 I X=+^(I,0) W !,"Cannot change to existing CPT date/time entry" K X Q
86 Q
87SETABX ;SET AB CROSSREFERENCE IN FILE 45
88 G KILLABX:$P($G(^DGPT(DA(1),"C",DA,0)),U,7)
89 N BOOL S (DGCPT,BOOL)=0
90 F S DGCPT=$O(^DGCPT(46,"C",DA(1),DGCPT)) Q:'DGCPT D Q:BOOL
91 .S BOOL='$G(^DGCPT(46,DGCPT,9))
92 I 'BOOL K ^DGPT("AB",$E(X,1,30),DA(1),DA)
93 S ^DGPT("AB",$E(X,1,30),DA(1),DA)="" Q
94KILLABX ;KILL AB CROSSREFERENCE IN FILE 45
95 G SETABX:'$P($G(^DGPT(DA(1),"C",DA,0)),U,7)
96 K ^DGPT("AB",$E(X,1,30),DA(1),DA) Q
97DISP F I=1:1:$P(DGZPRF,U,3) D
98 .S Y=+DGZPRF(I) D D^DGPTUTL W !,I,?5,Y
99 Q
100HELP W !,"Enter '^' to stop display and edit of data,"
101 W !,"'^N' to jump to screen #N (appears in upper right of screen as"
102 W " <N>),",!,"a number to jump to that number 801 screen,"
103 W " ?? to list the 801 screens,"
104 W !,"<RET> to continue on to next screen or A-B to edit:"
105 W !?10,"A-Professional service information",!,?10,"B-Procedure codes",!,"You may also enter any combination of the above, separated by commas (ex:A,B)",! Q
106CPT ;DISPLAY CPT CODES AND MODIFIERS
107 S CPT=+DGZPRF(J,K),N=$$CPT^ICPTCOD(CPT,$$GETDATE^ICDGTDRG(PTF)),N=$S(N>0:$P(N,U,2,99),1:"")
108 W $P(N,U)," ",$P(N,U,2)
109 F I=1,2 S MOD=$P(DGZPRF(J,K),U,I+1) D MOD:MOD
110 W !,?7,"Quantity: ",$P(DGZPRF(J,K),U,14) K I,MOD,N Q
111MOD S N=$$MOD^ICPTMOD(MOD,"I",$$GETDATE^ICDGTDRG(PTF)) W !,?7,"CPT Modifier ",I,":",$P(N,U,2)," ",$P(N,U,3)
112 Q
Note: See TracBrowser for help on using the repository browser.