- 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 Jan 18, 2025@02:46:37 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