- 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 Feb 19, 2025@00:02:42 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 ;