source: WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOVDF3.m@ 770

PSOVDF3 ;BIR/RTR-OUTPATIENT PHARMACY VDEF MESSAGE CONTINUED ;06/16/05
 ;;7.0;OUTPATIENT PHARMACY;**205,235,261**;DEC 1997;Build 9
 ;External reference to PS(50.7 supported by DBIA 2223
 ;External refernce to PS(50.607 supported by DBIA 2221
 ;
DOSE(GLOBAL) ;Add Dosage information to RXE 1
 N RES S RES=""
 N PSODD1,PSODD2,PSODD3,PSODD5,PSODDL,PSODDN,PSORES1,PSODDUNT,PSOD1FLG
 F PSODDL=0:0 S PSODDL=$O(GLOBAL(PSODDL)) Q:'PSODDL  D
 .S PSODDN=$G(GLOBAL(PSODDL,0)) Q:PSODDN=""
 .S PSODD1=$P(PSODDN,"^"),PSODD2=$P(PSODDN,"^",2),PSODD3=$P(PSODDN,"^",3),PSODD5=$P(PSODDN,"^",5),PSODDUNT=""
 .I PSODD1="",PSODD2="",PSODD5="" Q
 .I PSODD5'="",($E(PSODD5,$L(PSODD5))'?1A) S PSODD5=PSODD5_"D"
 .I PSODD5'="" S PSODD5=$$REPL^PSOVDF1(PSODD5)
 .S PSOD1FLG=0
 .I PSODD2'="",PSODD3'="",$P($G(^PS(50.607,PSODD3,0)),"^")'="" S PSOD1FLG=1,PSODDUNT=$P($G(^(0)),"^"),PSODDUNT=$$REPL^PSOVDF1(PSODDUNT) S:$G(PSODD1)'="" PSODD1=$$REPL^PSOVDF1(PSODD1),PSODD1=PSODD1_PSODDUNT
 .I 'PSOD1FLG,$G(PSODD1)'="" S PSODD1=$$REPL^PSOVDF1(PSODD1)
 .S PSORES1=""
 .I PSODD1'=""!(PSODD2'="") D
 ..I PSODD2'="" S PSODD2=$$REPL^PSOVDF1(PSODD2) S PSORES1=PSODD2 S:PSODD1'="" PSORES1=PSORES1_SEPS_PSODD1 Q
 ..S PSORES1=SEPS_PSODD1
 .I PSODD5'="" D
 ..I PSORES1="" S PSORES1=SEPC_SEPC_PSODD5 Q
 ..S PSORES1=PSORES1_SEPC_SEPC_PSODD5
 .Q:PSORES1=""
 .I $G(RES)'="" S RES=RES_SEPR_PSORES1 Q
 .S RES=PSORES1
 K TEMP
 Q RES
 ;
FINISH ;Finish rest of RXE 1 segment
 N PSOVAL1 S PSOVAL1=$P(VAL,SEPR)
 S WR=""
 S WR=$$GET^PSOVDF2(.GL,2,2)
 I $G(WR)'="" S WR=$$HLDATE^HLFNC(WR,"TS") I WR>0 S WR=$$REPL^PSOVDF1(WR),$P(PSOVAL1,SEPC,4)=WR,$P(PSOVAL1,SEPC,7)="FILL"
 ; (1~5-26.1)
 S WR=$$GET^PSOVDF2(.GL,3,5)
 I $G(WR)'="" D
 .S WR=$$HLDATE^HLFNC(WR,"TS") I WR>0 S WR=$$REPL^PSOVDF1(WR),$P(PSOVAL1,SEPC,5)=WR,$P(PSOVAL1,SEPC,7)=$P(PSOVAL1,SEPC,7)_"/CANCEL"
 E  S WR=$$GET^PSOVDF2(.GL,2,6) I $G(WR)'="" D
 .  S WR=$$HLDATE^HLFNC(WR,"TS") I WR>0 S WR=$$REPL^PSOVDF1(WR),$P(PSOVAL1,SEPC,5)=WR,$P(PSOVAL1,SEPC,7)=$P(PSOVAL1,SEPC,7)_"/EXPIRATION"
 S $P(VAL,SEPR)=PSOVAL1
 S WR=""
 Q
 ;
REM ;Remarks for Original Fill
 S MSG="",CTR=0
 S VAL=$$GET^PSOVDF2(.GL,3,7)
 I $G(VAL)="" Q
 S VAL=$$REPL^PSOVDF1(VAL)
 D PUT(3)
 S CTR=CTR+1,VAL=CTR D PUT(1)
 S VAL="RE"_SEPC_"REMARKS"_SEPC_SRC_"_12" D PUT(4)
 S MSG="NTE"_SEPF_MSG D OUT^PSOVDF2
 Q
 ;
DEL ;Deletion comments
 S MSG=""
 S VAL=$$GET^PSOVDF2(.GL,"D",1)
 I $G(VAL)="" Q
 S VAL=$$REPL^PSOVDF1(VAL)
 D PUT(3)
 S CTR=CTR+1,VAL=CTR D PUT(1)
 S VAL="DE"_SEPC_"DELETION COMMENTS"_SEPC_SRC_"_108" D PUT(4)
 S MSG="NTE"_SEPF_MSG D OUT^PSOVDF2
 Q
 ;
CLOZ ; Clozapine Dosage
 S VAL=$$REPL^PSOVDF1(VAL)
 D PUT(5)
 S CTR=CTR+1,VAL=CTR D PUT(1)
 S VAL="NM" D PUT(2)
 S VAL="CLOZAPINE DOSAGE" D PUT(3)
 S VAL="MG/DAY" D PUT(6)
 S VAL="F" D PUT(11)
 S MSG="OBX"_SEPF_MSG D OUT^PSOVDF2
 Q
 ;
WBC ; WBC results
 S VAL=$$REPL^PSOVDF1(VAL)
 D PUT(5)
 S CTR=CTR+1,VAL=CTR D PUT(1)
 S VAL="NM" D PUT(2)
 S VAL="WBC RESULTS" D PUT(3)
 S VAL="F" D PUT(11)
 ; (14-303)
 S VAL=$$GET^PSOVDF2(.GL,"SAND",3)
 I $G(VAL)'="" S VAL=$$HLDATE^HLFNC(VAL,"TS") I VAL>0 S VAL=$$REPL^PSOVDF1(VAL) D PUT(14)
 S MSG="OBX"_SEPF_MSG D OUT^PSOVDF2
 Q
PRC ;Provider Comments, do not piece out data, can contain up-arrow
 S MSG=""
 I '$D(GL("PRC")) Q
 S VAL="" K TEMP M TEMP=GL("PRC") S VAL=$$SSETZ(.TEMP,1)
 I $G(VAL)="" Q
 D PUT(3)
 S CTR=CTR+1,VAL=CTR D PUT(1)
 S VAL="PR"_SEPC_"PROVIDER COMMENTS"_SEPC_HLINST_"_52.039_.01" D PUT(4)
 S MSG="NTE"_SEPF_MSG D OUT^PSOVDF2
 Q
SSETZ(GLOBAL,P) ;Format Provider Comments
 N RES,PSOVPCOM,PSOVDFD1,X
 S (RES,X)="",PSOVDFD1=0
SSET10Z S PSOVDFD1=$O(GLOBAL(PSOVDFD1)) G SSETQZ:'PSOVDFD1
 S PSOVPCOM=GLOBAL(PSOVDFD1,0) I PSOVPCOM="" G SSET10Z
 I $G(RES)'="" S RES=RES_" "_PSOVPCOM
 E  S RES=PSOVPCOM
 G SSET10Z
SSETQZ ;
 I $G(RES)'="" S RES=$$REPL^PSOVDF1(RES)
 Q RES
 ;
 Q
 ;
PUT(P) ; Put in MSG
 I $G(VAL)="" Q
 S $P(MSG,SEPF,P)=VAL
 Q
 ;
SSET(GL,L) ;Instruction field
 N RES,X,Y
 S RES="",Y=0
 Q:$G(L)="" RES
 F  S Y=$O(GL(Y)) Q:'Y  D
 . S X=GL(Y,0),X=$$REPL^PSOVDF1(X) I X'="" D
 . . S X=SEPC_X
 . . I $G(RES)'="" S RES=RES_SEPR_X_SEPC_L
 . . E  S RES=X_SEPC_L
 . . S CTR=CTR+1
 Q RES
 ;
SSETX(GLOBAL,L) ;Format Sig, don't piece out, can possibly contain up-arrow from Provider Comments
 Q:L=""
 N RES,PSOVSIG,PSOVDFD1,X
 S (RES,X)="",PSOVDFD1=0
SSET10X S PSOVDFD1=$O(GLOBAL(PSOVDFD1)) G SSETQX:'PSOVDFD1
 S PSOVSIG=GLOBAL(PSOVDFD1,0) I PSOVSIG'="" D
 .S PSOVSIG=$$REPL^PSOVDF1(PSOVSIG)
 .I $G(RES)'="" S RES=RES_PSOVSIG
 .E  S RES=$S(L[115:SEPC,1:"")_PSOVSIG
 G SSET10X
SSETQX I $G(RES)="" Q RES
 I L[115 S RES=RES_SEPC_L
 E  S RES=RES_SEPC_SEPC_L
 Q RES
 ;
 Q
ORC13 ;
 S WR="",$P(WR,SEPC,2)=VAL
 S VAL=$P($G(^SC(VAL,0)),U) I $G(VAL)'="" S VAL=$$REPL^PSOVDF1(VAL),$P(WR,SEPC)=VAL
 S VAL=WR
 Q
 ;
RXE1OF31 ;
 D RXE31A
 S:WR'="" VAL=WR_SEPR_VAL
 Q
 ;
RXE31 ;
 S VAL=$P($G(^PSDRUG(PSOVDRUG,0)),"^"),VAL=$$REPL^PSOVDF1(VAL)
 S VAL=PSOVDRUG_SEPC_VAL_SEPC_HLINST_"_50_.01"
 Q
 ;
RXE31A ;
 D RXE31
 N CMOP S CMOP=$G(^PSDRUG(PSOVDRUG,"ND"))
 I $P(CMOP,"^",10)'="" S CMOP=$$REPL^PSOVDF1($P(CMOP,"^",10)),VAL=VAL_SEPR_CMOP_SEPC_SEPC_HLINST_"_50_27"
 Q
 ;
RXE6 ;
 N DOSF,DOS,VDOS
 S DOSF="",VDOS=$$GET^PSOVDF2(.GL,"OR1",1)
 Q:VDOS=""
 I $G(VDOS) S DOS=$P($G(^PS(50.7,VDOS,0)),"^",2) D:$G(DOS)
 . S DOSF=$$REPL^PSOVDF1($P($G(^PS(50.606,DOS,0)),"^")) D:DOSF'=""
 . . S VAL=DOS_SEPC_DOSF_SEPC_HLINST_"_50.7_.02"
 . . S VDOS=$$GETVUID^XTID(50.7,.02,DOS) D:$P(VDOS,"^")'=0
 . . . S VDOS=$P(VDOS,"^"),VDOS=$$REPL^PSOVDF1(VDOS) S VAL=VAL_SEPC_VDOS_SEPC_DOSF_SEPC_"99VA_50.7_.02"
 Q
 ;
FT1A7 ;
 S TP=$$GET^PSOVDF2(.GL,"OR1",1)
 S:$G(TP) VAL=$$REPL^PSOVDF1($P($G(^PS(50.7,TP,0)),"^"))
 I VAL'="" S VAL=TP_SEPC_VAL_SEPC_SRC_"_39.2",VFT7=VAL
 Q
 ;
FT1S2 ;  ORIGINAL SEQ# 2
 S VAL=$$GET1^DIQ(52,PSOVDFD0_",",105,"I") Q:VAL=""
 S WR=$$GET1^DIQ(52,PSOVDFD0_",",105) Q:WR=""
 S MSG="",WR=$$REPL^PSOVDF1(WR)
 S VAL=VAL_SEPC_WR_SEPC_SRC_"_105" D PUT(7)
 S VAL=$G(CTR)+1 D PUT(1)
 S VAL=$$GET^PSOVDF2(.GL,2,2)
 I $G(VAL)'="" S VAL=$$HLDATE^HLFNC(VAL,"TS") I VAL>0 S VAL=$$REPL^PSOVDF1(VAL) D PUT(4)
 S VAL="CO" D PUT(6)
 S MSG="FT1"_SEPF_MSG D OUT^PSOVDF2
 Q
 ;
FT1R ; REFILL & PARTIAL
 S VAL=$P(TP,U,11) Q:VAL="" 
 S MSG="",VAL=$$REPL^PSOVDF1(VAL) D PUT(12)
 S VAL=PSOVDFD1 D PUT(1)
 S VAL=$P(TP,U,1) I VAL'="" S VAL=$$HLDATE^HLFNC(VAL,"TS") I VAL>0 S VAL=$$REPL^PSOVDF1(VAL) D PUT(4)
 S VAL="CG" D PUT(6)
 I $G(VFT7) S VAL=VFT7 D PUT(7)
 S MSG="FT1"_SEPF_MSG D OUT^PSOVDF2
 Q
 ;
NSET(GLOBAL) ;Verb-8, Noun-3, Schedule-7, Conjuntion-5
 N I,J,K,L,M,N,O,P,X,Y,Z
 S (Z,X)="",Y=0,M=52.0113
NSET1 ;
 F  S Y=$O(GLOBAL(Y)) Q:'Y  D
 . S X=$G(GLOBAL(Y,0)) Q:X=""
 . F I=9,4,8,6 S N=I-1,O=M_"_"_N,L=HLINST_"_"_O D
 . . S J=$P($G(X),U,I),J=$$REPL^PSOVDF1(J) I J'="" D
 . . . S P=0 I I=6 S J=$$GET1^DIQ(M,Y_","_PSOVDFD0,N) D
 . . . . S K=$$GETVUID^XTID(M,N) I $P(K,"^")'=0 S K=$P(K,"^"),K=$$REPL^PSOVDF1(K),J=K_SEPC_J_SEPC_"99VA_",P=1
 . . . S J=$S(P:"",1:SEPC)_J
 . . . I Z'="" S Z=Z_SEPR_J_$S(P:O,1:SEPC_L)
 . . . E  S Z=J_SEPC_$S(P:O,1:L)
 . . . S CTR=CTR+1
 Q Z
 ;
ORCCS ; ORC 25,4-6 - Checking the CMOP EVENT sub-file (#52.01)
 N X,Y,RF,VU,I,ST S I=0
 F  S I=$O(GL(4,I)) Q:'I  S X=GL(4,I,0) I X'="" S RF=$P(X,"^",3),Y=$P(X,"^",4) D
 . I Y'="" S ST=$$GET1^DIQ(52.01,I_","_PSOVDFD0,3) I ST'="" S VU=$$GETVUID^XTID(52.01,3) D
 . . I $P(VU,"^")'=0 S VU=$P(VU,"^"),VU=$$REPL^PSOVDF1(VU)
 . . E  S VU=""
 . . S ST=$$REPL^PSOVDF1(ST)
 . . S VCMP(RF)=$S(VU'="":VU,1:Y)_SEPC_ST_SEPC_$S(VU'="":"99VA",1:HLINST)_"_52_400"
 Q
 ;
ORC25 ;
 N PSOVALE S PSOVALE=$G(PSOVAR(52,PSOVEN,100,"E")),PSOVALE=$$REPL^PSOVDF1(PSOVALE)
 S PSOVLV=$$GETVUID^XTID(52,100,VAL)
 I $P($G(PSOVLV),"^")'=0 S PSOVLV=$P(PSOVLV,"^"),PSOVLV=$$REPL^PSOVDF1(PSOVLV) D  Q
 . S VAL=$G(PSOVLV)_SEPC_$G(PSOVALE)_SEPC_"99VA_52_100"
 I $G(VAL)'="" S VAL=$$REPL^PSOVDF1(VAL),VAL=VAL_SEPC_$G(PSOVALE)_SEPC_SRC_"_100"
 Q
  ; 
PREM ;
 S VAL="RE"_SEPC_"REMARKS"_SEPC_HLINST_"_52.2_.03"
 Q
 ;
RREM ;
 S VAL="RE"_SEPC_"REMARKS"_SEPC_HLINST_"_52.1_3"
 Q
 ;