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

PSOVDF3.m

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