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

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

initial load of WorldVistAEHR

File size: 1.7 KB
RevLine 
[613]1DGPTAPA3 ;ALB/MTC - PTF A/P ARCHIVE UTILITY CONT. ; 10-19-92
2 ;;5.3;Registration;;Aug 13, 1993
3 ;
4AR501 ;-- this function will load the 501 information
5 N X,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,"M",I)) Q:'I D
10 . S K=K+1,SEQ=SEQ+1,X=$G(^DGPT(DGPTF,"M",I,0)) Q:X']""
11 .;-- movement date (4)
12 . S Y=DGPTF_U_"501"_U_K_U_$S($P(X,U,10):$P(X,U,10),1:"")
13 .;-- treated for and SC condition (5)
14 . S Y=Y_U_$S($P(X,U,18)=1:"YES",1:"NO")
15 .;-- leave days (6)
16 . S Y=Y_U_$S($P(X,U,3):$P(X,U,3),1:"")
17 .;-- pass days (7)
18 . S Y=Y_U_$S($P(X,U,4):$P(X,U,4),1:"")
19 .;-- losing specilaty (8)
20 . S Y=Y_U_$S($P(X,U,2):$P(^DIC(42.4,$P(X,U,2),0),U),1:"")
21 .;
22 .;-- check for ICD codes (9-18)
23 . F J=5:1:9,11:1:15 D
24 .. S Y=Y_U_$S($P(X,U,J):$P(^ICD9($P(X,U,J),0),U),1:"")
25 .;
26 .;-- check for 300 node information (19-24)
27 .;
28 . S X2=$G(^DGPT(DGPTF,"M",I,300))
29 . S Y=Y_U_$$AR300^DGPTAPA1(X2)
30 . S SEQ=SEQ+1,@REF@(SEQ,0)=Y
31 ;-- update
32 S $P(^DGP(45.62,DGTMP,100,0),U,3,4)=SEQ_U_SEQ
33 Q
34 ;
35AR535 ;-- this function will load the 535 information
36 N Y,X,I,DG535,OSEQ,SEQ
37 S OSEQ=$G(^DGP(45.62,DGTMP,100,0)) Q:OSEQ']""
38 S SEQ=$P(OSEQ,U,3),REF="^DGP(45.62,"_DGTMP_",100)"
39 ;
40 S (I,DG535)=0 F S DG535=$O(^DGPT(DGPTF,535,DG535)) Q:'DG535 D
41 . S I=I+1,SEQ=SEQ+1,X=$G(^DGPT(DGPTF,535,DG535,0)),X1=""
42 .;-- physical movement # (4)
43 . S Y=DGPTF_U_"535"_U_I_U_$S($P(X,U,10):$P(X,U,10),1:"")
44 .;-- losing specialty (5)
45 . S Y=Y_U_$P(^DIC(42.4,$P(X,U,2),0),U,1)
46 .;-- leave days (6)
47 . S Y=Y_U_$P(X,U,3)
48 .;-- pass days (7)
49 . S Y=Y_U_$P(X,U,4)
50 .; losing ward (8)
51 . S Y=Y_U_$P(^DIC(42,$P(X,U,6),0),U)
52 . S @REF@(SEQ,0)=Y
53 ;-- update
54 S $P(^DGP(45.62,DGTMP,100,0),U,3,4)=SEQ_U_SEQ
55 Q
56 ;
Note: See TracBrowser for help on using the repository browser.