Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: GMRCU

GMRCU.m

Go to the documentation of this file.
  1. GMRCU ;SLC/DLT - Consult/Request Utilities ;5/20/98 14:21
  1. ;;3.0;CONSULT/REQUEST TRACKING;**1**;DEC 27, 1997
  1. MTIM ;CONVERT TIME from X=2890313.1304 INTO X=13:04
  1. S X=$P(X,".",2) Q:'$L(X)
  1. S X=$S(X:$E(X,1,2)_$E("00",0,2-$L($E(X,1,2)))_":"_$E(X,3,4)_$E("00",0,2-$L($E(X,3,4))),1:"")
  1. Q
  1. REGDT ; Receives X in internal date.time, and returns X in MM/DD/YY format
  1. S X=$S(X:$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3),1:"")
  1. Q
  1. REGDTM ;Receives X in internal date.time, and returns X in MM/DD/YY TT:TT
  1. N T
  1. S T=$P(X,".",2),X=$S(X:$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3),1:"")_" "_$S(T:$E(T,1,2)_$E("00",0,2-$L($E(T,1,2)))_":"_$E(T,3,4)_$E("00",0,2-$L($E(T,3,4))),1:"")
  1. Q
  1. SIDT ; Receives X as internal date/time and returns X in DD MMM YY
  1. N MON,MM
  1. S X=$P(X,".") I 'X S X="" Q
  1. S MON="JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC"
  1. S MM=$E(X,4,5),MM=$S(MM:$P(MON,U,MM),1:"")
  1. S X=$E(X,6,7)_" "_MM_" "_$E(X,2,3)
  1. Q
  1. FMHL7DTM ; Recieves X as internal date/time and returns X in CCYYMMDDHHMM
  1. N T
  1. S T=$P(X,".",2)
  1. S T=$S(T:$E(T,1,2)_$E("00",0,2-$L($E(T,1,2)))_$E(T,3,4)_$E("00",0,2-$L($E(T,3,4))),1:"0000")
  1. S X=($E($P(X,"."),1,3)+1700)_$E($P(X,"."),4,7)_T
  1. Q
  1. HL7FMDTM ; Recieves X as CCYYMMDDHHMM and returns X as internal date/time
  1. N DATE,TIME
  1. S DATE=$E(X,1,8),TIME=$E(X,9,12)
  1. S DATE=DATE-17000000,X=DATE_"."_TIME
  1. Q
  1. DEM ; Gets Demographic Data from VADPT
  1. ; Receives: DFN
  1. ; Returns: GMRCPNM,GMRCSN,GMRCDOB,SEX,GMRCWARD,GMRCRB,GMRCAGE
  1. ; and GMRCWLI,GMRCHLI
  1. K VAINDT,VAHOW D OERR^VADPT
  1. S GMRCPNM=VADM(1)
  1. S GMRCSN=$S($D(VA("PID")):VA("PID"),1:$P(VADM(2),"^",2))
  1. S GMRCAGE=VADM(4),SEX=$P(VADM(5),"^")
  1. S GMRCWARD=$P(VAIN(4),"^",2),GMRCRB=VAIN(5),GMRCWLI=$P(VAIN(4),"^",1)
  1. S GMRCDOB=$P(VADM(3),"^",2)
  1. K VA,VAIN,VADM,VAERR
  1. Q
  1. MD ; Format physician names ;4/4/89 11:39 ;
  1. ; Recieves: IFN for New Person file as PR and desired name length, as NML
  1. ; Returns: Lastname,FI to specified length as PR
  1. N PRFI,PRLN,PRNM
  1. S PRNM=$S(PR:$S($D(^VA(200,+PR,0)):$P(^(0),"^"),1:"UNKNOWN"),1:"UNKNOWN")
  1. I PRNM?1A.A." ".A1",".A.E S PRLN=$P(PRNM,","),PRFI=$E($P(PRNM,",",2),1) I $L(PRLN)>(NML-2) S PRLN=$E(PRLN,1,(NML-2))
  1. S PR=$S(PRNM="UNKNOWN":PRNM,1:PRLN_","_PRFI)
  1. Q
  1. NAME ; Format names ;6/30/89 11:20 ;
  1. ; Recieves: FILE (3 for User, 16 for Person, 6 for Provider)
  1. ; IFN (Internal file # for above file),
  1. ; NML (Desired length for name to be returned)
  1. ; FNF (Flag to specify first name format: 0 for FI, 1 for FN)
  1. ; Returns: Lastname,First(name/initial) to specified length as NM
  1. ;
  1. N DIC,RAWNM,LN,FN,FA,NI,CH,X,Y
  1. S DIC=FILE,DIC(0)="NXZ",X=IFN D ^DIC S RAWNM=$S($D(Y(0,0)):Y(0,0),1:"UNKNOWN")
  1. S LN=$P(RAWNM,","),FN=$P(RAWNM,",",2)
  1. S FA=0 I $L(FN) F NI=1:1 S CH=$E(FN,NI) Q:CH?1A S FA=NI
  1. I FA S FN=$E(FN,FA+1,$L(FN))
  1. I 'FNF S FN=$E(FN,1)
  1. S NM=$S($L(FN):LN_","_FN,1:LN),NM=$E(NM,1,NML)
  1. K FILE,IFN,NML,FNF
  1. Q
  1. PTRCLN ;Clean out subservice 'B' X-reference of deleted entries
  1. S I=0 F S I=$O(^GMR(123.5,I)) Q:I<1 I $D(^(I,10,0)) S J=0 F S J=$O(^GMR(123.5,I,10,J)) Q:J<1 S ENTRY=+^(J,0) I '$D(^GMR(123.5,ENTRY,0)) K ^GMR(123.5,I,10,J,0),^GMR(123.5,I,10,"B",ENTRY) D
  1. .S CNT=$P(^GMR(123.5,I,10,0),"^",4),$P(^(0),"^",4)=CNT-1
  1. K CNT,ENTRY,I,J Q