Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSJPDCLU

PSJPDCLU.m

Go to the documentation of this file.
  1. PSJPDCLU ;BIR/MHA/MC - PADE ORDER ; 11/18/19 1:17pm
  1. ;;5.0;INPATIENT MEDICATIONS;**317,337,395,405,364,432,438**;16 DEC 97;Build 4
  1. ;Reference to ^PS(50.7 supported by DBIA 2180
  1. ;Reference to ^PS(50.606 supported by DBIA 2174
  1. ;Reference to ^PS(50.607 supported by DBIA 2221
  1. ;Reference to ^PS(51.2 supported by DBIA 2178
  1. ;Reference to ^PS(52.6 supported by DBIA 1231
  1. ;Reference to ^PS(52.7 supported by DBIA 2173
  1. ;Reference to ^PSDRUG supported by DBIA 2192
  1. ;Reference to $$PROD2^PSNAPIS supported by DBIA 2531
  1. ;Reference to ^ORD(101 supported by DBIA #872
  1. ;Reference to ^DIC(42 supported by DBIA 10039
  1. ;Reference to ^SC supported by DBIA 10040
  1. ;Reference to EN^VAFCPID supported by DBIA 3015
  1. ;Reference to EN^VAFHLEVN supported by DBIA 3016
  1. ;Reference to $$PIVCHK^VAFHPIVT supported by DBIA 6606
  1. Q
  1. ;
  1. PDORD(RESNDCLN) ;
  1. ; RESNDCLN=Specific Clinic IEN to be sent
  1. Q:'$P($$SEND^VAFHUTL(),"^",2)
  1. Q:$O(^PS(58.7,"B",""))=""
  1. N I,J,PSJAP,PSJQ,PSJBAP,PSJFTSH,PSJWARDH,PSJRBDH S (PSJAP,I)=0
  1. F S I=$O(^PS(58.7,I)) Q:'I S J=$$PDACT^PSJPDCLA(I)
  1. Q:'PSJAP
  1. M PSJBAP=PSJAP
  1. N SNM,CNM S SNM="PSJ RDEO11 SERVER"
  1. Q:'$O(^ORD(101,"B",SNM,0))
  1. S CNM="PSJ RDEO11 CLIENT"
  1. Q:'$O(^ORD(101,"B",CNM,0))
  1. N HL,NSEG,SEQ,SEG,NFS,NECH,NSCS D INIT^HLFNC2(SNM,.HL) Q:$D(HL)=1
  1. S NFS=HL("FS"),NECH=$E(HL("ECH"),1),NSCS=$E(HL("ECH"),4)
  1. N CLN,CLAPDT,PSJWARD,DFN,I,PSJRBD,ADMDT,PIVOT,PV,PSJDIV1,LOC,EVNDT,PDL,FTS,ASIH
  1. S DFN=PSJHLDFN,(CLN,PIVOT,ADMDT,CLAPDT,EVNDT,ASIH)=0,(LOC,PSJWARD,PSJRBD,PV,PSJDIV1,FTS)=""
  1. I RXO["V",$D(^PS(55,DFN,"IV",+RXO,"DSS")) S I=^("DSS") S CLN=$P(I,"^"),CLAPDT=$P(I,"^",2)
  1. I RXO["U",$D(^PS(55,DFN,5,+RXO,8)) S I=^(8) S CLN=$P(I,"^"),CLAPDT=$P(I,"^",2)
  1. I $G(RESNDCLN) Q:$G(RESNDCLN)'=$G(CLN)
  1. N PSJQ,PSJQ2,PSJQCL,PSJPDON,VAIP,VAIN,PSJPDO,SETZ S (PSJQ,PSJQ2,SETZ)="",PSJPDO=0
  1. D IN5^VADPT
  1. I ($P($G(VAIP(13,3)),"^",2)["ASIH")!($P($G(VAIP(14,3)),"^",2)["ASIH") S ASIH=1
  1. I (VAIP(5)="")&($G(DGPMTYP)=6)&($G(DGPMP)'="")&($G(DGPMA)="")&($D(DGPMVI)) D
  1. . M VAIP=DGPMVI
  1. I VAIP(5)!$G(PSJDCA) D
  1. . I $G(ASIH)&$G(PSJDCA) S PIVOT=$$PIVOT^PSJPDCLA(DFN,$G(RXO),.PSJWARDH,.PSJRBDH,.PSJFTSH) D
  1. .. S:$G(PSJWARDH)]"" PSJWARD=PSJWARDH
  1. .. S:$G(PSJRBDH)]"" PSJRBD=PSJRBDH
  1. .. S:$G(PSJFTSH)]"" FTS=PSJFTSH
  1. . Q:$G(PIVOT)&$G(ASIH)
  1. . I VAIP(5)="" S VAIP("D")="L" D IN5^VADPT
  1. . S I=+VAIP(5),PSJWARD=$P(VAIP(5),"^",2),PSJRBD=$P(VAIP(6),"^",2),ADMDT=+VAIP(13,1),EVNDT=+VAIP(3)
  1. . S FTS=$P(VAIP(8),"^")_NECH_$P(VAIP(8),"^",2)
  1. . S PSJDIV1=+$P($G(^DIC(42,I,0)),"^",11)
  1. . S PIVOT=+$$PIVCHK^VAFHPIVT(DFN,ADMDT,1,VAIP(13)_";DGPM(")
  1. . I PIVOT<0 D ; Still no pivot - try to find admission linked to order login date
  1. .. S PIVOT=$$PIVOT^PSJPDCLA(DFN,$G(RXO),.PSJWARDH,.PSJRBDH,.PSJFTSH)
  1. . I PIVOT<0 D ; STILL no pivot - check PADE OUTBOUND MESSAGES (#58.72) log file
  1. .. S PIVOT=$$LOGPIVOT^PSJPDCLA(DFN,$G(RXO))
  1. I PSJWARD'="",CLN,CLAPDT D Q:'PSJQ S SETZ="IC" G CORD
  1. . S PSJQ=$$CHKPD^PSJPDCL(PSJWARD,PSJRBD) S:'PSJQ PIVOT=0
  1. . I PSJQ M PSJQ2=PSJQ K PSJQ
  1. . M PSJAP=PSJBAP S PSJPDO=1
  1. . S PSJQ=$$CHKPDCL^PSJPDCLA(CLN) Q:'PSJQ
  1. . S PV="CLN"
  1. I PSJWARD'="" D Q:'PSJQ G CORD
  1. . S PSJPDO=1,PSJQ=$$CHKPD^PSJPDCL(PSJWARD,PSJRBD)
  1. . Q:'PSJQ
  1. . S PV="WARD",SETZ="I"
  1. I CLN S PSJDIV1=+$P($G(^SC(CLN,0)),"^",15) D Q:'PSJQ M PSJQ2=PSJQ S SETZ="C"
  1. . S PSJPDO=1,PSJQ=$$CHKPDCL^PSJPDCLA(CLN) Q:'PSJQ
  1. . S PV="CLN"
  1. CORD ;
  1. ;*364 Moving to another routine due to SACC max limit.
  1. D CORD^PSJPDCLV
  1. Q
  1. ;
  1. SEND ;
  1. ;*364 Moving to another routine due to SACC max limit.
  1. D SEND^PSJPDCLV
  1. Q
  1. ;
  1. PID ;
  1. N VAFSTR
  1. S VAFSTR="1,2,3,4,5,6,7,8,9,19"
  1. N VAFPID,M
  1. S VAFPID=$$EN^VAFCPID(DFN,VAFSTR)
  1. S SEQ=SEQ+1
  1. S NSEG(SEQ)=$TR(VAFPID,"""""","")
  1. Q
  1. ;
  1. PV1 ;
  1. N PV1,VAIP
  1. I PV="WARD" D
  1. .S VAFSTR=",2,3,7,10,18,21,39,44,45"
  1. .S PV1=$$IN^VAFHLPV1(DFN,"",VAFSTR,"","",1,"")
  1. .I $G(PSJWARDH)]"" S $P(PV1,NFS,4)=PSJWARDH_NECH_$TR($P($G(PSJRBDH),"-",1,2),"-",NECH)
  1. .S:$P(PV1,NFS,4)="" $P(PV1,NFS,4)=PSJWARD_NECH_$TR($P(PSJRBD,"-",1,2),"-",NECH)
  1. .S SEG=PV1
  1. I PV="CLN" D
  1. .I PSJWARD'="",PIVOT S VAFSTR=",2,3,7,10,18,21,39,44,45"
  1. .E S VAFSTR=""
  1. .S PV1=$$IN^VAFHLPV1(DFN,EVNDT,VAFSTR,"","",1,"")
  1. .I RXO["U",CLAPDT S $P(PV1,NFS,12)=$P($G(^SC(CLN,0)),"^")_NECH_CLN
  1. .I RXO["V" I (PSJWARD'=""&CLAPDT)!(PSJWARD="") S $P(PV1,NFS,12)=$P($G(^SC(CLN,0)),"^")_NECH_CLN
  1. .S SEG=PV1
  1. S:$G(PIVOT)>0 $P(SEG,NFS,51)=PIVOT
  1. S:$P(PV1,NFS,4)="" $P(SEG,NFS,3)="O"
  1. S SEQ=SEQ+1
  1. S NSEG(SEQ)=$TR(SEG,"""""","")
  1. S:$G(PSJDIV1) $P(NSEG(SEQ),NFS,40)=$P($$SITE^VASITE(,PSJDIV1),"^",3)
  1. Q
  1. ;
  1. ORC ;
  1. S SEG="ORC"
  1. S STATUS=$S(RXO["U":$P(PS55(0),"^",9),1:$P(PS55(0),"^",17))
  1. S:$G(PSJEXPOE) STATUS="E"
  1. S ($P(SEG,NFS,2),PDL(15))=$S(STATUS="A"&((PDTYP="SN")!(PDTYP="SC")):"NW",PDTYP="OH":"OH",PDTYP="OE":"RL",PDTYP="OD"!($E(STATUS)="D")!(STATUS="E"):"DC",1:"XX")
  1. S $P(SEG,NFS,3)=+$P(PS55(0),"^",21)
  1. S ($P(SEG,NFS,4),PDL(2))=RXO
  1. S $P(SEG,NFS,6)=$S($E(STATUS)="D":"DC",STATUS="E":"ZE",(STATUS="H"!($G(PDTYP)="OH")):"HD",1:"CM")
  1. S VAR1="",VAR2=$S(RXO["U":$P(PS55(0),"^",25),1:$P(PS55(2),"^",5))
  1. D:VAR2
  1. .I RXO["U" S VAR1=$P($G(^PS(55,DFN,5,+VAR2,0)),"^",21)_NECH_VAR2
  1. .I RXO["V" S VAR1=$P($G(^PS(55,DFN,"IV",+VAR2,0)),"^",21)_NECH_VAR2
  1. S $P(SEG,NFS,9)=VAR1
  1. S $P(SEG,NFS,10)=+$$HLDATE^HLFNC($S(RXO["U":$P(PS55(0),"^",16),1:$P(PS55(2),"^")))
  1. S VAR1=$S(RXO["U":$P(PS55(4),"^",7),1:$P(PS55(2),"^",11))
  1. D:VAR1
  1. .S VAR2=$P($G(^VA(200,VAR1,0)),"^")
  1. .S:VAR2]"" VAR2=$$HLNAME^XLFNAME(VAR2,"",NECH)
  1. .S ($P(SEG,NFS,11),$P(SEG,NFS,20))=VAR1_NECH_VAR2
  1. S VAR1=$S(RXO["U":$P($G(PS55(4)),"^",3),1:$P($G(PS55(4)),"^",4))
  1. S:VAR1="" VAR1=+$G(DUZ)
  1. D:VAR1
  1. .S VAR2=$P($G(^VA(200,+VAR1,0)),"^")
  1. .S:VAR2]"" VAR2=$$HLNAME^XLFNAME(VAR2,"",NECH)
  1. .S $P(SEG,NFS,12)=VAR1_NECH_VAR2
  1. S VAR1=$S(RXO["U":$P(PS55(0),"^",2),1:$P($G(PS55(0)),"^",6))
  1. D:VAR1
  1. .S VAR2=$P($G(^VA(200,+VAR1,0)),"^")
  1. .S:VAR2]"" VAR2=$$HLNAME^XLFNAME(VAR2,"",NECH)
  1. .S $P(SEG,NFS,13)=VAR1_NECH_VAR2
  1. S VAR1=$P(SEG,NFS,2)
  1. S VAR2=$S(VAR1="NW":"NEW",VAR1="DC":"DISCONTINUE",VAR1="HD":"HOLD",VAR1="OH":"HOLD",VAR1="RL":"RELEASED HOLD",VAR1="XX":"CHANGE",1:"UNKNOWN")
  1. S $P(SEG,NFS,17)=VAR2
  1. I $G(PSJDMU) S VAR1=+$G(DUZ) D:VAR1
  1. .S VAR2=$P($G(^VA(200,VAR1,0)),"^") S:VAR2]"" VAR2=$$HLNAME^XLFNAME(VAR2,"",NECH)
  1. .S $P(SEG,NFS,20)=VAR1_NFS_VAR2
  1. S SEQ=SEQ+1
  1. S NSEG(SEQ)=SEG
  1. D:$D(^XTMP("PADE")) DISP
  1. Q
  1. ;
  1. RXE ;
  1. N DOSE
  1. S SEG="RXE"
  1. I RXO["V" D IVRXE Q
  1. S $P(SEG,NFS,2)=$$QT(DFN,RXO,.PS55)
  1. S $P(SEG,NFS,3)=$$GIVECODE(+$$DSPDRG,NECH)
  1. N DOSETMP,MIN,MAX
  1. S DOSE=$TR($P(PS55(.2),"^",2),","),MIN=+DOSE
  1. S DOSETMP=$TR(DOSE," ")
  1. I DOSETMP["-" S MIN=+$P(DOSETMP,"-"),MAX=$P(DOSETMP,"-",2,99)
  1. S $P(SEG,NFS,4)=$S(MIN:MIN,1:"")
  1. S $P(SEG,NFS,5)=$S($G(MAX):+$G(MAX),1:"")
  1. I '$G(MAX),$G(MIN),+$TR($P($G(DOSE),MIN,2,99)," ") D
  1. . S $P(SEG,NFS,6)=DOSE
  1. E D
  1. . S DOSETMP=$S($G(MAX):$P(DOSE,+MAX,2,99),$G(MIN):$P($G(DOSE),MIN,2,99),1:DOSE)
  1. . I $E(DOSETMP)=" " S DOSETMP=$E(DOSETMP,2,$L(DOSETMP))
  1. . S $P(SEG,NFS,6)=DOSETMP
  1. S VAR1=$$GETFORM(.PS55)
  1. S $P(SEG,NFS,7)=VAR1
  1. N PCE S PCE=""
  1. I $D(PS55(15)) D
  1. .N PC,I S I=0,PC="" F S I=$O(PS55(15,I)) Q:'I D
  1. ..I PCE]"" S PCE=PCE_$TR(PS55(15,I,0),"|","/") Q
  1. ..S PC=PC_$TR(PS55(15,I,0),"|","/")
  1. ..I $L(PC)>200 S PCE=$E(PC,201,999)_" ",PC=$E(PC,1,200)
  1. .S $P(SEG,NFS,22)=PC
  1. S $P(SEG,NFS,11)=$P($$DSPDRG,"^",2)
  1. S VAR1=+$P(PS55(0),"^",2),VAR2=$P($G(^VA(200,VAR1,0)),"^") S:VAR2]"" VAR2=$$HLNAME^XLFNAME(VAR2,"",NECH),VAR1=$$DEA^XUSER(,VAR1)
  1. S $P(SEG,NFS,14)=VAR1_NECH_VAR2
  1. S VAR1=$P($G(PS55(4)),"^",3),VAR2="" I VAR1 S VAR2=$P($G(^VA(200,+VAR1,0)),"^") S VAR2=$$HLNAME^XLFNAME(VAR2,"",NECH)
  1. S $P(SEG,NFS,15)=VAR1_NECH_VAR2
  1. S $P(SEG,NFS,16)=RXO
  1. S SEQ=SEQ+1
  1. S NSEG(SEQ)=SEG
  1. I $O(SEG(0)) S I=0 F S I=$O(SEG(I)) Q:'I S NSEG(SEQ,I)=SEG(I)
  1. I $G(PCE)]"" D
  1. .S SEQ=SEQ+1
  1. .S NSEG(SEQ)="NTE"_NFS_NFS_NFS_PCE
  1. D:$D(^XTMP("PADE")) DISP
  1. K SEG
  1. Q
  1. ;
  1. IVRXE ;
  1. N ND0,NDPT2,NDAD,NDSOL,PCE S PCE=""
  1. S ND0=PS55(0),NDPT2=PS55(.2),NDAD=$G(PS55("AD",1,0)),NDSOL=$G(PS55("SOL",1,0))
  1. S $P(SEG,NFS,2)=$$QT(DFN,RXO,.PS55)
  1. S $P(SEG,NFS,3)=$$GIVECODE($S(NDAD:$P(^PS(52.6,+NDAD,0),"^",2),1:$P(^PS(52.7,+NDSOL,0),"^",2)),NECH)
  1. S $P(SEG,NFS,4)=+$$QT(DFN,RXO,.PS55)
  1. S $P(SEG,NFS,6)=$TR($P($G(DOSE),+DOSE,2,9)," ")
  1. S VAR1=+$G(PS55("AD",1,0)),VAR1=+$P($G(^PS(52.6,VAR1,0)),"^",11),VAR1=+$P($G(^PS(50.7,VAR1,0)),"^",2),VAR1=$G(^PS(50.606,VAR1,0))
  1. S $P(SEG,NFS,7)=VAR1
  1. I $D(PS55(10)) D
  1. .N PC,I S I=0,PC="" F S I=$O(PS55(10,I)) Q:'I D
  1. ..I PCE]"" S PCE=PCE_$TR(PS55(10,I,0),"|","/") Q
  1. ..S PC=PC_$TR(PS55(10,I,0),"|","/")
  1. ..I $L(PC)>200 S PCE=$E(PC,201,999)_" ",PC=$E(PC,1,200)
  1. .S $P(SEG,NFS,22)=PC
  1. S $P(SEG,NFS,11)=1
  1. S $P(SEG,NFS,12)="BAG"
  1. S VAR1=+$P(PS55(0),"^",6)
  1. D:VAR1
  1. . S VAR2=$P($G(^VA(200,VAR1,0)),"^") S:VAR2]"" VAR2=$$HLNAME^XLFNAME(VAR2,"",NECH)
  1. . S VAR1=$$DEA^XUSER(,VAR1)
  1. . S $P(SEG,NFS,14)=VAR1_NECH_VAR2
  1. S VAR1=$P($G(PS55(4)),"^",4)
  1. D:VAR1
  1. .S VAR2=$P($G(^VA(200,+VAR1,0)),"^") S:VAR2]"" VAR2=$$HLNAME^XLFNAME(VAR2,"",NECH)
  1. .S $P(SEG,NFS,15)=VAR1_NECH_VAR2
  1. S $P(SEG,NFS,16)=RXO
  1. I $P(PS55(0),"^",15)'="" S $P(SEG,NFS,23)="M"_$P(PS55(0),"^",15)
  1. S VAR1=$P(PS55(0),"^",8),VAR2=$P(VAR1,+VAR1,2),VAR1=+VAR1
  1. I $E(VAR2)=" " S VAR2=$P(VAR2," ",2)
  1. I (VAR2="")!(VAR1=0),$P(PS55(0),"^",8)'="" S VAR2=$P(PS55(0),"^",8)
  1. S $P(SEG,NFS,24)=$S(VAR1=0:"",1:VAR1)
  1. S $P(SEG,NFS,25)=NECH_VAR2
  1. S VAR1=$P($G(PS55("AD",1,0)),"^",2),VAR2=$P(VAR1,+VAR1,2)
  1. I $E(VAR2)=" " S VAR2=$P(VAR2," ",2,99)
  1. I VAR2="" S VAR1=$P($G(PS55("SOL",1,0)),"^",2),VAR2=$P(VAR1,+VAR1,2)
  1. I $E(VAR2)=" " S VAR2=$P(VAR2," ",2,99)
  1. S $P(SEG,NFS,26)=+VAR1
  1. D CONT(VAR2,27,NFS)
  1. IVC ;
  1. S SEQ=SEQ+1
  1. S NSEG(SEQ)=SEG
  1. I $O(SEG(0)) S I=0 F S I=$O(SEG(I)) Q:'I S NSEG(SEQ,I)=SEG(I)
  1. I $G(PCE)]"" D
  1. .S SEQ=SEQ+1
  1. .S NSEG(SEQ)="NTE"_NFS_NFS_NFS_PCE
  1. D:$D(^XTMP("PADE")) DISP
  1. K SEG
  1. Q
  1. ;
  1. CONT(VALUE,PIECE,FS) ;
  1. N TEMP,TEMP2,NODES,STRING,BEG,END,REM
  1. I $L(SEG)+$L(VALUE)<246 S $P(SEG,FS,PIECE)=VALUE Q
  1. S TEMP=SEG_FS_VALUE
  1. S SEG=$E(TEMP,1,245)
  1. S STRING=$E(TEMP,246,$L(TEMP)),NODES=$L(STRING)\245,REM=$L(STRING)#245,BEG=1,END=245 I REM S NODES=NODES+1
  1. F TEMP2=1:1:NODES S SEG(TEMP2)=$E(STRING,BEG,END) S BEG=BEG+245,END=END+245
  1. Q
  1. ;
  1. RXR ;
  1. S SEG="RXR"
  1. S VAR1=$S(RXO["U":$P(PS55(0),"^",3),1:$P(PS55(.2),"^",3))
  1. S VAR1=$G(^PS(51.2,+VAR1,0)) S VAR2=$P(VAR1,"^"),VAR1=$P(VAR1,"^",3)
  1. S $P(SEG,NFS,2)=VAR1_NECH_VAR2_NECH_"99PSR"
  1. S SEQ=SEQ+1
  1. S NSEG(SEQ)=SEG
  1. D:$D(^XTMP("PADE")) DISP
  1. Q
  1. ;
  1. RXC ;
  1. D RXC^PSJPADE
  1. Q
  1. ;
  1. IVRXC ;
  1. N D,X,PSJDD,PSJADSO,FIL
  1. F PSJADSO="SOL","AD" S D=0 F S D=$O(PS55(PSJADSO,D)) Q:'D S PSJDD=$P(PS55(PSJADSO,D,0),"^") D
  1. .Q:'PSJDD
  1. .S FIL=$S(PSJADSO="AD":52.6,1:52.7) S PSJDD=^PS(FIL,PSJDD,0),PSJDD=$P(PSJDD,"^",2)
  1. .S SEG="RXC"_NFS_$S(PSJADSO="AD":"A",1:"B")
  1. .S $P(SEG,NFS,3)=$$GIVECODE(PSJDD,NECH)
  1. .S VAR1=$P(PS55(PSJADSO,D,0),"^",2),VAR2=$P(VAR1,+VAR1,2)
  1. .S:$E(VAR2)=" " VAR2=$P(VAR2," ",2)
  1. .S $P(SEG,NFS,4)=+VAR1
  1. .S $P(SEG,NFS,5)=NECH_VAR2
  1. .S VAR1=$G(^PSDRUG(PSJDD,"DOS")),X=+$P(VAR1,"^",2)
  1. .I X S VAR2=$P($G(^PS(50.607,X,0)),"^") S VAR2=X_NECH_VAR2_NECH_"99PSU"
  1. .I VAR1 S $P(SEG,NFS,6)=+VAR1,$P(SEG,NFS,7)=VAR2
  1. .S SEQ=SEQ+1
  1. .S NSEG(SEQ)=SEG
  1. .D:$D(^XTMP("PADE")) DISP
  1. Q
  1. ;
  1. ZRX ;
  1. S STATUS=$S(RXO["U":$P(PS55(0),"^",9),1:$P(PS55(0),"^",17))
  1. S VAR1=$S($G(PDTYP)="SN":"N",STATUS["E"!(STATUS["D"):"O",1:"F")
  1. S SEG="ZRX"_NFS_VAR1_NFS_+PDHDT
  1. S SEQ=SEQ+1
  1. S NSEG(SEQ)=SEG
  1. D:$D(^XTMP("PADE")) DISP
  1. Q
  1. ;
  1. GETFORM(PSJ55) ;
  1. N X
  1. S X=+$P($G(^PSDRUG(+$$DSPDRG,2)),"^")
  1. I X S X=+$P($G(^PS(50.7,X,0)),"^",2),VAR1=$P($G(^PS(50.606,X,0)),"^")
  1. I VAR1="" S VAR1=$P($G(^PSDRUG(+$$DSPDRG,660)),"^",8)
  1. I VAR1="" S X=$P($G(^PSDRUG(+$$DSPDRG,"ND")),"^",3) S:X VAR1=$P($$PROD2^PSNAPIS(,X),"^",4)
  1. Q VAR1
  1. ;
  1. QT(DFN,RXO,PS55) ;
  1. S VAR1=""
  1. I RXO["U" D Q VAR1
  1. .S DOSE=$TR($P($G(PS55(.2)),"^",2),",")
  1. .N AT,NAT S AT=$TR($P(PS55(2),"^",5),"-",","),NAT=""
  1. .I AT N I,J F I=1:1:$L(AT,",") S J=$P(AT,",",I) D
  1. ..S J=$S($L(J)=2:J_"00",1:J)
  1. ..S $P(NAT,",",I)=J
  1. .S VAR1=+DOSE_NECH_$$ESC($P(PS55(2),"^"))_NSCS_NAT_NECH_NECH
  1. .S VAR1=VAR1_+$$HLDATE^HLFNC($P(PS55(2),"^",2),"TS")_NECH_+$$HLDATE^HLFNC($P(PS55(2),"^",4),"TS")_NECH
  1. .S VAR2=$$PRNOK^PSGS0($P(PS55(2),"^"))
  1. .S VAR1=VAR1_NECH_VAR2_NECH_$$DOWSTR^PSJPDCLV($P(PS55(2),"^"))
  1. I RXO["V" D Q VAR1
  1. .S ND0=PS55(0),NDPT2=PS55(.2),NDAD=$G(PS55("AD",1,0)),NDSOL=$G(PS55("SOL",1,0))
  1. .S DOSE=$P($G(PS55("AD",1,0)),"^",2) S VAR2=$TR($P(DOSE,+DOSE,2,9)," ")
  1. .I VAR2="" S DOSE=$P($G(PS55("SOL",1,0)),"^",2) S VAR2=$TR($P(DOSE,+DOSE,2,9)," ")
  1. .N AT,NAT S AT=$TR($P(PS55(0),"^",11),"-",","),NAT=""
  1. .I AT N I,J F I=1:1:$L(AT,",") S J=$P(AT,",",I) D
  1. ..S J=$S($L(J)=2:J_"00",1:J)
  1. ..S $P(NAT,",",I)=J
  1. .S VAR1=+DOSE_NSCS_VAR2_NECH_$S(($P(PS55(0),"^",9)]""):$P(PS55(0),"^",9),1:"C")_NSCS_NAT_NECH_NECH
  1. .S VAR1=VAR1_+$$HLDATE^HLFNC($P(PS55(0),"^",2))_NECH_+$$HLDATE^HLFNC($P(PS55(0),"^",3))
  1. .S VAR2=$$PRNOK^PSGS0($P(PS55(2),"^"))
  1. .N VAR3 S VAR3=$P(PS55(.2),"^",4) ;p438 priority
  1. .S VAR1=VAR1_NECH_NECH_VAR2_NECH_$$DOWSTR^PSJPDCLV($P(PS55(0),"^",9))_NECH_VAR3 ;p438 appended priority
  1. Q
  1. ;
  1. DSPDRG() ;
  1. N I,J S I=0,J=999999
  1. F S J=$O(PS55(1,J),-1) Q:J=0 D Q:I
  1. . I $P(PS55(1,J,0),"^",3),$P(PS55(1,J,0),"^",3)'>DT Q ;inactive drug
  1. . S I=J
  1. S:'I I=1
  1. Q $G(PS55(1,I,0))
  1. ;
  1. GIVECODE(ID,CS) ;
  1. N DRGID,DRGNM,DRGNM2,DRGSTR,DRUGND
  1. Q:'$D(^PSDRUG(ID)) ""
  1. S DRUGND=$G(^PSDRUG(ID,"ND"))
  1. S DRGNM=$$ESC($P($G(^PSDRUG(ID,0)),"^")),PDL(14)=ID
  1. S DRGSTR=ID_CS_DRGNM_CS_"99PSD"
  1. S DRGNM2=$$ESC($P(DRUGND,"^",2))
  1. S DRGID=$P(DRUGND,"^",3)
  1. S DRGSTR=DRGSTR_CS_DRGID_CS_DRGNM2_CS_"99PSP"
  1. Q DRGSTR
  1. ;
  1. DISP ;
  1. Q:'$D(^XUSEC("PSJ PADE MGR",DUZ))
  1. D FULL^VALM1
  1. W !!,?5,"THIS IS THE PADE "_$P(NSEG(SEQ),NFS)_" SEGMENT."
  1. N TR,TX F TR=1:1:$L(NSEG(SEQ),NFS) S TX=$P(NSEG(SEQ),NFS,TR) W !,$P(NSEG(SEQ),NFS)_"-"_(TR-1)_$S(TR<10:"= ",1:"=")_TX
  1. D PAUSE^VALM1
  1. Q
  1. ;
  1. ESC(VAL) ;
  1. N NVAL
  1. S NVAL="" F I=1:1:$L(VAL) S NVAL=NVAL_$S($E(VAL,I)="&":"\T\",1:$E(VAL,I))
  1. Q NVAL