source: WorldVistAEHR/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRUTIL.m

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

initial load of WorldVistAEHR

File size: 7.0 KB
Line 
1RMPRUTIL ;PHX/JLT,DLG,HPL,RVD-UTILITY PROGRAMS FOR PROSTHETICS ;10/19/1993
2 ;;3.0;PROSTHETICS;**12,28,30,44,41,55**;Feb 09, 1996
3 ;
4 ; ODJ - patch 55 - 1/29/01 - create extrinsic to return mail routing
5 ; code parameter. (see AUG-1097-32118)
6 ; RVD - patch 55 - 3/15/01 - initially set the value of 121 as the
7 ; mail routing symbol @ the post init.
8 ;
9GETPAT ;MAIN ENTRY POINT FOR PATIENT LOOKUPS
10 K RMPRDFN,RMPRSSN,RMPRSSNE,RMPRDOB
11 N DIC,Y,DLAYGO,VAHOW S DIC="^RMPR(665,",DIC(0)="AEMLQ",DLAYGO=665,DIC("A")="Select PROSTHETIC PATIENT: " D ^DIC K DIC,DLAYGO
12 Q:$G(Y)'>0
13 S:+Y>0 (RMPRDFN,DFN)=+Y D DEM^VADPT,ELIG^VADPT
14 ;set prosthetic variables
15 ;rmprssn is number nnnnnnnnn
16 ;rmprssne is external format of ssn nnn-nn-nnnn
17 S RMPRNAM=$P(VADM(1),U),RMPRSSN=$P(VADM(2),U)
18 S RMPRDOB=$P(VADM(3),U),RMPRSSNE=VA("PID")
19 S RMPRCNUM=VAEL(7)
20 I +VADM(6) S RMPRDOD=$P(VADM(6),U) W !!,$C(7),"PATIENT IS DECEASED. DATE OF DEATH WAS ",$P(VADM(6),U,2)
21 I $D(RMPRDOD) S DIR(0)="Y",DIR("A")="Would you Like to continue Processing this Patient",DIR("B")="NO" D ^DIR K DIR I +Y=0 K RMPRDFN
22 K RMPRDOD D KVAR^VADPT Q
23COMP ;LOOKUP FOR ADDRESS ON PATIENT 10-2319
24 S DFN=RMPRDFN,VAPA("P")="" D ADD^VADPT
25 S J=1 F I=1:1:3 S:VAPA(I)'="" XP(J)=VAPA(I),J=J+1
26 S XP(J)=$P(VAPA(4),U)_", "_$P(VAPA(5),U,2)_" "_$P(VAPA(6),U,1)
27 S:XP(J)=", " XP(J)="" S:XP(J)]"" J=J+1 S:XP(1)="" XP(J)="NO ADDRESS ON FILE",J=2
28 K VAPA S DFN=RMPRDFN D ADD^VADPT
29 S J1=1 F I=1:1:3 S:VAPA(I)'="" X1(J1)=VAPA(I),J1=J1+1
30 S X1(J1)=$P(VAPA(4),U)_", "_$P(VAPA(5),U,2)_" "_$P(VAPA(6),U)
31 S:X1(J1)=", " X1(J1)="" S:X1(1)="" X1(J1)="NO ADDRESS ON FILE" S J1=J1+1 Q
32EDT ;ENTER/EDIT 2421 AND NO-FORM
33 S HY=+Y I '$D(^RMPR(664,RMPRA,1)) S ^RMPR(664,RMPRA,1,0)="^664.02PA^0^0" G FILE
34 I $D(^RMPR(664,RMPRA,1,"B",+Y)) S DA=$O(^RMPR(664,RMPRA,1,"B",+Y,0)) G CHK
35FILE S Y=HY,NUM=$P(^RMPR(664,RMPRA,1,0),U,4)+1,$P(^(0),U,4)=NUM,$P(^(0),U,3)=$P(^(0),U,3)+1,^RMPR(664,RMPRA,1,NUM,0)=+Y,DA=NUM,^RMPR(664,RMPRA,1,"B",+Y,NUM)="" S NEW=1
36ENT K DR,DQ S DA(1)=RMPRA,DIE="^RMPR(664,"_RMPRA_",1," S DR=$S($D(NEW):"",1:".01;") K NEW I RMPRDR'["2421" G NFRM
37 S DR=DR_"16;8////^S X=$G(RMTYPE);9////^S X=$G(RMCAT);10////^S X=$G(RMSPE);1R~BRIEF DESCRIPTION OF ITEM (for Vendor);"
38 S DR=DR_"14;3;2;4R;11////C;7REMARKS (2319 and 1358)"
39 ;S DR=DR_"16;8;9;S RMPRDIS=+$P(^RMPR(664,DA(1),1,DA,0),U,10);S Y=$S(RMPRDIS=4:""@1"",1:""@2"");@2;1R~BRIEF DESCRIPTION OF ITEM (for Vendor);"
40 ;S DR=DR_"14EXTENDED DESCRIPTION;3QTY;2;4R~UNIT OF ISSUE;11////C;7REMARKS (2319 and 1358);S Y="""";@1;10SPECIAL CATEGORY;S Y=""@2"""
41 D ^DIE Q:$D(DTOUT) K NUM,DA,NEW,Y,DR Q
42NFRM ;S DR=DR_"16;8TYPE OF TRANSACTION;9PATIENT CATEGORY;S RMPRDIS=+$P(^RMPR(664,DA(1),1,DA,0),U,10);S Y=$S(RMPRDIS=4:""@1"",1:""@2"");@2;3QTY;2;4UNIT OF ISSUE;11////C;"
43 ;S DR=DR_"7REMARKS (2319 and 1358);S Y="""";@1;10SPECIAL CATEGORY;S Y=""@2"";"
44 S DR=DR_"16;8////^S X=$G(RMTYPE);9////^S X=$G(RMCAT);10////^S X=$G(RMSPE);3QTY;2;4UNIT OF ISSUE;11////C;"
45 S DR=DR_"7REMARKS (2319 and 1358)"
46 D ^DIE K NUM,DA,NEW,Y,DR Q
47TMC ;GET HOURS AND MINUTES BETWEEN START AND CLOSE DATES
48 S RB="."_$P(RMPRDATE,".",2)*100,RA="."_$P(RMPRCD,".",2)*100
49 S RC=RA-RB I '$P(RB,".",2) S RC=$P(RC,".")_"."_$S($L($P(RA,".",2))=1:$P(RA,".",2)_"0",1:$P(RA,".",2)) G TXT
50 S RH=$P(RC,"."),RM="."_$P(RC,".",2) S:RM>.60 RM=(.60)-(1-RM) S RC=RH_$S($L(RM)=2:RM_"0",1:RM)
51TXT Q:$D(RMPRGEC) S RC=$S($P(RC,"."):+$P(RC,".")_" Hr "_+$P(RC,".",2)_" Min ",1:+$P(RC,".",2)_" Min ") Q
52CHK ;ASK TO ADD DUPLICATE TO 2421 AND NO FORM
53 K DIR,Y S DIR(0)="S^Y:YES;N:NO",DIR("A")="DO YOU WANT TO ADD A DUPLICATE ITEM?",DIR("B")="NO" D ^DIR Q:$D(DIRUT)!($D(DTOUT)) I X["Y"!(X["y") G FILE
54 S RD=0 F RDA=0:0 S RDA=$O(^RMPR(664,RMPRA,1,"B",HY,RDA)) Q:RDA'>0 S RD=RD+1
55LKP ;DISPLAY DUPLICATE AND SINGLE ITEMS ON 2421 AND NO FORM
56 I RD>1 D Q:$D(DIRUT)!$D(DTOUT) I '$D(RD(+Y)) W $C(7) G LKP
57 .F RDA=0:0 S RDA=$O(^RMPR(664,RMPRA,1,"B",HY,RDA)) Q:RDA'>0 S RD(RDA)=^RMPR(664,RMPRA,1,RDA,0) W !?5,RDA,?10,$P(^PRC(441,$P(^RMPR(661,$P(RD(RDA),U),0),U),0),U,2)," $",$P(RD(RDA),U,3)
58 .K DIR,Y S DIR(0)="N" D ^DIR I +Y S DA=+Y
59 G ENT
60STA() ;CONVERTS RMPR("STA") INTO EXTERNAL FORMAT
61 N STAE I '$D(RMPRSITE)!'($D(RMPR)) D ^RMPRSIT
62 S STAE=$S($D(^DIC(4,RMPR("STA"),99)):$P(^(99),U),1:RMPR("STA"))
63 Q STAE
64ROU(RMPRSITE) ;Return mail routing code for a site
65 N RMPRSYM
66 S RMPRSYM=""
67 I $G(RMPRSITE)="" G ROUX
68 S RMPRSYM=$P($G(^RMPR(669.9,RMPRSITE,0)),"^",13)
69ROUX Q RMPRSYM
70STATN(RSTA) ;CONVERT POINTER TO STATION TO NAME OF STATION
71 ;VARIABLE PASSED IN: RSTA - POINTER TO STATION IN FILE 4
72 ;VARIABLE PASSED OUT:RSTATION - NAME OF STATION
73 Q:$G(RSTA)'>0 ""
74 N RSTATION
75 S RSTATION=$S($D(^DIC(4,RSTA,99)):$P(^(99),U,1),1:RSTA)
76 Q RSTATION
77 ;
78DIC660 ;REVERSE DIC LOOK UP FOR 660.
79 K ^TMP($J),RMIEN W ! S DIC="^RMPR(665,",DIC(0)="AEMQZ",DIC("A")="Select PATIENT: "
80 D ^DIC G:+Y'>0!($D(DTOUT)) EXIT
81REV ; Added for reverse look-up..
82 S I=0 F S I=$O(^RMPR(660,"C",+Y,I)) Q:I'>0 I $D(^RMPR(660,I,0)) S:$P(^(0),U,6)!($P(^(0),U,26)'="") ^TMP($J,9999999-$P($G(^RMPR(660,I,0)),U,1),I)=I
83LST S (I,RMI,RMQUIT,RMSEL,RMIEN)=0 W !,"CHOOSE FROM:"
84 F S I=$O(^TMP($J,I)) Q:I'>0!(RMQUIT)!(RMSEL)!(RMIEN) S J=0 F S J=$O(^TMP($J,I,J)) Q:J'>0 S RMI=RMI+1,^TMP($J,RMI)=I_"^"_J D WRI I '(RMI#17) D DIS Q:(RMSEL)!(RMQUIT)!(RMIEN)
85 G:RMSEL LST G:RMIEN PROC I 'RMI W !!,"***PATIENT HAS NO 2319 RECORD!!!!" G EXIT
86 I RMQUIT W !!,"***** NO SELECTION MADE!!!" G EXIT
87 W !!,"[<RETURN> or '^' to Quit] or Choose Number 1-",RMI W ": " R X:DTIME I '$T G EXIT
88 I X=""!(X="^")!('$D(X)) W !!,"***** NO SELECTION MADE!!!" G EXIT
89 I '$D(^TMP($J,+X)) W !,$C(7),"****INVALID RESPONSE, Please choose a NUMBER within the range!!!!",! G LST
90 S RMIEN=$P(^TMP($J,+X),U,2)
91PROC S Y=+RMIEN,RO=$G(^RMPR(660,+Y,0)),Y=$P(^(0),U,1),RMDFN=0 S:$P(RO,U,2) RMDFN=$P(RO,U,2) X ^DD("DD")
92 W " ",Y," ",$S(RMDFN:$E($P(^DPT(RMDFN,0),U,1),1,20),1:"")," $",$J($P(RO,U,16),0,2)
93EXIT K DIC,DIE,DIR,%,X,RMI,RMIT,RMSEL,RMQUIT,RMDFN,RO,Y,^TMP($J) Q
94WRI ;WRITE REVERSE LISTING
95 S (RMIT,RMDFN)=0 S RO=$G(^RMPR(660,J,0)),Y=$P(^(0),U,1) X ^DD("DD") S:$P(RO,U,6) RMIT=$P(^RMPR(661,$P(RO,U,6),0),U,1) S:$P(RO,U,2) RMDFN=$P(RO,U,2)
96 W !,$J(RMI,4),"> ",Y,?20,$S(RMDFN:$E($P($G(^DPT(RMDFN,0)),U,1),1,20),1:"")
97 I $P(RO,U,26)'="" W ?41,$S($P(RO,U,26)="P":"SHIPPING",$P(RO,U,26)="D":"DELIVERY",1:"SHIPPING")
98 E W ?41,$S(RMIT:$E($P($G(^PRC(441,RMIT,0)),U,2),1,25),1:"")
99 W ?68,"$",$J($P(RO,U,16),0,2) Q
100DIS W !!,"<RETURN> to Continue, '^' to Quit or Choose Number 1-",RMI W ": " R X:DTIME I '$T S RMQUIT=1 Q
101 Q:X=""!(X=" ") I X="^" S RMQUIT=1 Q
102 I '$D(^TMP($J,+X)) W !,$C(7),"*****INVALID RESPONSE, Please choose a NUMBER within the range!!!!" S RMSEL=1 Q
103 S RMIEN=$P(^TMP($J,+X),U,2) Q
104 ;
105KILLG ;kill & set 'G' cross reference in 660.
106 S RMPRBE=$P(^RMPR(660,DA,0),U,22)
107 K ^RMPR(660,"G",RMPRBE,DA)
108 S $P(^RMPR(660,DA,0),U,22)=$P(^RMPR(661.1,X,0),U,4),RMPRX=X
109 S DIK=DIE,DIK(1)="4.1^G" D IX^DIK S X=RMPRX K RMPRX,RMPRBE,RMPRDA
110 Q
111 ;
112121 ;set 121 as the mail routing symbol.
113 N RMII,RMIIDAT,DIE
114 S DIE="^RMPR(669.9,",DR="34///^S X=121"
115 F RMII=0:0 S RMII=$O(^RMPR(669.9,RMII)) Q:RMII'>0 S RMIIDAT=$G(^RMPR(699.9,RMII,0)) I $D(RMIIDAT) S DA=RMII D ^DIE
116 Q
Note: See TracBrowser for help on using the repository browser.