PSONVNEW ;BIR/SAB - Add Non-VA Med orders ;29-May-2012 14:56;PLS
;;7.0;OUTPATIENT PHARMACY;**132,1009,118,203,265,1015**;DEC 1997;Build 62
;External reference ^PS(50.606 supported by DBIA 2174
;External reference ^PS(50.7 supported by DBIA 2223
;External reference ^PS(55 supported by DBIA 2228
;External reference to ^PS(51.2 supported by DBIA 2226
;adds new non-va med to #55
;
;*203 change 3 fields from "///" to "////" they can be larger than
; defined and need to be put in as is to prevent hard crash.
;*265 change update of Dosage & Sched fields DR strings, can contain ; free form char ";"
;Modified - IHS/MSC/PLS - 08/30/2010 - Line REIN+17, Added +32, STATU EP
;
I '$D(^PS(55,DFN,0)) D
.K DD,DO S DIC(0)="L",(DINUM,X)=DFN,DIC("DR")="52.1////2" D FILE^DICN D:Y<1 K DIC,DA,DR,DD,DO
..S $P(^PS(55,DFN,0),"^")=DFN,$P(^(0),"^",6)=2
..K DIK S DA=DFN,DIK="^PS(55,",DIK(1)=.01 D EN^DIK K DIK
;
N PSONVA,DSC K PCOM
F I=0:0 S I=$O(MSG(I)) Q:'I D
.I $P(MSG(I),"|")="NTE",$P(MSG(I),"|",2)=6 S DSC=$G(DSC)+1 S PCOM(DSC)=$P(MSG(I),"|",4) F T=0:0 S T=$O(MSG(I,T)) Q:'T S DSC=DSC+1,PCOM(DSC)=MSG(I,T)
.I $P(MSG(I),"|")="ORC" S STDT=$P(MSG(I),"|",8),STRDT=$$HL7TFM^XLFDT($P(STDT,"^",4))
;
; - Files the Non-VA Med order into the "NVA" multiple in File #55
K DR,DIC,DD,DA,DO,DINUM S DA(1)=DFN,X=PSORDITE
;*203,*265 fix DR & dose & sched fields
S PSODOS=$G(PSOLQ1I(1)),PSOSCH=$$SCHED($P($G(QTARRAY(1)),"^"))
S DR="1////"_PSODDRUG_";2////^S X=PSODOS;3////"_$$ROUTE($G(ROUTE(1)))
S DR=DR_";4////^S X=PSOSCH;7////"_$G(PLACER)_";8///"_$G(STRDT)
S DR=DR_";11///"_$G(PSOLOG)_";12////"_$G(ENTERED)_";13////"_$G(LOCATION)
; IHS/MSC/REC/PLS - Add MED REC Fields 8/30/10
S DR=DR_";21401///"_$G(MSCLD)_";21402///"_$G(MSCHMLST)_";21403///"_$G(MSCHMLOC)
S DIC("DR")=DR,DIC(0)="L",DIC="^PS(55,"_DFN_",""NVA"",",DLAYGO=55.05
D FILE^DICN S PSONVA=+Y K DR,DIC,DD,DA,DO,DINUM
K PSODOS,PSOSCH
;
K DSC,STDT
I $P(PSODSC,"^",2)]"" D
.S DSC=1,^PS(55,DFN,"NVA",PSONVA,"DSC",1,0)=$P(PSODSC,"^",2)
.S ^PS(55,DFN,"NVA",PSONVA,"DSC",0)="^55.052^1^1^"_DT_"^^^^"
I $O(PSODSC(0)) D
.F T=0:0 S T=$O(PSODSC(T)) Q:'T S DSC=$G(DSC)+1,^PS(55,DFN,"NVA",PSONVA,"DSC",DSC,0)=PSODSC(T)
.S ^PS(55,DFN,"NVA",PSONVA,"DSC",0)="^55.052^"_DSC_"^"_DSC_"^"_DT_"^^^^"
I $O(PCOM(0)) F T=0:0 S T=$O(PCOM(T)) Q:'T D
.S DSC=$G(DSC)+1,^PS(55,DFN,"NVA",PSONVA,"DSC",DSC,0)=PCOM(T)
.S ^PS(55,DFN,"NVA",PSONVA,"DSC",0)="^55.052^"_DSC_"^"_DSC_"^"_DT_"^^^^"
.S ^PS(55,DFN,"NVA",PSONVA,1,T,0)=PCOM(T)
.S ^PS(55,DFN,"NVA",PSONVA,1,0)="^^"_T_"^"_T_"^"_DT_"^"
I $G(OCOUNT) S ^PS(55,DFN,"NVA",PSONVA,"OCK",0)="^55.051^"_OCOUNT_"^"_OCOUNT F OCOUNT=1:1:OCOUNT D
.S ^PS(55,DFN,"NVA",PSONVA,"OCK",OCOUNT,0)=$G(OBXAR(OCOUNT,1))_"^"_PROV
.I $G(OBXAR(OCOUNT,1))]"" S ^PS(55,DFN,"NVA",PSONVA,"OCK","B",$E(OBXAR(OCOUNT,1),1,30),OCOUNT)=""
.S PSOBCT=1 F LLL=2:1 Q:'$D(OBXAR(OCOUNT,LLL)) S ^PS(55,DFN,"NVA",PSONVA,"OCK",OCOUNT,"OVR",1,0)=OBXAR(OCOUNT,LLL)
;IHS/MSC/REC/PLS - 08/06/2010 - Add Med Rec fields
I $D(^PS(55,DFN,"NVA",PSONVA,0)) D
.S ^PS(55,DFN,"NVA",PSONVA,21400)=$G(MSCLD)_U_$G(MSCHMLST)_U_$G(MSCHMLOC)
.I $O(MSCRSN(0)) D
..N T,MSCR
..S T=0 F S T=$O(MSCRSN(0)) Q:'T D
...S MSCR=$G(MSCR)+1
...S ^PS(55,DFN,"NVA",PSONVA,21401,MSCR,0)=MSCRSN(T)
...K MSCRSN(T)
..S ^PS(55,DFN,"NVA",PSONVA,21401,0)="^55.521404^"_MSCR_U_MSCR_U_DT_"^^^^"
K MSCLD,MSCHMLST,MSCHMLOC,MSCRSN
K HOLD,SCH,SCHED,SDL,SGL,A,W,WW,CHR,STRDT
;
M PMSG=MSG
REIN K MSG S NULLFLDS="F JJ=0:1:LIMIT S FIELD(JJ)="""""
K ^UTILITY("DIQ1",$J),DIQ S DA=$P($$SITE^VASITE(),"^")
I $G(DA) S DIC=4,DIQ(0)="I",DR="99" D EN^DIQ1 S PSOHINST=$G(^UTILITY("DIQ1",$J,4,DA,99,"I")) K ^UTILITY("DIQ1",$J),DA,DR,DIQ,DIC
S MSG(1)="MSH|^~\&|PHARMACY|"_$G(PSOHINST)_"|||||ORR"
;
S COUNT=1,LIMIT=5 X NULLFLDS D DEM^VADPT S NAME=$G(VADM(1)) K VADM
S FIELD(0)="PID",FIELD(3)=DFN,FIELD(5)=NAME
D SEG^PSOHLSN1
;
;
S LIMIT=19 X NULLFLDS
S FIELD(0)="PV1",FIELD(2)="O",FIELD(3)=LOCATION
D SEG^PSOHLSN1
;
S LIMIT=15 X NULLFLDS
S FIELD(0)="ORC",FIELD(1)=$S($G(REIN):"SC",1:"OK"),FIELD(2)=PLACER_"^OR",FIELD(3)=PSONVA_"N^PS",FIELD(5)="CM"
S FIELD(10)=$P(^PS(55,DFN,"NVA",PSONVA,0),"^",11)_"^"_$P(^VA(200,$P(^PS(55,DFN,"NVA",PSONVA,0),"^",11),0),"^")
;IHS/MSC/REC/PLS - 08/06/2010 - Change field 5 if there is a status of Reconcile
I +$P(^PS(55,DFN,"NVA",PSONVA,0),U,6)=97 S FIELD(5)="REC"
D SEG^PSOHLSN1
I $G(REIN) S MSG(COUNT)=MSG(COUNT)_"|^^^^DATE OF DEATH DELETED BY MAS.^"
;
S LIMIT=1 X NULLFLDS
S FIELD(0)="RXO",OI=$P(^PS(55,DFN,"NVA",PSONVA,0),"^")
S FIELD(1)="^^^"_OI_"^"_$P($G(^PS(50.7,OI,0)),"^")_" "_$P($G(^PS(50.606,+$P($G(^(0)),"^",2),0)),"^")_"^99PSP"
D SEG^PSOHLSN1
;
S LIMIT=1 X NULLFLDS
S FIELD(0)="RXE"
S PSOPSTRT="",X=$P(^PS(55,DFN,"NVA",PSONVA,0),"^",9) I X S PSOPSTRT=$$FMTHL7^XLFDT(X)
K X S FIELD(1)="^^^"_$G(PSOPSTRT)_"^"
D SEG^PSOHLSN1
;
D SEND^PSOHLSN1 K FIELDS,LIMIT,PSODSC,PSONVA,OI Q:$G(REIN)
;dc change order
DC F OO=0:0 S OO=$O(PMSG(OO)) Q:'OO I $P(PMSG(OO),"|")="ORC",$P(PMSG(OO),"|",2)="XO" D Q
.F XO=0:0 S XO=$O(PMSG(XO)) Q:'XO I $P(PMSG(XO),"|")="ZRX" S POERR("PSOFILNM")=$P(PMSG(XO),"|",2) Q
I +$G(POERR("PSOFILNM")),$G(^PS(55,DFN,"NVA",+$G(POERR("PSOFILNM")),0)) S PDFN=DFN D XO^PSOORUTL
K XO,OO,PMSG
Q
SCHED(SCH) ; Returns the SCHEDULE description
N SCHED,CNT,FND,A,I,K,HOLD
S SCHED="" Q:$G(SCH)="" SCHED
;
F A=0:0 S A=$O(^PS(51.1,"B",SCH,A)) Q:'A D I SCHED'="" Q
. S:$P($G(^PS(51.1,A,0)),"^",8)'="" SCHED=$P($G(^(0)),"^",8)
I SCHED'="" G QSCH
;
I $G(^PS(51,"A",SCH))'="" S SCHED=$P(^PS(51,"A",SCH),"^") G QSCH
;
S CNT=$L(SCH," "),FND=0
F I=1:1:CNT S (WORD,HOLD(I))=$P(SCH," ",I) D
. I WORD="" Q
. F K=0:0 S K=$O(^PS(51.1,"B",WORD,K)) Q:'K D I FND Q
. . I $P($G(^PS(51.1,K,0)),"^",8)'="" D
. . . S HOLD(I)=$P($G(^PS(51.1,K,0)),"^",8),FND=1
. I $G(^PS(51,"A",WORD))]"" S HOLD(I)=$P(^(WORD),"^")
S FND=0 F K=1:1:CNT S SCHED=SCHED_$S($G(FND):" ",1:"")_$G(HOLD(K)),FND=1
;
QSCH Q SCHED
;
ROUTE(RTIEN) ; Returns the ROUTE description
N X
Q:'$G(RTIEN) "" S X=$G(^PS(51.2,RTIEN,0))
Q $S($P(X,"^",2)'="":$P(X,"^",2),1:$P(X,"^"))
;
APSOD ;dc non-va meds because of date of death entry called from psocan3
N PDA,PDFN ;,POERR("PSOFILNM")
F PDA=0:0 S PDA=$O(^PS(55,PSODFN,"NVA",PDA)) Q:'PDA I '$P(^PS(55,PSODFN,"NVA",PDA,0),"^",6),'$P(^(0),"^",7) D
.S POERR("PSOFILNM")=PDA,PDFN=PSODFN D XO^PSOORUTL
;IHS/MSC/REC/PLS - 08/09/10
;Update status based on the dosage form
STATU ;EP - If set to miscellaneous, then the status of the order should be RECONCILE
N MSCPDF
Q:$G(PSORDITE)']"" ;No pharmacy orderable item
S MSCPDF=$P(^PS(50.606,$P(^PS(50.7,PSORDITE,0),U,2),0),U)
I MSCPDF="MISCELLANEOUS" D
.N FDA
.S FDA(55.05,PSONVA_","_DFN_",",5)="RECONCILE"
.D UPDATE^DIE("E","FDA","","")
Q
PSONVNEW ;BIR/SAB - Add Non-VA Med orders ;29-May-2012 14:56;PLS
+1 ;;7.0;OUTPATIENT PHARMACY;**132,1009,118,203,265,1015**;DEC 1997;Build 62
+2 ;External reference ^PS(50.606 supported by DBIA 2174
+3 ;External reference ^PS(50.7 supported by DBIA 2223
+4 ;External reference ^PS(55 supported by DBIA 2228
+5 ;External reference to ^PS(51.2 supported by DBIA 2226
+6 ;adds new non-va med to #55
+7 ;
+8 ;*203 change 3 fields from "///" to "////" they can be larger than
+9 ; defined and need to be put in as is to prevent hard crash.
+10 ;*265 change update of Dosage & Sched fields DR strings, can contain ; free form char ";"
+11 ;Modified - IHS/MSC/PLS - 08/30/2010 - Line REIN+17, Added +32, STATU EP
+12 ;
+13 IF '$DATA(^PS(55,DFN,0))
Begin DoDot:1
+14 KILL DD,DO
SET DIC(0)="L"
SET (DINUM,X)=DFN
SET DIC("DR")="52.1////2"
DO FILE^DICN
IF Y<1
Begin DoDot:2
+15 SET $PIECE(^PS(55,DFN,0),"^")=DFN
SET $PIECE(^(0),"^",6)=2
+16 KILL DIK
SET DA=DFN
SET DIK="^PS(55,"
SET DIK(1)=.01
DO EN^DIK
KILL DIK
End DoDot:2
KILL DIC,DA,DR,DD,DO
End DoDot:1
+17 ;
+18 NEW PSONVA,DSC
KILL PCOM
+19 FOR I=0:0
SET I=$ORDER(MSG(I))
IF 'I
QUIT
Begin DoDot:1
+20 IF $PIECE(MSG(I),"|")="NTE"
IF $PIECE(MSG(I),"|",2)=6
SET DSC=$GET(DSC)+1
SET PCOM(DSC)=$PIECE(MSG(I),"|",4)
FOR T=0:0
SET T=$ORDER(MSG(I,T))
IF 'T
QUIT
SET DSC=DSC+1
SET PCOM(DSC)=MSG(I,T)
+21 IF $PIECE(MSG(I),"|")="ORC"
SET STDT=$PIECE(MSG(I),"|",8)
SET STRDT=$$HL7TFM^XLFDT($PIECE(STDT,"^",4))
End DoDot:1
+22 ;
+23 ; - Files the Non-VA Med order into the "NVA" multiple in File #55
+24 KILL DR,DIC,DD,DA,DO,DINUM
SET DA(1)=DFN
SET X=PSORDITE
+25 ;*203,*265 fix DR & dose & sched fields
+26 SET PSODOS=$GET(PSOLQ1I(1))
SET PSOSCH=$$SCHED($PIECE($GET(QTARRAY(1)),"^"))
+27 SET DR="1////"_PSODDRUG_";2////^S X=PSODOS;3////"_$$ROUTE($GET(ROUTE(1)))
+28 SET DR=DR_";4////^S X=PSOSCH;7////"_$GET(PLACER)_";8///"_$GET(STRDT)
+29 SET DR=DR_";11///"_$GET(PSOLOG)_";12////"_$GET(ENTERED)_";13////"_$GET(LOCATION)
+30 ; IHS/MSC/REC/PLS - Add MED REC Fields 8/30/10
+31 SET DR=DR_";21401///"_$GET(MSCLD)_";21402///"_$GET(MSCHMLST)_";21403///"_$GET(MSCHMLOC)
+32 SET DIC("DR")=DR
SET DIC(0)="L"
SET DIC="^PS(55,"_DFN_",""NVA"","
SET DLAYGO=55.05
+33 DO FILE^DICN
SET PSONVA=+Y
KILL DR,DIC,DD,DA,DO,DINUM
+34 KILL PSODOS,PSOSCH
+35 ;
+36 KILL DSC,STDT
+37 IF $PIECE(PSODSC,"^",2)]""
Begin DoDot:1
+38 SET DSC=1
SET ^PS(55,DFN,"NVA",PSONVA,"DSC",1,0)=$PIECE(PSODSC,"^",2)
+39 SET ^PS(55,DFN,"NVA",PSONVA,"DSC",0)="^55.052^1^1^"_DT_"^^^^"
End DoDot:1
+40 IF $ORDER(PSODSC(0))
Begin DoDot:1
+41 FOR T=0:0
SET T=$ORDER(PSODSC(T))
IF 'T
QUIT
SET DSC=$GET(DSC)+1
SET ^PS(55,DFN,"NVA",PSONVA,"DSC",DSC,0)=PSODSC(T)
+42 SET ^PS(55,DFN,"NVA",PSONVA,"DSC",0)="^55.052^"_DSC_"^"_DSC_"^"_DT_"^^^^"
End DoDot:1
+43 IF $ORDER(PCOM(0))
FOR T=0:0
SET T=$ORDER(PCOM(T))
IF 'T
QUIT
Begin DoDot:1
+44 SET DSC=$GET(DSC)+1
SET ^PS(55,DFN,"NVA",PSONVA,"DSC",DSC,0)=PCOM(T)
+45 SET ^PS(55,DFN,"NVA",PSONVA,"DSC",0)="^55.052^"_DSC_"^"_DSC_"^"_DT_"^^^^"
+46 SET ^PS(55,DFN,"NVA",PSONVA,1,T,0)=PCOM(T)
+47 SET ^PS(55,DFN,"NVA",PSONVA,1,0)="^^"_T_"^"_T_"^"_DT_"^"
End DoDot:1
+48 IF $GET(OCOUNT)
SET ^PS(55,DFN,"NVA",PSONVA,"OCK",0)="^55.051^"_OCOUNT_"^"_OCOUNT
FOR OCOUNT=1:1:OCOUNT
Begin DoDot:1
+49 SET ^PS(55,DFN,"NVA",PSONVA,"OCK",OCOUNT,0)=$GET(OBXAR(OCOUNT,1))_"^"_PROV
+50 IF $GET(OBXAR(OCOUNT,1))]""
SET ^PS(55,DFN,"NVA",PSONVA,"OCK","B",$EXTRACT(OBXAR(OCOUNT,1),1,30),OCOUNT)=""
+51 SET PSOBCT=1
FOR LLL=2:1
IF '$DATA(OBXAR(OCOUNT,LLL))
QUIT
SET ^PS(55,DFN,"NVA",PSONVA,"OCK",OCOUNT,"OVR",1,0)=OBXAR(OCOUNT,LLL)
End DoDot:1
+52 ;IHS/MSC/REC/PLS - 08/06/2010 - Add Med Rec fields
+53 IF $DATA(^PS(55,DFN,"NVA",PSONVA,0))
Begin DoDot:1
+54 SET ^PS(55,DFN,"NVA",PSONVA,21400)=$GET(MSCLD)_U_$GET(MSCHMLST)_U_$GET(MSCHMLOC)
+55 IF $ORDER(MSCRSN(0))
Begin DoDot:2
+56 NEW T,MSCR
+57 SET T=0
FOR
SET T=$ORDER(MSCRSN(0))
IF 'T
QUIT
Begin DoDot:3
+58 SET MSCR=$GET(MSCR)+1
+59 SET ^PS(55,DFN,"NVA",PSONVA,21401,MSCR,0)=MSCRSN(T)
+60 KILL MSCRSN(T)
End DoDot:3
+61 SET ^PS(55,DFN,"NVA",PSONVA,21401,0)="^55.521404^"_MSCR_U_MSCR_U_DT_"^^^^"
End DoDot:2
End DoDot:1
+62 KILL MSCLD,MSCHMLST,MSCHMLOC,MSCRSN
+63 KILL HOLD,SCH,SCHED,SDL,SGL,A,W,WW,CHR,STRDT
+64 ;
+65 MERGE PMSG=MSG
REIN KILL MSG
SET NULLFLDS="F JJ=0:1:LIMIT S FIELD(JJ)="""""
+1 KILL ^UTILITY("DIQ1",$JOB),DIQ
SET DA=$PIECE($$SITE^VASITE(),"^")
+2 IF $GET(DA)
SET DIC=4
SET DIQ(0)="I"
SET DR="99"
DO EN^DIQ1
SET PSOHINST=$GET(^UTILITY("DIQ1",$JOB,4,DA,99,"I"))
KILL ^UTILITY("DIQ1",$JOB),DA,DR,DIQ,DIC
+3 SET MSG(1)="MSH|^~\&|PHARMACY|"_$GET(PSOHINST)_"|||||ORR"
+4 ;
+5 SET COUNT=1
SET LIMIT=5
XECUTE NULLFLDS
DO DEM^VADPT
SET NAME=$GET(VADM(1))
KILL VADM
+6 SET FIELD(0)="PID"
SET FIELD(3)=DFN
SET FIELD(5)=NAME
+7 DO SEG^PSOHLSN1
+8 ;
+9 ;
+10 SET LIMIT=19
XECUTE NULLFLDS
+11 SET FIELD(0)="PV1"
SET FIELD(2)="O"
SET FIELD(3)=LOCATION
+12 DO SEG^PSOHLSN1
+13 ;
+14 SET LIMIT=15
XECUTE NULLFLDS
+15 SET FIELD(0)="ORC"
SET FIELD(1)=$SELECT($GET(REIN):"SC",1:"OK")
SET FIELD(2)=PLACER_"^OR"
SET FIELD(3)=PSONVA_"N^PS"
SET FIELD(5)="CM"
+16 SET FIELD(10)=$PIECE(^PS(55,DFN,"NVA",PSONVA,0),"^",11)_"^"_$PIECE(^VA(200,$PIECE(^PS(55,DFN,"NVA",PSONVA,0),"^",11),0),"^")
+17 ;IHS/MSC/REC/PLS - 08/06/2010 - Change field 5 if there is a status of Reconcile
+18 IF +$PIECE(^PS(55,DFN,"NVA",PSONVA,0),U,6)=97
SET FIELD(5)="REC"
+19 DO SEG^PSOHLSN1
+20 IF $GET(REIN)
SET MSG(COUNT)=MSG(COUNT)_"|^^^^DATE OF DEATH DELETED BY MAS.^"
+21 ;
+22 SET LIMIT=1
XECUTE NULLFLDS
+23 SET FIELD(0)="RXO"
SET OI=$PIECE(^PS(55,DFN,"NVA",PSONVA,0),"^")
+24 SET FIELD(1)="^^^"_OI_"^"_$PIECE($GET(^PS(50.7,OI,0)),"^")_" "_$PIECE($GET(^PS(50.606,+$PIECE($GET(^(0)),"^",2),0)),"^")_"^99PSP"
+25 DO SEG^PSOHLSN1
+26 ;
+27 SET LIMIT=1
XECUTE NULLFLDS
+28 SET FIELD(0)="RXE"
+29 SET PSOPSTRT=""
SET X=$PIECE(^PS(55,DFN,"NVA",PSONVA,0),"^",9)
IF X
SET PSOPSTRT=$$FMTHL7^XLFDT(X)
+30 KILL X
SET FIELD(1)="^^^"_$GET(PSOPSTRT)_"^"
+31 DO SEG^PSOHLSN1
+32 ;
+33 DO SEND^PSOHLSN1
KILL FIELDS,LIMIT,PSODSC,PSONVA,OI
IF $GET(REIN)
QUIT
+34 ;dc change order
DC FOR OO=0:0
SET OO=$ORDER(PMSG(OO))
IF 'OO
QUIT
IF $PIECE(PMSG(OO),"|")="ORC"
IF $PIECE(PMSG(OO),"|",2)="XO"
Begin DoDot:1
+1 FOR XO=0:0
SET XO=$ORDER(PMSG(XO))
IF 'XO
QUIT
IF $PIECE(PMSG(XO),"|")="ZRX"
SET POERR("PSOFILNM")=$PIECE(PMSG(XO),"|",2)
QUIT
End DoDot:1
QUIT
+2 IF +$GET(POERR("PSOFILNM"))
IF $GET(^PS(55,DFN,"NVA",+$GET(POERR("PSOFILNM")),0))
SET PDFN=DFN
DO XO^PSOORUTL
+3 KILL XO,OO,PMSG
+4 QUIT
SCHED(SCH) ; Returns the SCHEDULE description
+1 NEW SCHED,CNT,FND,A,I,K,HOLD
+2 SET SCHED=""
IF $GET(SCH)=""
QUIT SCHED
+3 ;
+4 FOR A=0:0
SET A=$ORDER(^PS(51.1,"B",SCH,A))
IF 'A
QUIT
Begin DoDot:1
+5 IF $PIECE($GET(^PS(51.1,A,0)),"^",8)'=""
SET SCHED=$PIECE($GET(^(0)),"^",8)
End DoDot:1
IF SCHED'=""
QUIT
+6 IF SCHED'=""
GOTO QSCH
+7 ;
+8 IF $GET(^PS(51,"A",SCH))'=""
SET SCHED=$PIECE(^PS(51,"A",SCH),"^")
GOTO QSCH
+9 ;
+10 SET CNT=$LENGTH(SCH," ")
SET FND=0
+11 FOR I=1:1:CNT
SET (WORD,HOLD(I))=$PIECE(SCH," ",I)
Begin DoDot:1
+12 IF WORD=""
QUIT
+13 FOR K=0:0
SET K=$ORDER(^PS(51.1,"B",WORD,K))
IF 'K
QUIT
Begin DoDot:2
+14 IF $PIECE($GET(^PS(51.1,K,0)),"^",8)'=""
Begin DoDot:3
+15 SET HOLD(I)=$PIECE($GET(^PS(51.1,K,0)),"^",8)
SET FND=1
End DoDot:3
End DoDot:2
IF FND
QUIT
+16 IF $GET(^PS(51,"A",WORD))]""
SET HOLD(I)=$PIECE(^(WORD),"^")
End DoDot:1
+17 SET FND=0
FOR K=1:1:CNT
SET SCHED=SCHED_$SELECT($GET(FND):" ",1:"")_$GET(HOLD(K))
SET FND=1
+18 ;
QSCH QUIT SCHED
+1 ;
ROUTE(RTIEN) ; Returns the ROUTE description
+1 NEW X
+2 IF '$GET(RTIEN)
QUIT ""
SET X=$GET(^PS(51.2,RTIEN,0))
+3 QUIT $SELECT($PIECE(X,"^",2)'="":$PIECE(X,"^",2),1:$PIECE(X,"^"))
+4 ;
APSOD ;dc non-va meds because of date of death entry called from psocan3
+1 ;,POERR("PSOFILNM")
NEW PDA,PDFN
+2 FOR PDA=0:0
SET PDA=$ORDER(^PS(55,PSODFN,"NVA",PDA))
IF 'PDA
QUIT
IF '$PIECE(^PS(55,PSODFN,"NVA",PDA,0),"^",6)
IF '$PIECE(^(0),"^",7)
Begin DoDot:1
+3 SET POERR("PSOFILNM")=PDA
SET PDFN=PSODFN
DO XO^PSOORUTL
End DoDot:1
+4 ;IHS/MSC/REC/PLS - 08/09/10
+5 ;Update status based on the dosage form
STATU ;EP - If set to miscellaneous, then the status of the order should be RECONCILE
+1 NEW MSCPDF
+2 ;No pharmacy orderable item
IF $GET(PSORDITE)']""
QUIT
+3 SET MSCPDF=$PIECE(^PS(50.606,$PIECE(^PS(50.7,PSORDITE,0),U,2),0),U)
+4 IF MSCPDF="MISCELLANEOUS"
Begin DoDot:1
+5 NEW FDA
+6 SET FDA(55.05,PSONVA_","_DFN_",",5)="RECONCILE"
+7 DO UPDATE^DIE("E","FDA","","")
End DoDot:1
+8 QUIT
