source: FOIAVistA/trunk/r/CMOP-PSX/PSXUTL.m@ 1446

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