PSXUTL ;BIR/BAB,WPB,HTW-Utility Subroutines ;14 Feb 2002 2:27 PM
;;2.0;CMOP;**3,38**;11 Apr 97
;Reference to ^PS(54 supported by DBIA #2227
;Reference to ^PSDRUG( supported by DBIA #1983
;
HEX ;converts decimal #<128 to a two byte hex #
;requires PSXHEX = decimal # to be converted
;returns PSXHEX = hex #, if error PSXHEX=""
N %,H,H1,H2 S %=PSXHEX
I (%<0)!(%>127)!(%'=+%) S PSXHEX="" Q ;error if # not between 0 - 127
I %<10 S PSXHEX=0_% Q ;if # < 10 result is trivial, pad with zero
S H=%\16 S:H>9 H=$E(" ABCDEF",H) S H1=H
S H=%#16 S:H>9 H=$E(" ABCDEF",H) S H2=H
S PSXHEX=H1_H2
Q
FLUSH1 N X,X1,X2,N S N=0
; the *READ is for the CMOP vendors CPU only
S X=$P($H,",",2) F R *X2:0 Q:'$T S N=N+1 S X1=$P($H,",",2) S:X1<X X1=X1+86400 Q:(X1-X)>20
Q
;check to see if a timer has expired
;requires PSXTM = PSXTMx where x is A, B, D or E
;returns PSXTMOUT=1 if timer has expired, otherwise PSXTMOUT=0
CHKA S DELTA=PSXDLTA,PSXTM=PSXTMA G CHK
CHKB S DELTA=PSXDLTB,PSXTM=PSXTMB G CHK
CHKD S DELTA=PSXDLTD,PSXTM=PSXTMD G CHK
CHKE S DELTA=PSXDLTE,PSXTM=PSXTME
CHK N %
S %=$P($H,",",2) S:%<PSXTM %=%+86400
S PSXTMOUT=$S(%'>(PSXTM+DELTA):0,1:1)
K DELTA
Q
LOG ;create a log entry in the CMOP INTERFACE file
;requires the LOG() array with the text of the MESSAGE
N X,Y
H 1
D NOW^%DTC K %I,%H
K DIC,DD,DO
S X=%,DINUM=9999999-X,DIC="^PSX(553,"_1_",""X"",",DIC(0)="Z"
D FILE^DICN G:$P(Y,"^",3)'=1 LOG
L +^PSX(553,1,"S"):DTIME Q:'$T
S X="" F %=1:1 S X=$O(LOG(X)) Q:'X S ^PSX(553,1,"X",+Y,"X",%,0)=LOG(X)
S %=%-1,^PSX(553,1,"X",+Y,"X",0)="^^"_%_"^"_%_"^"_$P(+Y(0),".")
L -^PSX(553,1,"S")
K DD,DO,DUOUT,DTOUT,X,Y,DIC,DINUM,%,DLAYGO
Q
TSOUT ;convert current date time to HL7 timestamp
;returns PSXTS= YYYYMMDDHHMM
D NOW^%DTC
S %=$E($P(%,".",2),1,6)
S PSXTS=(1700+$E(X,1,3))_$E(X,4,7)_%_$E("0000",1,4-$L(%))
K %,%H,%I
Q
TSIN ;convert an HL7 timestamp to fileman format
;returns e.g. PSXFM=2910305.213
;requires PSXTS as input with YYYYMMDDHHMM format
I $G(PSXTS)']""!($L(PSXTS)<7) S PSXFM=""
N X S X=$E(PSXTS,9,14) S PSXFM=$E(PSXTS,1,2)-17_$E(PSXTS,3,8)_$S(+X:+("."_X),1:"")
Q
STATUS ;display CMOP status for entry action on RX menu
N PSXSTAT,PSXTXT
S PSXSTAT=$G(^PSX(553,1,"S"))
Q:$G(PSXSTAT)=""
S PSXTXT="CMOP Interface is "_$S(PSXSTAT="R":"RUNNING!!!",1:"Stopped.")
W !!,?((IOM\2)-($L(PSXTXT)\2)-3),PSXTXT
K PSXSTAT,PSXTXT
Q
EXIT K DIC,DIE,Y,DR,DA
Q
DRUGW ;
F Z0=1:1 Q:$P(X,",",Z0,99)="" S Z1=$P(X,",",Z0) W:$D(^PS(54,Z1,0)) ?35,$P(^(0),"^"),! I '$D(^(0)) W ?35,"NO SUCH WARNING LABEL" K X Q
Q
DRG ;
F X=0:0 S X=$O(^PSDRUG(X)) Q:'$G(X) I $D(^PSDRUG(X,5)) D
.S XX=$P(^PSDRUG(X,5),"^"),^(5)=XX K XX
Q
UNMARK ;Entry point to unmark drug for CMOP dispense
N PSX,Z,%
S $P(^PSDRUG(PSXCK,3),"^",1)=0 K ^PSDRUG("AQ",PSXCK)
S:'$D(^PSDRUG(PSXCK,4,0)) ^PSDRUG(PSXCK,4,0)="^50.0214DA^^"
S (PSX,Z)=0 F S Z=$O(^PSDRUG(PSXCK,4,Z)) Q:'Z S PSX=Z
S PSX=PSX+1 D NOW^%DTC S ^PSDRUG(PSXCK,4,PSX,0)=%_"^E^"_DUZ_"^CMOP Dispense^"_$S($G(^PSDRUG(PSXCK,3))=1:"YES",$G(^PSDRUG(PSXCK,3))=0:"NO",1:"")
S $P(^PSDRUG(PSXCK,4,0),"^",3)=PSX,$P(^(0),"^",4)=$P(^(0),"^",4)+1
K PSX,Z,%
Q
RALRT S XQAMSG=PSXFILE_" file is in use. Transmission not completed. Contact IRM." D GRP1^PSXNOTE,SETUP^XQALERT K PSXFILE,XQALERT,XQA,XQAMSG Q
SETVER S DIC="9.4",X="OUTPATIENT PHARMACY",DIC(0)="MOZX" D ^DIC D:$G(Y)'>0 ALRT Q:$G(Y)'>0 S XDA=+$G(Y) K X,Y,DIC,DIC(0)
S DA=XDA,DIQ="PSXUTL1",DIQ(0)="I",DIC="9.4",DR="13" D EN^DIQ1 S PSXV=+$G(PSXUTL1(9.4,XDA,13,"I")) D:$G(PSXV)'>0 ALRT K DA,XDA,DIQ,DIQ(0),DIC,X,Y,PSXUTL1 S PSXVER=$S($G(PSXV)>"6.0":1,1:"")
Q
ALRT S XQAMSG="Package file entry for Outpatient Pharamacy is corrupt" D GRP1^PSXNOTE,SETUP^XQALERT K PSXFILE,XQALERT,XQA,XQAMSG S PSXER=$G(PSXER)_"^"_12 D ER1^PSXERR K PSXER Q
;
GETS(FILE,IENS,DR,FORM,TARG,ERR) ;
S IENS=$$IENS(IENS)
I $D(ERR) D GETS^DIQ(FILE,IENS,DR,FORM,TARG,ERR) I 1
E D GETS^DIQ(FILE,IENS,DR,FORM,TARG)
D TOP(TARG)
Q
IENS(IENS) ;Resolve IENS to numbers X,Y,Z to 89,34,345
N I,X
F I=1:1 S X=$P(IENS,",",I) Q:X="" D
. I X'=+X F S X=@X I X=+X S $P(IENS,",",I)=X Q
Q IENS
;
TOP(TARGROOT) ; Move to the top the returned DIQ array
; Move array(file,iens,field)=value to array(field)=value
; also moves the ,field,"I") =value(internal) to (field)=value(internal)
Q:'$D(@TARGROOT)
N FILE,IENS,FLD
S FILE=$O(@TARGROOT@(""))
S IENS=$O(@TARGROOT@(FILE,""))
S FLD=+$O(@TARGROOT@(FILE,IENS,""))
M ^TMP($J,"TOP")=@TARGROOT@(FILE,IENS)
K @TARGROOT
M @TARGROOT=^TMP($J,"TOP")
K ^TMP($J,"TOP")
; if form is of xx(FLD,"I") move value to xx(FLD)
I $O(@TARGROOT@(FLD,""))="I" D
. S FLD=0 F S FLD=$O(@TARGROOT@(FLD)) Q:FLD'>0 D
.. S @TARGROOT@(FLD)=@TARGROOT@(FLD,"I") K @TARGROOT@(FLD,"I")
Q
;
PIECE(REC,DLM,XX) ; where XX = VAR_U_I ex: XX="PATNM^1"
; Set VAR = piece I of REC using delimiter DLM
N Y,I S Y=$P(XX,U),I=$P(XX,U,2),@Y=$P(REC,DLM,I)
Q
SET(REC,DLM,ABCD) ; where XX = VAR_U_I ex: XX="PATNM^1"
; Set VAR into piece I of REC using delimiter DLM
N Y,I S Y=$P(ABCD,U),I=$P(ABCD,U,2)
I Y'=+Y,Y'="" S $P(REC,DLM,I)=$G(@Y) I 1
E S $P(REC,DLM,I)=Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSXUTL 5213 printed Sep 23, 2025@19:21:22 Page 2
PSXUTL ;BIR/BAB,WPB,HTW-Utility Subroutines ;14 Feb 2002 2:27 PM
+1 ;;2.0;CMOP;**3,38**;11 Apr 97
+2 ;Reference to ^PS(54 supported by DBIA #2227
+3 ;Reference to ^PSDRUG( supported by DBIA #1983
+4 ;
HEX ;converts decimal #<128 to a two byte hex #
+1 ;requires PSXHEX = decimal # to be converted
+2 ;returns PSXHEX = hex #, if error PSXHEX=""
+3 NEW %,H,H1,H2
SET %=PSXHEX
+4 ;error if # not between 0 - 127
IF (%<0)!(%>127)!(%'=+%)
SET PSXHEX=""
QUIT
+5 ;if # < 10 result is trivial, pad with zero
IF %<10
SET PSXHEX=0_%
QUIT
+6 SET H=%\16
if H>9
SET H=$EXTRACT(" ABCDEF",H)
SET H1=H
+7 SET H=%#16
if H>9
SET H=$EXTRACT(" ABCDEF",H)
SET H2=H
+8 SET PSXHEX=H1_H2
+9 QUIT
FLUSH1 NEW X,X1,X2,N
SET N=0
+1 ; the *READ is for the CMOP vendors CPU only
+2 SET X=$PIECE($HOROLOG,",",2)
FOR
READ *X2:0
if '$TEST
QUIT
SET N=N+1
SET X1=$PIECE($HOROLOG,",",2)
if X1<X
SET X1=X1+86400
if (X1-X)>20
QUIT
+3 QUIT
+4 ;check to see if a timer has expired
+5 ;requires PSXTM = PSXTMx where x is A, B, D or E
+6 ;returns PSXTMOUT=1 if timer has expired, otherwise PSXTMOUT=0
CHKA SET DELTA=PSXDLTA
SET PSXTM=PSXTMA
GOTO CHK
CHKB SET DELTA=PSXDLTB
SET PSXTM=PSXTMB
GOTO CHK
CHKD SET DELTA=PSXDLTD
SET PSXTM=PSXTMD
GOTO CHK
CHKE SET DELTA=PSXDLTE
SET PSXTM=PSXTME
CHK NEW %
+1 SET %=$PIECE($HOROLOG,",",2)
if %<PSXTM
SET %=%+86400
+2 SET PSXTMOUT=$SELECT(%'>(PSXTM+DELTA):0,1:1)
+3 KILL DELTA
+4 QUIT
LOG ;create a log entry in the CMOP INTERFACE file
+1 ;requires the LOG() array with the text of the MESSAGE
+2 NEW X,Y
+3 HANG 1
+4 DO NOW^%DTC
KILL %I,%H
+5 KILL DIC,DD,DO
+6 SET X=%
SET DINUM=9999999-X
SET DIC="^PSX(553,"_1_",""X"","
SET DIC(0)="Z"
+7 DO FILE^DICN
if $PIECE(Y,"^",3)'=1
GOTO LOG
+8 LOCK +^PSX(553,1,"S"):DTIME
if '$TEST
QUIT
+9 SET X=""
FOR %=1:1
SET X=$ORDER(LOG(X))
if 'X
QUIT
SET ^PSX(553,1,"X",+Y,"X",%,0)=LOG(X)
+10 SET %=%-1
SET ^PSX(553,1,"X",+Y,"X",0)="^^"_%_"^"_%_"^"_$PIECE(+Y(0),".")
+11 LOCK -^PSX(553,1,"S")
+12 KILL DD,DO,DUOUT,DTOUT,X,Y,DIC,DINUM,%,DLAYGO
+13 QUIT
TSOUT ;convert current date time to HL7 timestamp
+1 ;returns PSXTS= YYYYMMDDHHMM
+2 DO NOW^%DTC
+3 SET %=$EXTRACT($PIECE(%,".",2),1,6)
+4 SET PSXTS=(1700+$EXTRACT(X,1,3))_$EXTRACT(X,4,7)_%_$EXTRACT("0000",1,4-$LENGTH(%))
+5 KILL %,%H,%I
+6 QUIT
TSIN ;convert an HL7 timestamp to fileman format
+1 ;returns e.g. PSXFM=2910305.213
+2 ;requires PSXTS as input with YYYYMMDDHHMM format
+3 IF $GET(PSXTS)']""!($LENGTH(PSXTS)<7)
SET PSXFM=""
+4 NEW X
SET X=$EXTRACT(PSXTS,9,14)
SET PSXFM=$EXTRACT(PSXTS,1,2)-17_$EXTRACT(PSXTS,3,8)_$SELECT(+X:+("."_X),1:"")
+5 QUIT
STATUS ;display CMOP status for entry action on RX menu
+1 NEW PSXSTAT,PSXTXT
+2 SET PSXSTAT=$GET(^PSX(553,1,"S"))
+3 if $GET(PSXSTAT)=""
QUIT
+4 SET PSXTXT="CMOP Interface is "_$SELECT(PSXSTAT="R":"RUNNING!!!",1:"Stopped.")
+5 WRITE !!,?((IOM\2)-($LENGTH(PSXTXT)\2)-3),PSXTXT
+6 KILL PSXSTAT,PSXTXT
+7 QUIT
EXIT KILL DIC,DIE,Y,DR,DA
+1 QUIT
DRUGW ;
+1 FOR Z0=1:1
if $PIECE(X,",",Z0,99)=""
QUIT
SET Z1=$PIECE(X,",",Z0)
if $DATA(^PS(54,Z1,0))
WRITE ?35,$PIECE(^(0),"^"),!
IF '$DATA(^(0))
WRITE ?35,"NO SUCH WARNING LABEL"
KILL X
QUIT
+2 QUIT
DRG ;
+1 FOR X=0:0
SET X=$ORDER(^PSDRUG(X))
if '$GET(X)
QUIT
IF $DATA(^PSDRUG(X,5))
Begin DoDot:1
+2 SET XX=$PIECE(^PSDRUG(X,5),"^")
SET ^(5)=XX
KILL XX
End DoDot:1
+3 QUIT
UNMARK ;Entry point to unmark drug for CMOP dispense
+1 NEW PSX,Z,%
+2 SET $PIECE(^PSDRUG(PSXCK,3),"^",1)=0
KILL ^PSDRUG("AQ",PSXCK)
+3 if '$DATA(^PSDRUG(PSXCK,4,0))
SET ^PSDRUG(PSXCK,4,0)="^50.0214DA^^"
+4 SET (PSX,Z)=0
FOR
SET Z=$ORDER(^PSDRUG(PSXCK,4,Z))
if 'Z
QUIT
SET PSX=Z
+5 SET PSX=PSX+1
DO NOW^%DTC
SET ^PSDRUG(PSXCK,4,PSX,0)=%_"^E^"_DUZ_"^CMOP Dispense^"_$SELECT($GET(^PSDRUG(PSXCK,3))=1:"YES",$GET(^PSDRUG(PSXCK,3))=0:"NO",1:"")
+6 SET $PIECE(^PSDRUG(PSXCK,4,0),"^",3)=PSX
SET $PIECE(^(0),"^",4)=$PIECE(^(0),"^",4)+1
+7 KILL PSX,Z,%
+8 QUIT
RALRT SET XQAMSG=PSXFILE_" file is in use. Transmission not completed. Contact IRM."
DO GRP1^PSXNOTE
DO SETUP^XQALERT
KILL PSXFILE,XQALERT,XQA,XQAMSG
QUIT
SETVER SET DIC="9.4"
SET X="OUTPATIENT PHARMACY"
SET DIC(0)="MOZX"
DO ^DIC
if $GET(Y)'>0
DO ALRT
if $GET(Y)'>0
QUIT
SET XDA=+$GET(Y)
KILL X,Y,DIC,DIC(0)
+1 SET DA=XDA
SET DIQ="PSXUTL1"
SET DIQ(0)="I"
SET DIC="9.4"
SET DR="13"
DO EN^DIQ1
SET PSXV=+$GET(PSXUTL1(9.4,XDA,13,"I"))
if $GET(PSXV)'>0
DO ALRT
KILL DA,XDA,DIQ,DIQ(0),DIC,X,Y,PSXUTL1
SET PSXVER=$SELECT($GET(PSXV)>"6.0":1,1:"")
+2 QUIT
ALRT SET XQAMSG="Package file entry for Outpatient Pharamacy is corrupt"
DO GRP1^PSXNOTE
DO SETUP^XQALERT
KILL PSXFILE,XQALERT,XQA,XQAMSG
SET PSXER=$GET(PSXER)_"^"_12
DO ER1^PSXERR
KILL PSXER
QUIT
+1 ;
GETS(FILE,IENS,DR,FORM,TARG,ERR) ;
+1 SET IENS=$$IENS(IENS)
+2 IF $DATA(ERR)
DO GETS^DIQ(FILE,IENS,DR,FORM,TARG,ERR)
IF 1
+3 IF '$TEST
DO GETS^DIQ(FILE,IENS,DR,FORM,TARG)
+4 DO TOP(TARG)
+5 QUIT
IENS(IENS) ;Resolve IENS to numbers X,Y,Z to 89,34,345
+1 NEW I,X
+2 FOR I=1:1
SET X=$PIECE(IENS,",",I)
if X=""
QUIT
Begin DoDot:1
+3 IF X'=+X
FOR
SET X=@X
IF X=+X
SET $PIECE(IENS,",",I)=X
QUIT
End DoDot:1
+4 QUIT IENS
+5 ;
TOP(TARGROOT) ; Move to the top the returned DIQ array
+1 ; Move array(file,iens,field)=value to array(field)=value
+2 ; also moves the ,field,"I") =value(internal) to (field)=value(internal)
+3 if '$DATA(@TARGROOT)
QUIT
+4 NEW FILE,IENS,FLD
+5 SET FILE=$ORDER(@TARGROOT@(""))
+6 SET IENS=$ORDER(@TARGROOT@(FILE,""))
+7 SET FLD=+$ORDER(@TARGROOT@(FILE,IENS,""))
+8 MERGE ^TMP($JOB,"TOP")=@TARGROOT@(FILE,IENS)
+9 KILL @TARGROOT
+10 MERGE @TARGROOT=^TMP($JOB,"TOP")
+11 KILL ^TMP($JOB,"TOP")
+12 ; if form is of xx(FLD,"I") move value to xx(FLD)
+13 IF $ORDER(@TARGROOT@(FLD,""))="I"
Begin DoDot:1
+14 SET FLD=0
FOR
SET FLD=$ORDER(@TARGROOT@(FLD))
if FLD'>0
QUIT
Begin DoDot:2
+15 SET @TARGROOT@(FLD)=@TARGROOT@(FLD,"I")
KILL @TARGROOT@(FLD,"I")
End DoDot:2
End DoDot:1
+16 QUIT
+17 ;
PIECE(REC,DLM,XX) ; where XX = VAR_U_I ex: XX="PATNM^1"
+1 ; Set VAR = piece I of REC using delimiter DLM
+2 NEW Y,I
SET Y=$PIECE(XX,U)
SET I=$PIECE(XX,U,2)
SET @Y=$PIECE(REC,DLM,I)
+3 QUIT
SET(REC,DLM,ABCD) ; where XX = VAR_U_I ex: XX="PATNM^1"
+1 ; Set VAR into piece I of REC using delimiter DLM
+2 NEW Y,I
SET Y=$PIECE(ABCD,U)
SET I=$PIECE(ABCD,U,2)
+3 IF Y'=+Y
IF Y'=""
SET $PIECE(REC,DLM,I)=$GET(@Y)
IF 1
+4 IF '$TEST
SET $PIECE(REC,DLM,I)=Y
