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