source: FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IB20PT86.m@ 1757

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

initial load of FOIAVistA 6/30/08 version

File size: 3.4 KB
Line 
1IB20PT86 ;ALB/CPM - EXPORT ROUTINE 'DGPTUTL' ; 14-FEB-94
2 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
3 ;
4DGPTUTL ;ALB/AS - PTF UTILITY ROUTINE ; 12/13/89@8
5 ;;5.3;Registration;**26**;Aug 13, 1993
6D I $L(Y)'<7 S %=$E(Y,4,5)*3,Y=$E("JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC",%-2,%)_" "_$S($E(Y,6,7):$J(+$E(Y,6,7),2)_",",1:"")_($E(Y,1,3)+1700)_$S(Y[".":" "_$E(Y_0,9,10)_":"_$E(Y_"000",11,12),1:"") Q
7 S Y="" Q
8PM ;sets variables from ^DGPM global
9 S DGPMCA=$O(^DGPM("APTF",PTF,0)),DGPMAN=$S($D(^DGPM(+DGPMCA,0)):^(0),1:"") Q
10MT ;Determine and store Means Test Indicator
11 S DGZEC=$S($D(^DPT(DFN,.36)):$P(^(.36),U,1),1:""),DGZEC=$S($D(^DIC(8,+DGZEC,0)):^(0),1:"") I $P(DGZEC,U,5)="N" S DGX="N" G DIE
12 I DGADM<2860701 S DGX="X" G DIE
13 I $D(^DGPT(PTF,101)),$D(^DIC(45.1,+^(101),0)),$P(^(0),"^",4) S DGX="X" G DIE
14 I $P(^DG(43,1,0),U,21),DGADM]"",$D(^DIC(42,+$P(DGPMAN,U,6),0)),$P(^(0),U,3)="D" S DGX="X" G DIE
15 S DGT=$P($G(^DGPT(PTF,70)),"."),DGZ1=$$LST^DGMTU(DFN,DGT) G AS:'DGZ1
16 S DGX=$S('$D(DGZ1):"U",1:$P(DGZ1,U,4)),DGX=$S(DGX="A":"AN","BN"[DGX:DGX,"CP"[DGX:"C",1:"U") G DIE:DGX'="N"
17AS S DGZ=$S($D(^DPT(DFN,.321)):^(.321),1:0) I $P(DGZ,U,2)="Y"!($P(DGZ,U,3)="Y") S DGX="AS" G DIE
18 I $P(DGZEC,U,5)="Y",$P(DGZEC,U,4)<4,"^2^15^"'[(U_$P(DGZEC,U,9)_U) S DGX="AS" G DIE
19 I DGZEC]"" S DGX="AN" G DIE
20 S DGX="U" I '$D(DGLN) W !,"===> this patient has a blank Eligibility Code"
21DIE I '$D(DGBGJ) S DA=PTF,DR="10///"_DGX_$S('$P(^DGPT(PTF,0),U,3):";3///`"_$P($$SITE^VASITE,U),1:""),DIE="^DGPT(" D ^DIE K DGZEC,DGZ,DGZ1,DG1,DGX,DR,DGT,DA,DIE Q
22 I DGX'=$P(^DGPT(PTF,0),"^",10) S DA=PTF,DR="10///"_DGX,DIE="^DGPT(" D ^DIE
23 K DGZEC,DGZ,DGZ1,DG1,DGX,DGT,DR,DA,DIE Q
24 ;
25RTY ; -- set rec type variables
26 ; input: Y := rec type #
27 ; output: DGRTY := rec type #
28 ; DGRTY0 := name of type (in future, may expand to 0th node)
29 ;
30 I Y=1 S DGRTY=1,DGRTY0="PTF"
31 I Y=2 S DGRTY=2,DGRTY0="CENSUS"
32 Q
33 ;
34HANG ;
35 R DGPTHANG:4 K DGPTHANG Q
36 ;
37CEN ; -- find current active census ; return ifn and 0th node
38 S DGCN=$O(^DG(45.86,"AC",1,0)),DGCN0=$S($D(^DG(45.86,+DGCN,0)):^(0),1:"")
39 Q
40 ;
41FMT ; -- determime PTF record format
42 ;
43 S Z=$S(Y:Y,1:DT)
44 S DGPTFMT=1 D FDT
45 I Z>Y S DGPTFMT=2
46 K Z
47 Q
48 ;
49FDT ; -- set new format date for testing
50 S Y=2901000 Q
51 ;
52UPDT ; -- update PTF record w/PTF and DFN defined
53 I '$D(^DGPT(PTF,0)) W:'$D(ZTQUEUED) !!,*7,">>> PTF record #",PTF," does not exist." G UPDTQ
54 S X=^(0)
55 I $P(X,U,11)>1 W:'$D(ZTQUEUED) !!,*7,">>> Record #",PTF," is not a PTF record." G UPDTQ
56 S DGPTFE=$P(X,U,4),(DGADM,AD)=+$P(X,U,2),DGST=$D(^DGP(45.84,PTF))>0
57 I DGST W:'$D(ZTQUEUED) !!,*7,">>> PTF record #",PTF," is closed out. No updating allowed." G UPDTQ
58 I DGPTFE W:'$D(ZTQUEUED) !!,*7,">>> PTF record #",PTF," is a fee PTF record. No updating is possible." G UPDTQ
59 N DGPMCA,DGPMAN D PM
60 I DGPMCA D:'$P(^DGPT(PTF,0),U,5) SUF^DGPTF D LE^DGPTTS,DC^DGPTF
61 ;
62UPDTQ K AGE,D0,D1,DA,DGADM,DGLAST,DGP,DGTY,DIC,DIE,DR,DIV,DIU,DISYS,DIK,DIKLM,DIG,DIH,DI,DIW,DIWL,DIWR,DIWT,DN,DOB,DQ,DG,DRG,SEX,TY,L,P1,DIS2,DGPTFE,DGST,DGX,DFN1,DFN2,PR,I1,TDD,AD
63 Q
64 ;
65EXPL ; -- explode string A(input) to DGA(output)
66 N J,L S DGA=$E(A,2,999)
67 I DGA["-" S X=DGA,DGA="" F J=1:1 S L=$P(X,",",J) Q:'L D EXPL1:L["-" S:L]"" DGA=DGA_L_"," Q:$P(X,",",J+1,999)=""
68 Q
69 ;
70EXPL1 ; -- explode string 'L' of form "1-12" ; input and output is 'L'
71 N I,X
72 I $P(L,"-")'?1N.N!($P(L,"-",2,999)'?1N.N) S L="" G EXPL1Q
73 I +L>$P(L,"-",2) S L="" G EXPL1Q
74 I +L=+$P(L,"-",2) S L=+L G EXPL1Q
75 S X="" F I=+L:1:+$P(L,"-",2) Q:($L(X)+$L(I)+1)>240 S X=X_I_","
76 S L=$E(X,1,$L(X)-1)
77EXPL1Q Q
Note: See TracBrowser for help on using the repository browser.