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

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

initial load of FOIAVistA 6/30/08 version

File size: 2.1 KB
Line 
1DGPTAPA2 ;ALB/MTC - PTF A/P ARCHIVE UTILITY CONT. ; 10-19-92
2 ;;5.3;Registration;;Aug 13, 1993
3 ;
4AR401 ;-- this function will load the 401 information
5 N X,X1,Y,I,J,K,OSEQ,SEQ
6 S OSEQ=$G(^DGP(45.62,DGTMP,100,0)) Q:OSEQ']""
7 S SEQ=$P(OSEQ,U,3),REF="^DGP(45.62,"_DGTMP_",100)"
8 ;
9 S (K,I)=0 F S I=$O(^DGPT(DGPTF,"S",I)) Q:'I D
10 . S K=K+1,SEQ=SEQ+1,X=$G(^DGPT(DGPTF,"S",I,0)) Q:X']""
11 .;-- surgery date (4)
12 . S Y=DGPTF_U_"401"_U_K_U_$S($P(X,U):$P(X,U),1:"")
13 .;-- sur specialty (5)
14 . S Y=Y_U_$S($P(X,U,3):$P($G(^DIC(45.3,$P(X,U,3),0)),U,2),1:"")
15 .;-- cat of chief sur (6)
16 . S Y=Y_U_$S($P(X,U,4):$P($P($P(^DD(45.01,4,0),U,3),";",$P(X,U,4)),":",2),$P(X,U,4)="V":"VA TEAM",$P(X,U,4)="M":"MIXED VA&NON VA",$P(X,U,4)="N":"NON VA",1:"")
17 .;-- cat of first ass (7), pric ana (8), source of pay (9)
18 . F J=5,6,7 S Y=Y_U_$S($P(X,U,J):$P($P($P(^DD(45.01,J,0),U,3),";",$P(X,U,J)),":",2),1:"")
19 .;
20 .;-- check for ICD codes (10-14)
21 . F J=8:1:12 D
22 .. S Y=Y_U_$S($P(X,U,J):$P(^ICD0($P(X,U,J),0),U),1:"")
23 .;
24 .;-- check for 300 node information (15)
25 . S X2=$G(^DGPT(DGPTF,"S",I,300))
26 . S Y=Y_U_$S($P(X2,U,2)=1:"Live Donor",$P(X2,U,2)=2:"Cadaver",1:"")
27 . S SEQ=SEQ+1,@REF@(SEQ,0)=Y
28 .;
29 .;-- 401P
30 .;-- ICD codes (4-9)
31 . S X3=$G(^DGPT(DGPTF,"401P")) I X3]"" D S @REF@(SEQ,0)=Y
32 .. S SEQ=SEQ+1,Y=DGPTF_U_"401P"_U_K F J=1:1:5 I $P(X3,U,J) D
33 ... S Y=Y_U_$P(^ICD0($P(X3,U,J),0),U)
34 .;
35 ;
36 ;-- update
37 S $P(^DGP(45.62,DGTMP,100,0),U,3,4)=SEQ_U_SEQ
38 Q
39 ;
40AR601 ;-- this function will load the 601 information
41 N X,Y,I,J,K,OSEQ,SEQ
42 S OSEQ=$G(^DGP(45.62,DGTMP,100,0)) Q:OSEQ']""
43 S SEQ=$P(OSEQ,U,3),REF="^DGP(45.62,"_DGTMP_",100)"
44 ;
45 S (K,I)=0 F S I=$O(^DGPT(DGPTF,"P",I)) Q:'I D
46 . S K=K+1,SEQ=SEQ+1,X=$G(^DGPT(DGPTF,"P",I,0)) Q:X']""
47 .;-- procedure date (4)
48 . S Y=DGPTF_U_"601"_U_K_U_$S($P(X,U):$P(X,U),1:"")
49 .;-- specialty (5)
50 . S Y=Y_U_$P($G(^DIC(42.4,+$P(X,U,2),0)),U,1)
51 .;-- dialysis type (6)
52 . S Y=Y_U_$P($G(^DG(45.4,+$P(X,U,3),0)),U)
53 .;-- # of treat (7)
54 . S Y=Y_U_+$P(X,U,4)
55 .;-- ICD codes (8-12)
56 . F J=5:1:9 D
57 .. S Y=Y_U_$S($P(X,U,J):$P(^ICD0($P(X,U,J),0),U),1:"")
58 . S @REF@(SEQ,0)=Y
59 ;
60 ;-- update
61 S $P(^DGP(45.62,DGTMP,100,0),U,3,4)=SEQ_U_SEQ
62 Q
63 ;
Note: See TracBrowser for help on using the repository browser.