113 lines
4.9 KiB
Mathematica
113 lines
4.9 KiB
Mathematica
DGPTUTL1 ;ALB/MJK - PTF Utility ;2/1/05 2:20pm
|
|
;;5.3;Registration;**33,45,54,517,635**;Aug 13, 1993
|
|
;
|
|
FLAG ; -- select PTF rec to update xmit flags
|
|
S DGMAX=25
|
|
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"
|
|
D ^DIC K DIC G FLAGQ:+Y<0 S (Y,PTF)=+Y D CHK
|
|
F DGMTY=501,535 I $D(DGMTY(DGMTY)) D UP Q:$D(DGOUT)
|
|
FLAGQ K DGMAX,DGT,DGADM,DGX,DGA1,DGA,DGMTY,C,DGOUT Q
|
|
;
|
|
UP ; -- select mvt and update xmit flag
|
|
I DGMTY=501 S DIC="^DGPT("_PTF_",""M"",",DIC("S")="I Y'=1,'$D(^(""P""))"
|
|
I DGMTY=535 S DIC="^DGPT("_PTF_",535,",DIC("S")="I Y'=1"
|
|
W ! S DIC(0)="AEMQ" D ^DIC S DIE=DIC K DIC
|
|
K DGOUT I X["^" S DGOUT=""
|
|
I +Y<0 G UPQ
|
|
S DA=+Y,DR=17 D ^DIE K DE,DQ G UP
|
|
UPQ K DIE,DR Q
|
|
;
|
|
CHK ;
|
|
N T1,T2,C K DGMTY S T1=0,T2=9999999
|
|
F DGMTY=501,535 D 501^DGPTFVC2:DGMTY=501,535^DGPTFVC2:DGMTY=535 S:C>DGMAX DGMTY(DGMTY)=""
|
|
Q
|
|
;
|
|
INCOME ;-- load ptf income information
|
|
; Use discharge date if available; else use current date/time
|
|
D NOW^%DTC
|
|
S X=$S($D(^DGPT(PTF,70)):+^(70),1:%),DGX=$S($D(^DGPT(PTF,101)):^(101),1:"")
|
|
D INC
|
|
G INQ:Y=$P(DGX,U,7)
|
|
S DIE="^DGPT(",DA=PTF,DR="101.07////"_Y
|
|
D ^DIE
|
|
INQ ;
|
|
K DGX,DGINCM,DIE,DA,DR,DGI,DG30,DG362,DGT,%
|
|
Q
|
|
;
|
|
INC ;-- load income information Input:X date,Output:Y-income
|
|
N DGINCM,DGI,DG30,DG362,DGT,DGX
|
|
I '$D(X) S Y="" G INCQ
|
|
S Y=+$P($$INCOME^VAFMON(DFN,X),".")
|
|
I Y<0 S Y=0
|
|
INCQ Q
|
|
;
|
|
CHQUES ;-- This function will deterime if the patient has any of the following
|
|
; indicated : AO, IR and EC. If so the array DGEXQ will contain
|
|
; DGEXQ(1)="" - AO
|
|
; DGEXQ(2)="" - IR
|
|
; DGEXQ(3)="" - EC
|
|
; Otherwise they will be undefined.
|
|
K DGEXQ
|
|
S DGEXQ(1)="",DGEXQ(2)="",DGEXQ(3)=""
|
|
Q
|
|
;
|
|
SETTRAN ;-- set transmission if error DGOUT=1, will return XMZ
|
|
K DGXMZ
|
|
S DGOUTX=0
|
|
S Y=$S($P(DGD,".",2)=99:DGSD,1:DGD) X ^DD("DD")
|
|
S XMSUB=Y_" "_$P(DGRTY0,U)_" TRANSMISSION ",XMDUZ=.5
|
|
D GET^XMA2
|
|
I $D(XMZ),XMZ>0 S DGXMZ=XMZ K XMZ G SETQ
|
|
W !!,"*** ERROR *** Unable to create Mail Message #... Try again later."
|
|
S DGOUTX=1
|
|
SETQ ;
|
|
Q
|
|
;
|
|
KVAR ; -- clean up for l/e
|
|
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
|
|
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
|
|
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
|
|
K DGPM2X,DGPMDA,DGPMDCD,DGPMVI,DGAMY,VAERR,VAIP,DGPTSCRN,DGREC,DGHOLD,DG300,DG300A,DG300B,DG701,DGBPC,DGPTIT,DGMOV,DGSUR
|
|
K M3,DGLAST,DGMVT
|
|
Q
|
|
;
|
|
ELIG ; shows eligibility and disabilities
|
|
D ELIG^VADPT W #,!,"Eligibility: "_$P(VAEL(1),"^",2)_$S(+VAEL(3):" SC%: "_$P(VAEL(3),"^",2),1:"")
|
|
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
|
|
.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)
|
|
.W:$L(PSDIS_"-"_PSCNT_"% ("_$S($P(I1,"^",3):"SC",1:"NSC")_"), ")+$X>80 !,?15
|
|
.W $S($G(PSDIS)]"":PSDIS_"-",1:"")_PSCNT_"% ("_$S($P(I1,"^",3):"SC",1:"NSC")_"), "
|
|
.I $Y>22 W !,"PRESS RETURN TO CONTINUE:" R X:DTIME W #
|
|
Q
|
|
DATE ;EDIT CPT DATE/TIME TO BE AFTER ADMISSION DATE BUT BEFORE DISCHARGE
|
|
I X<$P(^DGPT(DA(1),0),U,2) W !,"Not before admission" K X Q
|
|
I $G(^(70)),X>^(70) W !,"Not after discharge" K X Q
|
|
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
|
|
Q
|
|
SETABX ;SET AB CROSSREFERENCE IN FILE 45
|
|
G KILLABX:$P($G(^DGPT(DA(1),"C",DA,0)),U,7)
|
|
N BOOL S (DGCPT,BOOL)=0
|
|
F S DGCPT=$O(^DGCPT(46,"C",DA(1),DGCPT)) Q:'DGCPT D Q:BOOL
|
|
.S BOOL='$G(^DGCPT(46,DGCPT,9))
|
|
I 'BOOL K ^DGPT("AB",$E(X,1,30),DA(1),DA)
|
|
S ^DGPT("AB",$E(X,1,30),DA(1),DA)="" Q
|
|
KILLABX ;KILL AB CROSSREFERENCE IN FILE 45
|
|
G SETABX:'$P($G(^DGPT(DA(1),"C",DA,0)),U,7)
|
|
K ^DGPT("AB",$E(X,1,30),DA(1),DA) Q
|
|
DISP F I=1:1:$P(DGZPRF,U,3) D
|
|
.S Y=+DGZPRF(I) D D^DGPTUTL W !,I,?5,Y
|
|
Q
|
|
HELP W !,"Enter '^' to stop display and edit of data,"
|
|
W !,"'^N' to jump to screen #N (appears in upper right of screen as"
|
|
W " <N>),",!,"a number to jump to that number 801 screen,"
|
|
W " ?? to list the 801 screens,"
|
|
W !,"<RET> to continue on to next screen or A-B to edit:"
|
|
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
|
|
CPT ;DISPLAY CPT CODES AND MODIFIERS
|
|
S CPT=+DGZPRF(J,K),N=$$CPT^ICPTCOD(CPT,$$GETDATE^ICDGTDRG(PTF)),N=$S(N>0:$P(N,U,2,99),1:"")
|
|
W $P(N,U)," ",$P(N,U,2)
|
|
F I=1,2 S MOD=$P(DGZPRF(J,K),U,I+1) D MOD:MOD
|
|
W !,?7,"Quantity: ",$P(DGZPRF(J,K),U,14) K I,MOD,N Q
|
|
MOD S N=$$MOD^ICPTMOD(MOD,"I",$$GETDATE^ICDGTDRG(PTF)) W !,?7,"CPT Modifier ",I,":",$P(N,U,2)," ",$P(N,U,3)
|
|
Q
|