PXRRGUT ;ISL/PKR - General utilities for PCE Encounter reports. ;10/13/2017
;;1.0;PCE PATIENT CARE ENCOUNTER;**8,18,48,211**;Aug 12, 1996;Build 454
;
;====================
EOR ;End of report display.
I $E(IOST)="C",IO=IO(0) D
. S DIR(0)="EA"
. S DIR("A")="End of the report. Press ENTER/RETURN to continue..."
. W !
. D ^DIR K DIR
Q
;
;====================
EXIT ;Clean things up.
D ^%ZISC
D HOME^%ZIS
K DIRUT,DTOUT,DUOUT
K ^TMP(PXRRXTMP)
K ^XTMP(PXRRXTMP)
Q
;
;====================
XTMPSUB(PXSUB) ;Generate a unique subscript for use with ^TMP and ^XTMP.
H 1
Q PXSUB_$J_$TR($H,",")
;
;====================
USTRINS(STRING,CHAR) ;Given a string, which is assumed to be in alphabetical
;order and a character which is not already in the string insert the
;character into the string in alphabetical order. For example:
;STRING CHAR RETURNS
;CEQ A ACEQ
;CEQ E CEQ
;CEQ F CEFQ
;CEQ T CEQT
;
N CH1,CH2,DONE,IC,LEN,STR
S LEN=$L(STRING)
;Special case of empty STRING.
I LEN=0 Q CHAR
;
S DONE=0
S STR=""
S CH1=$E(STRING,1,1)
I (CH1]CHAR) S STR=STR_CHAR_CH1,DONE=1
E S STR=STR_CH1
I CH1=CHAR S DONE=1
;
;Special case of STRING of length 1.
I (LEN=1)&('DONE) S STR=STR_CHAR,DONE=1
;
F IC=2:1:LEN D
. S CH2=$E(STRING,IC,IC)
. I DONE S STR=STR_CH2
. E D
.. I (CHAR]CH1)&(CH2]CHAR) S STR=STR_CHAR_CH2,DONE=1
.. E S STR=STR_CH2
.. I CH2=CHAR S DONE=1
.. S CH1=CH2
;
;If we made it all the way through the loop and we are still not
;done then append CHAR.
I ('DONE) S STR=STR_CHAR
Q STR
;
;====================
VLIST(SLIST,LIST,MESSAGE) ;Make sure all the elements of LIST are in
;SLIST. If they are, then LIST is valid. The elements of LIST can be
;separated by commas and spaces.
N IC,LE,LEN,VALID
S LIST=$TR(LIST,",","")
S LIST=$TR(LIST," ","")
;Make the test case insensitive.
S SLIST=$$UP^XLFSTR(SLIST)
S LIST=$$UP^XLFSTR(LIST)
S VALID=1
S LEN=$L(LIST)
I LEN=0 D
. W !,"The list is empty!"
. S VALID=0
F IC=1:1:LEN D
. S LE=$E(LIST,IC,IC)
. I SLIST'[LE D
.. W !,LE,MESSAGE
.. S VALID=0
Q VALID
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRRGUT 2185 printed Oct 16, 2024@18:31:21 Page 2
PXRRGUT ;ISL/PKR - General utilities for PCE Encounter reports. ;10/13/2017
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**8,18,48,211**;Aug 12, 1996;Build 454
+2 ;
+3 ;====================
EOR ;End of report display.
+1 IF $EXTRACT(IOST)="C"
IF IO=IO(0)
Begin DoDot:1
+2 SET DIR(0)="EA"
+3 SET DIR("A")="End of the report. Press ENTER/RETURN to continue..."
+4 WRITE !
+5 DO ^DIR
KILL DIR
End DoDot:1
+6 QUIT
+7 ;
+8 ;====================
EXIT ;Clean things up.
+1 DO ^%ZISC
+2 DO HOME^%ZIS
+3 KILL DIRUT,DTOUT,DUOUT
+4 KILL ^TMP(PXRRXTMP)
+5 KILL ^XTMP(PXRRXTMP)
+6 QUIT
+7 ;
+8 ;====================
XTMPSUB(PXSUB) ;Generate a unique subscript for use with ^TMP and ^XTMP.
+1 HANG 1
+2 QUIT PXSUB_$JOB_$TRANSLATE($HOROLOG,",")
+3 ;
+4 ;====================
USTRINS(STRING,CHAR) ;Given a string, which is assumed to be in alphabetical
+1 ;order and a character which is not already in the string insert the
+2 ;character into the string in alphabetical order. For example:
+3 ;STRING CHAR RETURNS
+4 ;CEQ A ACEQ
+5 ;CEQ E CEQ
+6 ;CEQ F CEFQ
+7 ;CEQ T CEQT
+8 ;
+9 NEW CH1,CH2,DONE,IC,LEN,STR
+10 SET LEN=$LENGTH(STRING)
+11 ;Special case of empty STRING.
+12 IF LEN=0
QUIT CHAR
+13 ;
+14 SET DONE=0
+15 SET STR=""
+16 SET CH1=$EXTRACT(STRING,1,1)
+17 IF (CH1]CHAR)
SET STR=STR_CHAR_CH1
SET DONE=1
+18 IF '$TEST
SET STR=STR_CH1
+19 IF CH1=CHAR
SET DONE=1
+20 ;
+21 ;Special case of STRING of length 1.
+22 IF (LEN=1)&('DONE)
SET STR=STR_CHAR
SET DONE=1
+23 ;
+24 FOR IC=2:1:LEN
Begin DoDot:1
+25 SET CH2=$EXTRACT(STRING,IC,IC)
+26 IF DONE
SET STR=STR_CH2
+27 IF '$TEST
Begin DoDot:2
+28 IF (CHAR]CH1)&(CH2]CHAR)
SET STR=STR_CHAR_CH2
SET DONE=1
+29 IF '$TEST
SET STR=STR_CH2
+30 IF CH2=CHAR
SET DONE=1
+31 SET CH1=CH2
End DoDot:2
End DoDot:1
+32 ;
+33 ;If we made it all the way through the loop and we are still not
+34 ;done then append CHAR.
+35 IF ('DONE)
SET STR=STR_CHAR
+36 QUIT STR
+37 ;
+38 ;====================
VLIST(SLIST,LIST,MESSAGE) ;Make sure all the elements of LIST are in
+1 ;SLIST. If they are, then LIST is valid. The elements of LIST can be
+2 ;separated by commas and spaces.
+3 NEW IC,LE,LEN,VALID
+4 SET LIST=$TRANSLATE(LIST,",","")
+5 SET LIST=$TRANSLATE(LIST," ","")
+6 ;Make the test case insensitive.
+7 SET SLIST=$$UP^XLFSTR(SLIST)
+8 SET LIST=$$UP^XLFSTR(LIST)
+9 SET VALID=1
+10 SET LEN=$LENGTH(LIST)
+11 IF LEN=0
Begin DoDot:1
+12 WRITE !,"The list is empty!"
+13 SET VALID=0
End DoDot:1
+14 FOR IC=1:1:LEN
Begin DoDot:1
+15 SET LE=$EXTRACT(LIST,IC,IC)
+16 IF SLIST'[LE
Begin DoDot:2
+17 WRITE !,LE,MESSAGE
+18 SET VALID=0
End DoDot:2
End DoDot:1
+19 QUIT VALID
+20 ;
