- 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 Jan 18, 2025@03:32: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