| 1 | DGPTUTL1 ;ALB/MJK - PTF Utility ;2/1/05 2:20pm
|
|---|
| 2 | ;;5.3;Registration;**33,45,54,517,635**;Aug 13, 1993
|
|---|
| 3 | ;
|
|---|
| 4 | FLAG ; -- 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)
|
|---|
| 9 | FLAGQ K DGMAX,DGT,DGADM,DGX,DGA1,DGA,DGMTY,C,DGOUT Q
|
|---|
| 10 | ;
|
|---|
| 11 | UP ; -- 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
|
|---|
| 18 | UPQ K DIE,DR Q
|
|---|
| 19 | ;
|
|---|
| 20 | CHK ;
|
|---|
| 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 | ;
|
|---|
| 25 | INCOME ;-- 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
|
|---|
| 33 | INQ ;
|
|---|
| 34 | K DGX,DGINCM,DIE,DA,DR,DGI,DG30,DG362,DGT,%
|
|---|
| 35 | Q
|
|---|
| 36 | ;
|
|---|
| 37 | INC ;-- 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
|
|---|
| 42 | INCQ Q
|
|---|
| 43 | ;
|
|---|
| 44 | CHQUES ;-- 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 | ;
|
|---|
| 54 | SETTRAN ;-- 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
|
|---|
| 63 | SETQ ;
|
|---|
| 64 | Q
|
|---|
| 65 | ;
|
|---|
| 66 | KVAR ; -- 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 | ;
|
|---|
| 74 | ELIG ; 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
|
|---|
| 82 | DATE ;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
|
|---|
| 87 | SETABX ;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
|
|---|
| 94 | KILLABX ;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
|
|---|
| 97 | DISP F I=1:1:$P(DGZPRF,U,3) D
|
|---|
| 98 | .S Y=+DGZPRF(I) D D^DGPTUTL W !,I,?5,Y
|
|---|
| 99 | Q
|
|---|
| 100 | HELP 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
|
|---|
| 106 | CPT ;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
|
|---|
| 111 | MOD S N=$$MOD^ICPTMOD(MOD,"I",$$GETDATE^ICDGTDRG(PTF)) W !,?7,"CPT Modifier ",I,":",$P(N,U,2)," ",$P(N,U,3)
|
|---|
| 112 | Q
|
|---|
