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

PXRRPECU.m

Go to the documentation of this file.
  1. PXRRPECU ;ISL/PKR - Utilities for dealing with the Person Class file. ;4/3/97
  1. ;;1.0;PCE PATIENT CARE ENCOUNTER;**12,31**;Aug 12, 1996
  1. ;
  1. ;=======================================================================
  1. ABBRV(VACODE) ;Given a VACODE get the full Person Class entry and return an
  1. ;abbreviation for it.
  1. N ABBRV,MAXLEN,MAXLENP3,OCC,PCLASS,SPEC,SUB
  1. ;If there is no VACODE then return Unknown.
  1. I $L(VACODE)'>0 Q "Unknown"
  1. ;
  1. S MAXLEN=20
  1. S MAXLENP3=MAXLEN+3
  1. I $L(VACODE,U)=3 S PCLASS=U_VACODE
  1. E S PCLASS=$$OCCUP^PXBGPRV("","",VACODE,1,"")
  1. ;
  1. S OCC=$P(PCLASS,U,2)
  1. I $L(OCC)>MAXLENP3 S OCC=$E(OCC,1,MAXLEN)_"..."
  1. S ABBRV=OCC
  1. ;
  1. S SPEC=$P(PCLASS,U,3)
  1. I $L(SPEC)>MAXLENP3 S SPEC=$E(SPEC,1,MAXLEN)_"..."
  1. I $L(SPEC)>0 S ABBRV=ABBRV_"+"_SPEC
  1. S SUB=$P(PCLASS,U,4)
  1. I $L(SUB)>MAXLENP3 S SUB=$E(SUB,1,MAXLEN)_"..."
  1. I $L(SUB)>0 S ABBRV=ABBRV_"+"_SUB
  1. Q ABBRV
  1. ;
  1. ;=======================================================================
  1. ALPHA(PCLASS) ;Given a person class of the form IEN_U_Occupation_U_Specialty
  1. ;_U_^Subspecialty return an abbreviation useful for alphabetizing.
  1. N T1,TEMP
  1. ;If there is no person class return Unknown.
  1. I +$P(PCLASS,U,1)'>0 Q "Unknown"
  1. S TEMP=$E($P(PCLASS,U,2),1,4)
  1. S T1=$E($P(PCLASS,U,3),1,4)
  1. I $L(T1)'>0 S T1="+"
  1. S TEMP=TEMP_T1
  1. S T1=$E($P(PCLASS,U,4),1,4)
  1. I $L(T1)'>0 S T1="+"
  1. S TEMP=TEMP_T1
  1. S TEMP=TEMP_U_$P(PCLASS,U,7)
  1. Q TEMP
  1. ;
  1. ;=======================================================================
  1. FDME(INP,ARRAY) ;Find and display the entries matching the input and get a selection.
  1. N DIR,IC,JC,LINP,RET,SA,X,Y
  1. ;Check for the special cases first.
  1. ;The null selection.
  1. I INP="" Q INP
  1. ;The wildcard selection.
  1. I INP=WC Q WC_U_WC
  1. ;An exact match.
  1. I $D(ARRAY(INP)) Q INP_U_ARRAY(INP)
  1. ;
  1. S RET=-1
  1. S INP=$$UPPRCASE(INP)
  1. S LINP=$L(INP)
  1. S IC=INP
  1. S JC=0
  1. F S IC=$O(ARRAY(IC)) Q:(INP'=$E(IC,1,LINP)) D
  1. . S JC=JC+1
  1. . S SA(JC)=IC_U_ARRAY(IC)
  1. I JC=1 W " ",$P(SA(1),U,1) Q SA(1)
  1. I JC>1 D
  1. . F IC=1:1:JC D
  1. .. W !,IC,?INDENT,$P(SA(IC),U,1)
  1. . S DIR(0)="NAO^1:"_JC
  1. . S DIR("A")="Choose 1-"_JC_": "
  1. . W !
  1. . D ^DIR
  1. . I +Y>0 S RET=SA(+Y)
  1. Q RET
  1. ;
  1. ;=======================================================================
  1. GETYORN(PROMPT) ;Get a yes or no answer, return true (yes) or false (no).
  1. N DIR,X,Y
  1. S DIR(0)="YAO"
  1. I $D(PROMPT) S DIR("A")=PROMPT
  1. D ^DIR
  1. Q Y
  1. ;
  1. ;=======================================================================
  1. LISTA(ARRAY) ;List all the elements of ARRAY.
  1. N IC,DONE
  1. K SELECT
  1. S $Y=0
  1. S DONE=0
  1. W !,"Choose from:"
  1. S IC=""
  1. F S IC=$O(ARRAY(IC)) Q:(IC="")!(DONE) D
  1. . W !,?INDENT,IC
  1. . I $Y>(IOSL-3) D PAGE(.ARRAY)
  1. I $D(SELECT) D
  1. . I SELECT'=-1 D
  1. .. ;S SSPEC=SELECT
  1. .. S DIR("B")=$P(SELECT,U,1)
  1. Q
  1. ;
  1. ;=======================================================================
  1. MATCH(PCLASS) ;Return true if PCLASS is in the PERSON CLASS list, PXXRPECL.
  1. N CLASSIEN,IC,LOCC,LSPEC,LSUB,MATCH,MOCC,MSPEC,MSUB
  1. N NS,OCC,SPEC,SUB,WC
  1. ;If PCLASS is less than 0 then no person class was returned.
  1. ;Therefore there cannot be a match.
  1. I +PCLASS<0 Q 0
  1. ;
  1. S NS="NOT SPECIFIED"
  1. S WC="*"
  1. S CLASSIEN=$P(PCLASS,U,1)
  1. ;OCCUP^PXBGPRV returns negative numbers in first piece if there was no
  1. ;person class. In this case the only match will be for the wildcard.
  1. I +CLASSIEN'>0 D
  1. . S (OCC,SPEC,SUB)=WC
  1. E D
  1. . S OCC=$P(PCLASS,U,2)
  1. . S SPEC=$P(PCLASS,U,3)
  1. . S SUB=$P(PCLASS,U,4)
  1. I $L(SPEC)=0 S SPEC=NS
  1. I $L(SUB)=0 S SUB=NS
  1. ;
  1. S MATCH=0
  1. F IC=1:1:NCL Q:MATCH D
  1. . S LOCC=$P(PXRRPECL(IC),U,1)
  1. . I (LOCC'=OCC)&(LOCC'=WC) Q
  1. . S LSPEC=$P(PXRRPECL(IC),U,2)
  1. . I (LSPEC'=SPEC)&(LSPEC'=WC) Q
  1. . S LSUB=$P(PXRRPECL(IC),U,3)
  1. . I (LSUB'=SUB)&(LSUB'=WC) Q
  1. .;If we got to here we have a match.
  1. . S $P(PXRRPECL(IC),U,4)="M"
  1. . S MATCH=1
  1. ;
  1. Q MATCH
  1. ;
  1. ;=======================================================================
  1. NXREF(XREF,STRING) ;Return the number of elements for the STRING and cross-ref pair.
  1. N IC,JC
  1. S (IC,JC)=0
  1. F S IC=$O(^USC(8932.1,XREF,STRING,IC)) Q:+IC=0 D
  1. . S JC=JC+1
  1. Q JC
  1. ;
  1. ;=======================================================================
  1. PAGE(ARRAY) ;Page breaking with optional return of selection.
  1. N DIR,X,Y
  1. S DIR(0)="FAOU^1:60"
  1. S DIR("A")="Enter Return to continue, your selection, or '^' to exit: "
  1. W !
  1. D ^DIR K DIR
  1. I $D(DUOUT)!($D(DTOUT)) S DONE=1 Q
  1. I Y="" W:$D(IOF) @IOF
  1. E D Q
  1. . S SELECT=$$FDME(Y,.ARRAY)
  1. . S DONE=1
  1. K DTOUT,DUOUT
  1. Q
  1. ;
  1. ;=======================================================================
  1. PCLLIST(NEWPIEN,BDT,EDT,LIST) ;Build a list of all the person classes for the
  1. ;provider NEWPIEN in the date range BDT to EDT. Return the total
  1. ;number.
  1. N IC,PCLASS,TEMP,TLIST,TOTAL
  1. K LIST
  1. S TOTAL=0
  1. F IC=BDT:1:EDT D
  1. . S PCLASS=$$GET^XUA4A72(NEWPIEN,IC)
  1. . I PCLASS>0 D
  1. .. S TEMP=$$ALPHA(PCLASS)
  1. . E S TEMP="Unknown"
  1. . S TLIST(TEMP)=""
  1. ;Count and return the unique entries.
  1. S IC=""
  1. F S IC=$O(TLIST(IC)) Q:IC="" D
  1. . S TOTAL=TOTAL+1
  1. . S LIST(TOTAL)=IC
  1. Q TOTAL
  1. ;
  1. ;=======================================================================
  1. UPPRCASE(STRING) ;Convert STRING to uppercase and return it.
  1. Q $TR(STRING,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
  1. ;
  1. ;=======================================================================
  1. VERIFY ;Have the user verify the most recent Person Class selection.
  1. N KEEP,PROMPT
  1. W !!,"Your Person Class Selection was:"
  1. W !,?INDENT,"OCCUPATION: ",$P(PXRRPECL(NCL),U,1)
  1. W !,?INDENT,"SPECIALTY: ",$P(PXRRPECL(NCL),U,2)
  1. W !,?INDENT,"SUBSPECIALTY: ",$P(PXRRPECL(NCL),U,3)
  1. W !
  1. S PROMPT="Is this selection correct? "
  1. S KEEP=$$GETYORN(PROMPT)
  1. I 'KEEP D
  1. . K PXRRPECL(NCL)
  1. . S NCL=NCL-1
  1. Q