117 lines
7.0 KiB
Mathematica
117 lines
7.0 KiB
Mathematica
RMPRUTIL ;PHX/JLT,DLG,HPL,RVD-UTILITY PROGRAMS FOR PROSTHETICS ;10/19/1993
|
|
;;3.0;PROSTHETICS;**12,28,30,44,41,55**;Feb 09, 1996
|
|
;
|
|
; ODJ - patch 55 - 1/29/01 - create extrinsic to return mail routing
|
|
; code parameter. (see AUG-1097-32118)
|
|
; RVD - patch 55 - 3/15/01 - initially set the value of 121 as the
|
|
; mail routing symbol @ the post init.
|
|
;
|
|
GETPAT ;MAIN ENTRY POINT FOR PATIENT LOOKUPS
|
|
K RMPRDFN,RMPRSSN,RMPRSSNE,RMPRDOB
|
|
N DIC,Y,DLAYGO,VAHOW S DIC="^RMPR(665,",DIC(0)="AEMLQ",DLAYGO=665,DIC("A")="Select PROSTHETIC PATIENT: " D ^DIC K DIC,DLAYGO
|
|
Q:$G(Y)'>0
|
|
S:+Y>0 (RMPRDFN,DFN)=+Y D DEM^VADPT,ELIG^VADPT
|
|
;set prosthetic variables
|
|
;rmprssn is number nnnnnnnnn
|
|
;rmprssne is external format of ssn nnn-nn-nnnn
|
|
S RMPRNAM=$P(VADM(1),U),RMPRSSN=$P(VADM(2),U)
|
|
S RMPRDOB=$P(VADM(3),U),RMPRSSNE=VA("PID")
|
|
S RMPRCNUM=VAEL(7)
|
|
I +VADM(6) S RMPRDOD=$P(VADM(6),U) W !!,$C(7),"PATIENT IS DECEASED. DATE OF DEATH WAS ",$P(VADM(6),U,2)
|
|
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
|
|
K RMPRDOD D KVAR^VADPT Q
|
|
COMP ;LOOKUP FOR ADDRESS ON PATIENT 10-2319
|
|
S DFN=RMPRDFN,VAPA("P")="" D ADD^VADPT
|
|
S J=1 F I=1:1:3 S:VAPA(I)'="" XP(J)=VAPA(I),J=J+1
|
|
S XP(J)=$P(VAPA(4),U)_", "_$P(VAPA(5),U,2)_" "_$P(VAPA(6),U,1)
|
|
S:XP(J)=", " XP(J)="" S:XP(J)]"" J=J+1 S:XP(1)="" XP(J)="NO ADDRESS ON FILE",J=2
|
|
K VAPA S DFN=RMPRDFN D ADD^VADPT
|
|
S J1=1 F I=1:1:3 S:VAPA(I)'="" X1(J1)=VAPA(I),J1=J1+1
|
|
S X1(J1)=$P(VAPA(4),U)_", "_$P(VAPA(5),U,2)_" "_$P(VAPA(6),U)
|
|
S:X1(J1)=", " X1(J1)="" S:X1(1)="" X1(J1)="NO ADDRESS ON FILE" S J1=J1+1 Q
|
|
EDT ;ENTER/EDIT 2421 AND NO-FORM
|
|
S HY=+Y I '$D(^RMPR(664,RMPRA,1)) S ^RMPR(664,RMPRA,1,0)="^664.02PA^0^0" G FILE
|
|
I $D(^RMPR(664,RMPRA,1,"B",+Y)) S DA=$O(^RMPR(664,RMPRA,1,"B",+Y,0)) G CHK
|
|
FILE 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
|
|
ENT 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
|
|
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);"
|
|
S DR=DR_"14;3;2;4R;11////C;7REMARKS (2319 and 1358)"
|
|
;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);"
|
|
;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"""
|
|
D ^DIE Q:$D(DTOUT) K NUM,DA,NEW,Y,DR Q
|
|
NFRM ;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;"
|
|
;S DR=DR_"7REMARKS (2319 and 1358);S Y="""";@1;10SPECIAL CATEGORY;S Y=""@2"";"
|
|
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;"
|
|
S DR=DR_"7REMARKS (2319 and 1358)"
|
|
D ^DIE K NUM,DA,NEW,Y,DR Q
|
|
TMC ;GET HOURS AND MINUTES BETWEEN START AND CLOSE DATES
|
|
S RB="."_$P(RMPRDATE,".",2)*100,RA="."_$P(RMPRCD,".",2)*100
|
|
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
|
|
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)
|
|
TXT Q:$D(RMPRGEC) S RC=$S($P(RC,"."):+$P(RC,".")_" Hr "_+$P(RC,".",2)_" Min ",1:+$P(RC,".",2)_" Min ") Q
|
|
CHK ;ASK TO ADD DUPLICATE TO 2421 AND NO FORM
|
|
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
|
|
S RD=0 F RDA=0:0 S RDA=$O(^RMPR(664,RMPRA,1,"B",HY,RDA)) Q:RDA'>0 S RD=RD+1
|
|
LKP ;DISPLAY DUPLICATE AND SINGLE ITEMS ON 2421 AND NO FORM
|
|
I RD>1 D Q:$D(DIRUT)!$D(DTOUT) I '$D(RD(+Y)) W $C(7) G LKP
|
|
.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)
|
|
.K DIR,Y S DIR(0)="N" D ^DIR I +Y S DA=+Y
|
|
G ENT
|
|
STA() ;CONVERTS RMPR("STA") INTO EXTERNAL FORMAT
|
|
N STAE I '$D(RMPRSITE)!'($D(RMPR)) D ^RMPRSIT
|
|
S STAE=$S($D(^DIC(4,RMPR("STA"),99)):$P(^(99),U),1:RMPR("STA"))
|
|
Q STAE
|
|
ROU(RMPRSITE) ;Return mail routing code for a site
|
|
N RMPRSYM
|
|
S RMPRSYM=""
|
|
I $G(RMPRSITE)="" G ROUX
|
|
S RMPRSYM=$P($G(^RMPR(669.9,RMPRSITE,0)),"^",13)
|
|
ROUX Q RMPRSYM
|
|
STATN(RSTA) ;CONVERT POINTER TO STATION TO NAME OF STATION
|
|
;VARIABLE PASSED IN: RSTA - POINTER TO STATION IN FILE 4
|
|
;VARIABLE PASSED OUT:RSTATION - NAME OF STATION
|
|
Q:$G(RSTA)'>0 ""
|
|
N RSTATION
|
|
S RSTATION=$S($D(^DIC(4,RSTA,99)):$P(^(99),U,1),1:RSTA)
|
|
Q RSTATION
|
|
;
|
|
DIC660 ;REVERSE DIC LOOK UP FOR 660.
|
|
K ^TMP($J),RMIEN W ! S DIC="^RMPR(665,",DIC(0)="AEMQZ",DIC("A")="Select PATIENT: "
|
|
D ^DIC G:+Y'>0!($D(DTOUT)) EXIT
|
|
REV ; Added for reverse look-up..
|
|
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
|
|
LST S (I,RMI,RMQUIT,RMSEL,RMIEN)=0 W !,"CHOOSE FROM:"
|
|
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)
|
|
G:RMSEL LST G:RMIEN PROC I 'RMI W !!,"***PATIENT HAS NO 2319 RECORD!!!!" G EXIT
|
|
I RMQUIT W !!,"***** NO SELECTION MADE!!!" G EXIT
|
|
W !!,"[<RETURN> or '^' to Quit] or Choose Number 1-",RMI W ": " R X:DTIME I '$T G EXIT
|
|
I X=""!(X="^")!('$D(X)) W !!,"***** NO SELECTION MADE!!!" G EXIT
|
|
I '$D(^TMP($J,+X)) W !,$C(7),"****INVALID RESPONSE, Please choose a NUMBER within the range!!!!",! G LST
|
|
S RMIEN=$P(^TMP($J,+X),U,2)
|
|
PROC 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")
|
|
W " ",Y," ",$S(RMDFN:$E($P(^DPT(RMDFN,0),U,1),1,20),1:"")," $",$J($P(RO,U,16),0,2)
|
|
EXIT K DIC,DIE,DIR,%,X,RMI,RMIT,RMSEL,RMQUIT,RMDFN,RO,Y,^TMP($J) Q
|
|
WRI ;WRITE REVERSE LISTING
|
|
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)
|
|
W !,$J(RMI,4),"> ",Y,?20,$S(RMDFN:$E($P($G(^DPT(RMDFN,0)),U,1),1,20),1:"")
|
|
I $P(RO,U,26)'="" W ?41,$S($P(RO,U,26)="P":"SHIPPING",$P(RO,U,26)="D":"DELIVERY",1:"SHIPPING")
|
|
E W ?41,$S(RMIT:$E($P($G(^PRC(441,RMIT,0)),U,2),1,25),1:"")
|
|
W ?68,"$",$J($P(RO,U,16),0,2) Q
|
|
DIS W !!,"<RETURN> to Continue, '^' to Quit or Choose Number 1-",RMI W ": " R X:DTIME I '$T S RMQUIT=1 Q
|
|
Q:X=""!(X=" ") I X="^" S RMQUIT=1 Q
|
|
I '$D(^TMP($J,+X)) W !,$C(7),"*****INVALID RESPONSE, Please choose a NUMBER within the range!!!!" S RMSEL=1 Q
|
|
S RMIEN=$P(^TMP($J,+X),U,2) Q
|
|
;
|
|
KILLG ;kill & set 'G' cross reference in 660.
|
|
S RMPRBE=$P(^RMPR(660,DA,0),U,22)
|
|
K ^RMPR(660,"G",RMPRBE,DA)
|
|
S $P(^RMPR(660,DA,0),U,22)=$P(^RMPR(661.1,X,0),U,4),RMPRX=X
|
|
S DIK=DIE,DIK(1)="4.1^G" D IX^DIK S X=RMPRX K RMPRX,RMPRBE,RMPRDA
|
|
Q
|
|
;
|
|
121 ;set 121 as the mail routing symbol.
|
|
N RMII,RMIIDAT,DIE
|
|
S DIE="^RMPR(669.9,",DR="34///^S X=121"
|
|
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
|
|
Q
|