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

PSONVNEW.m

Go to the documentation of this file. 
  1. 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
  1.  ;External reference ^PS(50.606 supported by DBIA 2174
  1.  ;External reference ^PS(50.7 supported by DBIA 2223
  1.  ;External reference ^PS(55 supported by DBIA 2228
  1.  ;External reference to ^PS(51.2 supported by DBIA 2226
  1.  ;adds new non-va med to #55
  1.  ;
  1.  ;*203 change 3 fields from "///" to "////" they can be larger than
  1.  ;      defined and need to be put in as is to prevent hard crash.
  1.  ;*265 change update of Dosage & Sched fields DR strings, can contain ;      free form char ";"
  1.  ;Modified - IHS/MSC/PLS - 08/30/2010 - Line REIN+17, Added +32, STATU EP
  1.  ;
  1.  I '$D(^PS(55,DFN,0)) D
  1.  .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
  1.  ..S $P(^PS(55,DFN,0),"^")=DFN,$P(^(0),"^",6)=2
  1.  ..K DIK S DA=DFN,DIK="^PS(55,",DIK(1)=.01 D EN^DIK K DIK
  1.  ;
  1.  N PSONVA,DSC K PCOM
  1.  F I=0:0 S I=$O(MSG(I)) Q:'I  D
  1.  .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)
  1.  .I $P(MSG(I),"|")="ORC" S STDT=$P(MSG(I),"|",8),STRDT=$$HL7TFM^XLFDT($P(STDT,"^",4))
  1.  ;
  1.  ; - Files the Non-VA Med order into the "NVA" multiple in File #55
  1.  K DR,DIC,DD,DA,DO,DINUM S DA(1)=DFN,X=PSORDITE
  1.  ;*203,*265 fix DR & dose & sched fields
  1.  S PSODOS=$G(PSOLQ1I(1)),PSOSCH=$$SCHED($P($G(QTARRAY(1)),"^"))
  1.  S DR="1////"_PSODDRUG_";2////^S X=PSODOS;3////"_$$ROUTE($G(ROUTE(1)))
  1.  S DR=DR_";4////^S X=PSOSCH;7////"_$G(PLACER)_";8///"_$G(STRDT)
  1.  S DR=DR_";11///"_$G(PSOLOG)_";12////"_$G(ENTERED)_";13////"_$G(LOCATION)
  1.  ; IHS/MSC/REC/PLS - Add MED REC Fields 8/30/10
  1.  S DR=DR_";21401///"_$G(MSCLD)_";21402///"_$G(MSCHMLST)_";21403///"_$G(MSCHMLOC)
  1.  S DIC("DR")=DR,DIC(0)="L",DIC="^PS(55,"_DFN_",""NVA"",",DLAYGO=55.05
  1.  D FILE^DICN S PSONVA=+Y K DR,DIC,DD,DA,DO,DINUM
  1.  K PSODOS,PSOSCH
  1.  ;
  1.  K DSC,STDT
  1.  I $P(PSODSC,"^",2)]"" D
  1.  .S DSC=1,^PS(55,DFN,"NVA",PSONVA,"DSC",1,0)=$P(PSODSC,"^",2)
  1.  .S ^PS(55,DFN,"NVA",PSONVA,"DSC",0)="^55.052^1^1^"_DT_"^^^^"
  1.  I $O(PSODSC(0)) D
  1.  .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)
  1.  .S ^PS(55,DFN,"NVA",PSONVA,"DSC",0)="^55.052^"_DSC_"^"_DSC_"^"_DT_"^^^^"
  1.  I $O(PCOM(0)) F T=0:0 S T=$O(PCOM(T)) Q:'T  D
  1.  .S DSC=$G(DSC)+1,^PS(55,DFN,"NVA",PSONVA,"DSC",DSC,0)=PCOM(T)
  1.  .S ^PS(55,DFN,"NVA",PSONVA,"DSC",0)="^55.052^"_DSC_"^"_DSC_"^"_DT_"^^^^"
  1.  .S ^PS(55,DFN,"NVA",PSONVA,1,T,0)=PCOM(T)
  1.  .S ^PS(55,DFN,"NVA",PSONVA,1,0)="^^"_T_"^"_T_"^"_DT_"^"
  1.  I $G(OCOUNT) S ^PS(55,DFN,"NVA",PSONVA,"OCK",0)="^55.051^"_OCOUNT_"^"_OCOUNT F OCOUNT=1:1:OCOUNT D
  1.  .S ^PS(55,DFN,"NVA",PSONVA,"OCK",OCOUNT,0)=$G(OBXAR(OCOUNT,1))_"^"_PROV
  1.  .I $G(OBXAR(OCOUNT,1))]"" S ^PS(55,DFN,"NVA",PSONVA,"OCK","B",$E(OBXAR(OCOUNT,1),1,30),OCOUNT)=""
  1.  .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)
  1.  ;IHS/MSC/REC/PLS - 08/06/2010 - Add Med Rec fields
  1.  I $D(^PS(55,DFN,"NVA",PSONVA,0)) D
  1.  .S ^PS(55,DFN,"NVA",PSONVA,21400)=$G(MSCLD)_U_$G(MSCHMLST)_U_$G(MSCHMLOC)
  1.  .I $O(MSCRSN(0)) D
  1.  ..N T,MSCR
  1.  ..S T=0 F  S T=$O(MSCRSN(0)) Q:'T  D
  1.  ...S MSCR=$G(MSCR)+1
  1.  ...S ^PS(55,DFN,"NVA",PSONVA,21401,MSCR,0)=MSCRSN(T)
  1.  ...K MSCRSN(T)
  1.  ..S ^PS(55,DFN,"NVA",PSONVA,21401,0)="^55.521404^"_MSCR_U_MSCR_U_DT_"^^^^"
  1.  K MSCLD,MSCHMLST,MSCHMLOC,MSCRSN
  1.  K HOLD,SCH,SCHED,SDL,SGL,A,W,WW,CHR,STRDT
  1.  ;
  1.  M PMSG=MSG
  1. REIN K MSG S NULLFLDS="F JJ=0:1:LIMIT S FIELD(JJ)="""""
  1.  K ^UTILITY("DIQ1",$J),DIQ S DA=$P($$SITE^VASITE(),"^")
  1.  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
  1.  S MSG(1)="MSH|^~\&|PHARMACY|"_$G(PSOHINST)_"|||||ORR"
  1.  ;
  1.  S COUNT=1,LIMIT=5 X NULLFLDS D DEM^VADPT S NAME=$G(VADM(1)) K VADM
  1.  S FIELD(0)="PID",FIELD(3)=DFN,FIELD(5)=NAME
  1.  D SEG^PSOHLSN1
  1.  ;
  1.  ;
  1.  S LIMIT=19 X NULLFLDS
  1.  S FIELD(0)="PV1",FIELD(2)="O",FIELD(3)=LOCATION
  1.  D SEG^PSOHLSN1
  1.  ;
  1.  S LIMIT=15 X NULLFLDS
  1.  S FIELD(0)="ORC",FIELD(1)=$S($G(REIN):"SC",1:"OK"),FIELD(2)=PLACER_"^OR",FIELD(3)=PSONVA_"N^PS",FIELD(5)="CM"
  1.  S FIELD(10)=$P(^PS(55,DFN,"NVA",PSONVA,0),"^",11)_"^"_$P(^VA(200,$P(^PS(55,DFN,"NVA",PSONVA,0),"^",11),0),"^")
  1.  ;IHS/MSC/REC/PLS - 08/06/2010 - Change field 5 if there is a status of Reconcile
  1.  I +$P(^PS(55,DFN,"NVA",PSONVA,0),U,6)=97 S FIELD(5)="REC"
  1.  D SEG^PSOHLSN1
  1.  I $G(REIN) S MSG(COUNT)=MSG(COUNT)_"|^^^^DATE OF DEATH DELETED BY MAS.^"
  1.  ;
  1.  S LIMIT=1 X NULLFLDS
  1.  S FIELD(0)="RXO",OI=$P(^PS(55,DFN,"NVA",PSONVA,0),"^")
  1.  S FIELD(1)="^^^"_OI_"^"_$P($G(^PS(50.7,OI,0)),"^")_" "_$P($G(^PS(50.606,+$P($G(^(0)),"^",2),0)),"^")_"^99PSP"
  1.  D SEG^PSOHLSN1
  1.  ;
  1.  S LIMIT=1 X NULLFLDS
  1.  S FIELD(0)="RXE"
  1.  S PSOPSTRT="",X=$P(^PS(55,DFN,"NVA",PSONVA,0),"^",9) I X S PSOPSTRT=$$FMTHL7^XLFDT(X)
  1.  K X S FIELD(1)="^^^"_$G(PSOPSTRT)_"^"
  1.  D SEG^PSOHLSN1
  1.  ;
  1.  D SEND^PSOHLSN1 K FIELDS,LIMIT,PSODSC,PSONVA,OI Q:$G(REIN)
  1.  ;dc change order
  1. DC F OO=0:0 S OO=$O(PMSG(OO)) Q:'OO  I $P(PMSG(OO),"|")="ORC",$P(PMSG(OO),"|",2)="XO" D  Q
  1.  .F XO=0:0 S XO=$O(PMSG(XO)) Q:'XO  I $P(PMSG(XO),"|")="ZRX" S POERR("PSOFILNM")=$P(PMSG(XO),"|",2) Q
  1.  I +$G(POERR("PSOFILNM")),$G(^PS(55,DFN,"NVA",+$G(POERR("PSOFILNM")),0)) S PDFN=DFN D XO^PSOORUTL
  1.  K XO,OO,PMSG
  1.  Q
  1. SCHED(SCH) ; Returns the SCHEDULE description
  1.  N SCHED,CNT,FND,A,I,K,HOLD
  1.  S SCHED="" Q:$G(SCH)="" SCHED
  1.  ;
  1.  F A=0:0 S A=$O(^PS(51.1,"B",SCH,A)) Q:'A  D  I SCHED'="" Q
  1.  . S:$P($G(^PS(51.1,A,0)),"^",8)'="" SCHED=$P($G(^(0)),"^",8)
  1.  I SCHED'="" G QSCH
  1.  ;
  1.  I $G(^PS(51,"A",SCH))'="" S SCHED=$P(^PS(51,"A",SCH),"^") G QSCH
  1.  ;
  1.  S CNT=$L(SCH," "),FND=0
  1.  F I=1:1:CNT S (WORD,HOLD(I))=$P(SCH," ",I) D
  1.  . I WORD="" Q
  1.  . F K=0:0 S K=$O(^PS(51.1,"B",WORD,K)) Q:'K  D  I FND Q
  1.  . . I $P($G(^PS(51.1,K,0)),"^",8)'="" D
  1.  . . . S HOLD(I)=$P($G(^PS(51.1,K,0)),"^",8),FND=1
  1.  . I $G(^PS(51,"A",WORD))]"" S HOLD(I)=$P(^(WORD),"^")
  1.  S FND=0 F K=1:1:CNT S SCHED=SCHED_$S($G(FND):" ",1:"")_$G(HOLD(K)),FND=1
  1.  ;
  1. QSCH Q SCHED
  1.  ;
  1. ROUTE(RTIEN) ; Returns the ROUTE description
  1.  N X
  1.  Q:'$G(RTIEN) "" S X=$G(^PS(51.2,RTIEN,0))
  1.  Q $S($P(X,"^",2)'="":$P(X,"^",2),1:$P(X,"^"))
  1.  ;
  1. APSOD ;dc non-va meds because of date of death entry called from psocan3
  1.  N PDA,PDFN ;,POERR("PSOFILNM")
  1.  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
  1.  .S POERR("PSOFILNM")=PDA,PDFN=PSODFN D XO^PSOORUTL
  1.  ;IHS/MSC/REC/PLS - 08/09/10
  1.  ;Update status based on the dosage form
  1. STATU ;EP - If set to miscellaneous, then the status of the order should be RECONCILE
  1.  N MSCPDF
  1.  Q:$G(PSORDITE)']""  ;No pharmacy orderable item
  1.  S MSCPDF=$P(^PS(50.606,$P(^PS(50.7,PSORDITE,0),U,2),0),U)
  1.  I MSCPDF="MISCELLANEOUS" D
  1.  .N FDA
  1.  .S FDA(55.05,PSONVA_","_DFN_",",5)="RECONCILE"
  1.  .D UPDATE^DIE("E","FDA","","")
  1.  Q