PSONVNEW ;BIR/SAB - Add Non-VA Med orders ;Feb 28, 2022@14:29:26
;;7.0;OUTPATIENT PHARMACY;**132,118,203,265,282,455,441**;DEC 1997;Build 208
;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
;External reference to ^ORHLSEC supported by DBIA 4922
;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 ";"
;*441 Add Complex Orders to NVA Meds
;
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,ORCSEG,PSOIND 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),"|",10),STRDT=$$HL7TFM^XLFDT(STDT),ORCSEG=$P($G(MSG(I)),"|",8)
.I $P(MSG(I),"|")="RXO" S PSOIND=$P(MSG(I),"|",21) ;*441-IND
;
; - 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
;it appears NVA old structure never took into account Possible dose vs. Local Possible dose, fix below
S PSODOS=$S($G(PSOQWX)&($G(PSOLQ1II(1))):Q1I(1),$G(PSOQWX)&($G(PSOLQ1IX(1))'="")&('$G(PSOLQ1II(1))):PSOLQ1IX(1),1:$G(PSOLQ1I(1))) ;init Dose for 1st rec for backwards compatible structure
S 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///"_$P($G(STRDT),".") ;*455 - ONLY STORE DATE, NOT TIME
S DR=DR_";11///"_$G(PSOLOG)_";12////"_$G(ENTERED)_";13////"_$G(LOCATION)_";15////^S X=$$UNESC^ORHLESC($G(PSOIND))" ;*441-IND
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
;introduces complex non-va orders via CPRS
K FDA S DA(1)=+Y,DA(2)=DFN
I $G(QCOUNT) D
.N PP,ORC
.F PP=0:0 S PP=$O(QTARRAY(PP)) Q:'PP D
..S ORC=$P($G(ORCSEG),"~",PP)
..S FDA(55.516,"+1,"_DA(1)_","_DA(2)_",",.01)=$TR($G(ORC),"^","|")
..S FDA(55.516,"+1,"_DA(1)_","_DA(2)_",",1)=$$SCHED($P($P($G(QTARRAY(PP)),"^"),"&")) ;nva meds schedules can have embedded & sub-delimiter for IP patients vs. OP patients
..S FDA(55.516,"+1,"_DA(1)_","_DA(2)_",",2)=$P($G(QTARRAY(PP)),"^",2)
..S FDA(55.516,"+1,"_DA(1)_","_DA(2)_",",3)=$P($G(QTARRAY(PP)),"^",6)
..;init val to either Possible Dose or Local Possible Dose
..S VAL=$S($G(PSOQWX)&($G(PSOLQ1II(PP))):Q1I(PP),$G(PSOQWX)&($G(PSOLQ1IX(PP))'="")&('$G(PSOLQ1II(PP))):PSOLQ1IX(PP),1:PSOLQ1I(PP))
..S FDA(55.516,"+1,"_DA(1)_","_DA(2)_",",4)=VAL
..D UPDATE^DIE("","FDA") K FDA
;
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)=$$UNESC^ORHLESC(PCOM(T)) ;*455
.S ^PS(55,DFN,"NVA",PSONVA,"DSC",0)="^55.052^"_DSC_"^"_DSC_"^"_DT_"^^^^"
.S ^PS(55,DFN,"NVA",PSONVA,1,T,0)=$$UNESC^ORHLESC(PCOM(T)) ;*455
.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)
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),"^")
D SEG^PSOHLSN1
I $G(REIN) S MSG(COUNT)=MSG(COUNT)_"|^^^^DATE OF DEATH DELETED BY MAS.^"
;
S LIMIT=20 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"
S FIELD(20)=$G(PSOIND)
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
;SCH = Schedule entered
;Returns Expanded Schedule, or ""
N SCHEX,SPCT
S SCH=$$UPPER(SCH)
I SCH="" Q ""
S SPCT=0 F I=1:1:$L(SCH) I $E(SCH,I)=" " S SPCT=SPCT+1
S SCHEX=$$EXP(SCH) I SCHEX]"" Q SCHEX
Q:SPCT=0 SCH
Q $$SCHED($P(SCH," ",1,SPCT))_" "_$$SCHED($P(SCH," ",SPCT+1))
EXP(X) ; expand based on 51.1 and 51
N PSIN,SCFLG,SCHEX
S PSIN=0 F S PSIN=$O(^PS(51.1,"APPSJ",X,PSIN)) Q:'PSIN!$G(SCFLG) I $P(^PS(51.1,PSIN,0),"^",8)'="" S SCHEX=$P($G(^(0)),"^",8),SCFLG=1
Q:$G(SCFLG) SCHEX
S PSIN=0 F S PSIN=$O(^PS(51,"B",X,PSIN)) Q:'PSIN!$G(SCLFL) I PSIN,($P(^PS(51,PSIN,0),"^",4)<2)&($P($G(^PS(51,"A",X)),"^")'="") S SCHEX=$P(^(X),"^"),SCFLG=1
Q:$G(SCFLG) SCHEX
Q ""
UPPER(PSOSCUP) ;
Q $TR(PSOSCUP,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
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
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSONVNEW 7307 printed Apr 09, 2024@21:34:47 Page 2
PSONVNEW ;BIR/SAB - Add Non-VA Med orders ;Feb 28, 2022@14:29:26
+1 ;;7.0;OUTPATIENT PHARMACY;**132,118,203,265,282,455,441**;DEC 1997;Build 208
+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 ;External reference to ^ORHLSEC supported by DBIA 4922
+7 ;adds new non-va med to #55
+8 ;
+9 ;*203 change 3 fields from "///" to "////" they can be larger than
+10 ; defined and need to be put in as is to prevent hard crash.
+11 ;*265 change update of Dosage & Sched fields DR strings, can contain ; free form char ";"
+12 ;*441 Add Complex Orders to NVA Meds
+13 ;
+14 IF '$DATA(^PS(55,DFN,0))
Begin DoDot:1
+15 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
+16 SET $PIECE(^PS(55,DFN,0),"^")=DFN
SET $PIECE(^(0),"^",6)=2
+17 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
+18 ;
+19 NEW PSONVA,DSC,ORCSEG,PSOIND
KILL PCOM
+20 FOR I=0:0
SET I=$ORDER(MSG(I))
if 'I
QUIT
Begin DoDot:1
+21 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)
+22 IF $PIECE(MSG(I),"|")="ORC"
SET STDT=$PIECE(MSG(I),"|",10)
SET STRDT=$$HL7TFM^XLFDT(STDT)
SET ORCSEG=$PIECE($GET(MSG(I)),"|",8)
+23 ;*441-IND
IF $PIECE(MSG(I),"|")="RXO"
SET PSOIND=$PIECE(MSG(I),"|",21)
End DoDot:1
+24 ;
+25 ; - Files the Non-VA Med order into the "NVA" multiple in File #55
+26 KILL DR,DIC,DD,DA,DO,DINUM
SET DA(1)=DFN
SET X=PSORDITE
+27 ;*203,*265 fix DR & dose & sched fields
+28 ;it appears NVA old structure never took into account Possible dose vs. Local Possible dose, fix below
+29 ;init Dose for 1st rec for backwards compatible structure
SET PSODOS=$SELECT($GET(PSOQWX)&($GET(PSOLQ1II(1))):Q1I(1),$GET(PSOQWX)&($GET(PSOLQ1IX(1))'="")&('$GET(PSOLQ1II(1))):PSOLQ1IX(1),1:$GET(PSOLQ1I(1)))
+30 SET PSOSCH=$$SCHED($PIECE($GET(QTARRAY(1)),"^"))
+31 SET DR="1////"_PSODDRUG_";2////^S X=PSODOS;3////"_$$ROUTE($GET(ROUTE(1)))
+32 ;*455 - ONLY STORE DATE, NOT TIME
SET DR=DR_";4////^S X=PSOSCH;7////"_$GET(PLACER)_";8///"_$PIECE($GET(STRDT),".")
+33 ;*441-IND
SET DR=DR_";11///"_$GET(PSOLOG)_";12////"_$GET(ENTERED)_";13////"_$GET(LOCATION)_";15////^S X=$$UNESC^ORHLESC($G(PSOIND))"
+34 SET DIC("DR")=DR
SET DIC(0)="L"
SET DIC="^PS(55,"_DFN_",""NVA"","
SET DLAYGO=55.05
+35 DO FILE^DICN
SET PSONVA=+Y
KILL DR,DIC,DD,DA,DO,DINUM
+36 ;introduces complex non-va orders via CPRS
+37 KILL FDA
SET DA(1)=+Y
SET DA(2)=DFN
+38 IF $GET(QCOUNT)
Begin DoDot:1
+39 NEW PP,ORC
+40 FOR PP=0:0
SET PP=$ORDER(QTARRAY(PP))
if 'PP
QUIT
Begin DoDot:2
+41 SET ORC=$PIECE($GET(ORCSEG),"~",PP)
+42 SET FDA(55.516,"+1,"_DA(1)_","_DA(2)_",",.01)=$TRANSLATE($GET(ORC),"^","|")
+43 ;nva meds schedules can have embedded & sub-delimiter for IP patients vs. OP patients
SET FDA(55.516,"+1,"_DA(1)_","_DA(2)_",",1)=$$SCHED($PIECE($PIECE($GET(QTARRAY(PP)),"^"),"&"))
+44 SET FDA(55.516,"+1,"_DA(1)_","_DA(2)_",",2)=$PIECE($GET(QTARRAY(PP)),"^",2)
+45 SET FDA(55.516,"+1,"_DA(1)_","_DA(2)_",",3)=$PIECE($GET(QTARRAY(PP)),"^",6)
+46 ;init val to either Possible Dose or Local Possible Dose
+47 SET VAL=$SELECT($GET(PSOQWX)&($GET(PSOLQ1II(PP))):Q1I(PP),$GET(PSOQWX)&($GET(PSOLQ1IX(PP))'="")&('$GET(PSOLQ1II(PP))):PSOLQ1IX(PP),1:PSOLQ1I(PP))
+48 SET FDA(55.516,"+1,"_DA(1)_","_DA(2)_",",4)=VAL
+49 DO UPDATE^DIE("","FDA")
KILL FDA
End DoDot:2
End DoDot:1
+50 ;
+51 SET PSONVA=+Y
KILL DR,DIC,DD,DA,DO,DINUM
+52 KILL PSODOS,PSOSCH
+53 ;
+54 KILL DSC,STDT
+55 IF $PIECE(PSODSC,"^",2)]""
Begin DoDot:1
+56 SET DSC=1
SET ^PS(55,DFN,"NVA",PSONVA,"DSC",1,0)=$PIECE(PSODSC,"^",2)
+57 SET ^PS(55,DFN,"NVA",PSONVA,"DSC",0)="^55.052^1^1^"_DT_"^^^^"
End DoDot:1
+58 IF $ORDER(PSODSC(0))
Begin DoDot:1
+59 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)
+60 SET ^PS(55,DFN,"NVA",PSONVA,"DSC",0)="^55.052^"_DSC_"^"_DSC_"^"_DT_"^^^^"
End DoDot:1
+61 IF $ORDER(PCOM(0))
FOR T=0:0
SET T=$ORDER(PCOM(T))
if 'T
QUIT
Begin DoDot:1
+62 ;*455
SET DSC=$GET(DSC)+1
SET ^PS(55,DFN,"NVA",PSONVA,"DSC",DSC,0)=$$UNESC^ORHLESC(PCOM(T))
+63 SET ^PS(55,DFN,"NVA",PSONVA,"DSC",0)="^55.052^"_DSC_"^"_DSC_"^"_DT_"^^^^"
+64 ;*455
SET ^PS(55,DFN,"NVA",PSONVA,1,T,0)=$$UNESC^ORHLESC(PCOM(T))
+65 SET ^PS(55,DFN,"NVA",PSONVA,1,0)="^^"_T_"^"_T_"^"_DT_"^"
End DoDot:1
+66 IF $GET(OCOUNT)
SET ^PS(55,DFN,"NVA",PSONVA,"OCK",0)="^55.051^"_OCOUNT_"^"_OCOUNT
FOR OCOUNT=1:1:OCOUNT
Begin DoDot:1
+67 SET ^PS(55,DFN,"NVA",PSONVA,"OCK",OCOUNT,0)=$GET(OBXAR(OCOUNT,1))_"^"_PROV
+68 IF $GET(OBXAR(OCOUNT,1))]""
SET ^PS(55,DFN,"NVA",PSONVA,"OCK","B",$EXTRACT(OBXAR(OCOUNT,1),1,30),OCOUNT)=""
+69 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
+70 KILL HOLD,SCH,SCHED,SDL,SGL,A,W,WW,CHR,STRDT
+71 ;
+72 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 DO SEG^PSOHLSN1
+18 IF $GET(REIN)
SET MSG(COUNT)=MSG(COUNT)_"|^^^^DATE OF DEATH DELETED BY MAS.^"
+19 ;
+20 SET LIMIT=20
XECUTE NULLFLDS
+21 SET FIELD(0)="RXO"
SET OI=$PIECE(^PS(55,DFN,"NVA",PSONVA,0),"^")
+22 SET FIELD(1)="^^^"_OI_"^"_$PIECE($GET(^PS(50.7,OI,0)),"^")_" "_$PIECE($GET(^PS(50.606,+$PIECE($GET(^(0)),"^",2),0)),"^")_"^99PSP"
+23 SET FIELD(20)=$GET(PSOIND)
+24 DO SEG^PSOHLSN1
+25 ;
+26 SET LIMIT=1
XECUTE NULLFLDS
+27 SET FIELD(0)="RXE"
+28 SET PSOPSTRT=""
SET X=$PIECE(^PS(55,DFN,"NVA",PSONVA,0),"^",9)
IF X
SET PSOPSTRT=$$FMTHL7^XLFDT(X)
+29 KILL X
SET FIELD(1)="^^^"_$GET(PSOPSTRT)_"^"
+30 DO SEG^PSOHLSN1
+31 ;
+32 DO SEND^PSOHLSN1
KILL FIELDS,LIMIT,PSODSC,PSONVA,OI
if $GET(REIN)
QUIT
+33 ;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 ;SCH = Schedule entered
+2 ;Returns Expanded Schedule, or ""
+3 NEW SCHEX,SPCT
+4 SET SCH=$$UPPER(SCH)
+5 IF SCH=""
QUIT ""
+6 SET SPCT=0
FOR I=1:1:$LENGTH(SCH)
IF $EXTRACT(SCH,I)=" "
SET SPCT=SPCT+1
+7 SET SCHEX=$$EXP(SCH)
IF SCHEX]""
QUIT SCHEX
+8 if SPCT=0
QUIT SCH
+9 QUIT $$SCHED($PIECE(SCH," ",1,SPCT))_" "_$$SCHED($PIECE(SCH," ",SPCT+1))
EXP(X) ; expand based on 51.1 and 51
+1 NEW PSIN,SCFLG,SCHEX
+2 SET PSIN=0
FOR
SET PSIN=$ORDER(^PS(51.1,"APPSJ",X,PSIN))
if 'PSIN!$GET(SCFLG)
QUIT
IF $PIECE(^PS(51.1,PSIN,0),"^",8)'=""
SET SCHEX=$PIECE($GET(^(0)),"^",8)
SET SCFLG=1
+3 if $GET(SCFLG)
QUIT SCHEX
+4 SET PSIN=0
FOR
SET PSIN=$ORDER(^PS(51,"B",X,PSIN))
if 'PSIN!$GET(SCLFL)
QUIT
IF PSIN
IF ($PIECE(^PS(51,PSIN,0),"^",4)<2)&($PIECE($GET(^PS(51,"A",X)),"^")'="")
SET SCHEX=$PIECE(^(X),"^")
SET SCFLG=1
+5 if $GET(SCFLG)
QUIT SCHEX
+6 QUIT ""
UPPER(PSOSCUP) ;
+1 QUIT $TRANSLATE(PSOSCUP,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
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 QUIT
