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