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

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