source: WorldVistAEHR/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSPP.m@ 701

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

initial load of WorldVistAEHR

File size: 3.6 KB
Line 
1YSPP ;ALB/ASF-INQUIRY PATIENT ;3/27/90 14:48 ;07/30/93 13:05
2 ;;5.01;MENTAL HEALTH;;Dec 30, 1994
3 S YSFHDR="Identifying Data <<section 1>>" D ENHD^YSFORM S:'$D(DA)&($D(YSDFN)) DA=YSDFN,DFN=YSDFN D DEM^VADPT,PID^VADPT
4ENCN ;
5 F I=0,.11,.111,.13,.21,.211,.24,.15,.3,.311,.31,.321,.32,.33,.331,.34,.362,.36,.52,1010.15 S A(I)="" S:$D(^DPT(DA,I))#10 A(I)=^(I)
6 I $G(YSDFN)'>0 S YSDFN=+DA
7 ;
8ENCE ; Called indirectly from YSCEN31
9 ;
10 I $P(A(.15),U,2)?7N W !?20,"PATIENT LISTED AS INELIGIBLE",$C(7,7)
11 W:$P(A(0),U,10)]"" !,"REMARKS: ",$P(A(0),U,10)
12 W !?7,"ALIAS: " S I=0 F S I=$O(^DPT(DA,.01,I)) Q:'I W:$X>40 ! W ?15,$P(^(I,0),U),?40,"SSN: ",VA("PID")
13 W !!,"",?9,"SEX: ",$P(VADM(5),U,2),?40,"ADDRESS: " S X=.11,X1=1,X2=1 D MOVE W S(1)
14 W !,"MARITAL STAT: ",$P(VADM(10),U,2) W:$D(S("CC",.11)) ?39,S("CC",.11) W ?49,S(2)
15 W !," RELIGION: ",$P(VADM(9),U,2),?49,S(3)
16 W !?9,"POB: ",$P(A(0),U,11),$S($D(^DIC(5,+$P(A(0),U,12),0)):", "_$P(^(0),U,2),1:""),?49,$$ZIP4(+YSDFN,1,S(4)) S X=.111,X1=1,X2=1 D MOVE
17LEG ;
18 W !?3,"LEGAL ADD: ",S(1),?40,"PHONE 1: ",$P(A(.13),U),! W:$D(S("CC",.111)) ?4,S("CC",.111) W ?15,S(2),?40,"PHONE 2: ",$P(A(.13),U,2)
19 W !?15,S(3),?40,"PHONE 3: ",$P(A(.13),U,3),!?15,S(4) W:$P(A(.13),U,4)]"" ?40,"PHONE 4: ",$P(A(.13),U,4)
20EMER ;
21 W !?3,"EMER CONT: ",$P(A(.33),U),?40,"E2-CONT: ",$P(A(.331),U) S X=.33,X1=1,X2=3 D MOVE S X=.331,X1=5,X2=3 D MOVE
22 W !," RELATION: ",$P(A(.33),U,2),?39,"RELATION: ",$P(A(.331),U,2)
23 W !?14,S(1),?49,S(5),!?14,$$ZIP4(+YSDFN,4,S(2)),?49,$$ZIP4(+YSDFN,5,S(6)),!?14,S(3),?49,S(7),!?14,S(4),?49,S(8)
24 W !?7,"PHONE: ",$P(A(.33),U,9),?42,"PHONE: ",$P(A(.331),U,9)
25 K YSCC,YSST Q:$D(YSNOFORM) D WAIT1^YSUTL:'YST,ENFT^YSFORM:YST Q
26MOVE ;
27 S S(X1)=$P(A(X),U,X2),S(X1+1)=$P(A(X),U,X2+1),S(X1+2)=$P(A(X),U,X2+2),S(X1+3)=$P(A(X),U,X2+3)_$S($D(^DIC(5,+$P(A(X),U,X2+4),0)):", "_$P(^(0),U,2),1:"")_" "_$P(A(X),U,X2+5)
28 S:S(X1+2)="" S(X1+2)=S(X1+3),S(X1+3)="" S:S(X1+1)="" S(X1+1)=S(X1+2),S(X1+2)=S(X1+3),S(X1+3)="" S:S(X1)="" S(X1)=S(X1+1),S(X1+1)=S(X1+2),S(X1+2)=S(X1+3),S(X1+3)=""
29 I X=.11!(X=.111) S YSCC=+$P(A(X),U,7) I YSCC>0 S YSST=+$P(A(X),U,5) I YSST>0,$D(^DIC(5,YSST,1,YSCC,0)) S S("YSCC",X)=" YSCC: "_$P(^(0),U,3) K YSCC,YSST
30 Q
31 ;
32ZIP4(YSDFN,TYPE,OTHTXT) ; Returns the ZIP+4 data for the TYPE zip specified
33 N NODE,PIECE,YSI
34 ; TYPE:
35 ; 1=ZIP CODE, 2=K2-ZIP CODE, 3=EMPLOYER ZIP CODE,
36 ; 4=E-ZIP CODE, 5=E2-ZIP CODE, 6=D-ZIP CODE,
37 ; 7=K-ZC, 8=TEMPORARY ZIP CODE, 9=ZC or TEMP (if current)
38 ;
39 ; Other Text.. (At times "ARLINGTON, TX ZIP" will be passed)
40 ; If so, strip off Zip Code... print remainder (Ie., ARLINGTON, TX part ...
41 ; Let other code find and print proper zip code
42 I $G(OTHTXT)]"" D
43 . F YSI=$L(OTHTXT):-1 QUIT:$E(OTHTXT,YSI)'?1N
44 . S OTHTXT=$E(OTHTXT,1,YSI)
45 . W OTHTXT," "
46 K OTHTXT
47 ;
48 I $G(YSDFN)'>0!($G(TYPE)'?1N&(+$G(TYPE)>0)) QUIT "" ;->
49 ;
50 ; If TYPE=9 the Temporary zip code should be printed if it exists...
51 ; (This is TYPE 8)
52 ; If not, the Zip Code (TYPE 1) should be printed...
53 I +TYPE=9 D
54 . S TYPE=1 ;Assume Temporary address not existent... Reset later if is.
55 . S X=$G(^DPT(+YSDFN,.121)) ;Watch it! Using X on following lines...
56 . S X("SD")=$P(X,U,7),X("ED")=$P(X,U,8)
57 . I X("SD")<(DT+1)&(X("ED")>DT) S TYPE=8
58 ;
59 ; Set Old node and piece variables
60 S NODE("O")=$P(".11^.211^.311^.33^.331^.34^.21^.121",U,+TYPE)
61 S PIECE("O")=$P("6^8^8^8^8^8^8^6",U,+TYPE)
62 ;
63 ; Set New node and piece variables
64 S NODE("N")=$P(".11^.22^.22^.22^.22^.22^.22^.121",U,+TYPE)
65 S PIECE("N")=$P("12^3^5^1^4^2^7^12",U,+TYPE)
66 ;
67 ; Get NEW ZIP+4 and use it...
68 S X=$P($G(^DPT(+YSDFN,+NODE("N"))),U,+PIECE("N"))
69 ;
70 ; If NEW ZIP+$ not there, use old ZIP...
71 I X']"" S X=$P($G(^DPT(+YSDFN,+NODE("O"))),U,+PIECE("O"))
72 QUIT X
73 ;
Note: See TracBrowser for help on using the repository browser.