- PSXBLD1 ;BIR/BAB,HTW,WPB-Document Data for Transmission ;10/15/98 10:38 AM
- ;;2.0;CMOP;**3,18,19,42,41,49,57,64,75**;11 Apr 97;Build 5
- ;Reference to ^PSRX( supported by DBIA #1977
- ;Reference to ^PSDRUG( supported by DBIA #1983
- ;Reference to ^PS(55, supported by DBIA #2228
- ;Reference to ^PS(59.7, supported by DBIA #694
- ;Reference to ^PS(59, supported by DBIA #1976
- ;Reference to PROD2^PSNAPIS supported by DBIA #2531
- MRX ;Multi rx
- G:'$P(PSOPAR,"^",18) SUS
- N RX F ZZ=0:0 S ZZ=$O(^PS(55,DFN,"P",ZZ)) Q:'ZZ S NBR=0 D RZX
- BUILD ;
- F PSA=0:0 S PSA=$O(RX(PSA)) Q:'PSA D SCRNEW
- K NAME,REFILL,PSDT2,NBR,PSRX,PSA,TN,AMC,PSRFL,X1,X2,PSRXX,RXNUM,ZZ
- G SUS
- SCRNEW ;
- S IEN50=+$P(^PSRX(PSA,0),U,6),NAME=$P(^PSDRUG(IEN50,0),U)
- I '$D(^PSDRUG(IEN50,"ND")) G S1
- S IENDF=$P($G(^PSDRUG(IEN50,"ND")),U),ZD1=$P($G(^("ND")),U,3)
- I $G(IENDF),($G(ZD1)) S ZX=$$PROD2^PSNAPIS(IENDF,ZD1),ZNDF=$P($G(ZX),"^")
- S1 S ZPRT=$S($G(ZNDF):ZNDF,1:NAME) K ZNDF,IENDF,NAME,IEN50,ZD1
- S ZPRT=$E(ZPRT,1,30)
- S REFILL=$P(RX(PSA),"^",2)
- S PSDT2=$P(RX(PSA),"^",1),PSDT2=PSDT2+17000000
- S RXNUM=$P($G(^PSRX(PSA,0)),"^")
- S NBR=NBR+1,PSXORD("M",NBR)="NTE|5||"_RXNUM_"\F\"_ZPRT_"\F\"_REFILL_"\F\"_PSDT2_$S($P(PSOPAR,"^",19):"\F\"_PSOINST_"-"_PSA,1:"")
- Q
- REFILL F AMC=0:0 S AMC=$O(^PSRX(PSRXX,1,AMC)) Q:'AMC S PSRFL=PSRFL-1
- I PSRFL>0 S X1=DT,X2=$P(^PSRX(PSRXX,0),"^",8)-10 D C^%DTC I X'<$P(^(2),"^",6) S PSRFL=0
- Q
- RZX S PSRXX=+^PS(55,DFN,"P",ZZ,0) I $D(^PSRX(PSRXX,0)) S PSRFL=$P(^(0),"^",9) D:$D(^(1))&PSRFL REFILL I PSRFL>0,$P(^PSRX(PSRXX,"STA"),"^",1)<10,13456'[$E($P(^("STA"),"^",1)),$P(^(2),"^",6)>DT S RX(PSRXX)=$P(^(2),"^",6)_"^"_PSRFL
- Q
- SUS ;Susp Notif-(PSXDTRG-last date transmitted)
- Q:'$G(DFN)!('$G(PSXDTRG))
- S CT=1
- F I=PSXDTRG:0 S I=$O(^PS(55,DFN,"P","A",I)) Q:'I D
- .F J=0:0 S J=$O(^PS(55,DFN,"P","A",I,J)) Q:'J S JJ=J D:$D(JJ) S CT=CT+1
- ..S NODE=$G(^PSRX(JJ,0)) Q:NODE']""
- ..S STATUS=+$P(^PSRX(JJ,"STA"),"^",1) Q:STATUS'=5!(STATUS>10)
- ..Q:$D(^PSX(550.2,PSXBAT,15,"B",JJ)) ;built in PSXRPPL PSX*2*42
- ..S ERX=$P(NODE,U)
- ..S IEN50=$P(NODE,"^",6),NAME=$P(^PSDRUG(IEN50,0),U)
- ..I '$D(^PSDRUG(IEN50,"ND")) G S2
- ..S IENDF=$P($G(^PSDRUG(IEN50,"ND")),U),ZD1=$P($G(^("ND")),U,3)
- ..I $G(IENDF),($G(ZD1)) S ZX=$$PROD2^PSNAPIS(IENDF,ZD1),ZNDF=$P($G(ZX),"^")
- S2 ..S ZPRT=$S($G(ZNDF):ZNDF,1:NAME)
- ..S ZPRT=$E(ZPRT,1,30)
- ..S PSXORD("E",CT)="NTE|6||"_ERX_"\F\"_ZPRT
- ..K NODE,STATUS,ERX,IEN50,IENDF,ZD1,ZNDF,ZPRT,NAME,ZX
- K I,J,NODE,STATUS,JJ,ZPRT,NAME,IENDF,IEN50,CT,RX
- Q
- DIV ;NTE|1||Site #\S\Div Name\S\Facility #\F\Street Add 1\S\Street Add 2\S\City\S\State Abbrev\S\Zip Code\F\Area Code & Phone #
- S PSXERFLG=0,PSXER=3
- S TNODE=$G(^PS(59,PSOSITE,0))
- ;Set site address to refill div if selected in system parameters
- I $P($G(^PS(59.7,1,40.1)),"^",4) S REFDIV=$P(^(40.1),"^",4) D
- .S TNODE1=$G(^PS(59,REFDIV,0)),TNODE=TNODE1 K TNODE1
- S PSXFAC=$P($G(PSXSYS),U,2)
- S STATE=$P(TNODE,"^",8),SITE=$P(TNODE,U,6) S (TEMP,Y)=TNODE
- S:STATE="" PSXER=PSXER_"^"_1,PSXERFLG=1
- S:SITE="" PSXER=PSXER_"^"_2,PSXERFLG=1
- S:$P(TNODE,U,1)="" PSXER=PSXER_"^"_3,PSXERFLG=1
- S:$P(TNODE,U,2)="" PSXER=PSXER_"^"_4,PSXERFLG=1
- S:$P(TNODE,U,7)="" PSXER=PSXER_"^"_5,PSXERFLG=1
- S:$P(TNODE,U,5)="" PSXER=PSXER_"^"_6,PSXERFLG=1
- S:$P(TNODE,U,3)="" PSXER=PSXER_"^"_7,PSXERFLG=1
- S:$P(TNODE,U,4)="" PSXER=PSXER_"^"_8,PSXERFLG=1
- ;VMP OIFO BAY PINES;ELR;PSX*2*57 SET PSXERFLG=0 NEXT LINE AND LINE AFTER THAT
- I PSXERFLG=1 D ER1^PSXERR S PSXERFLG=0,PSXDIVER=1 Q
- Q:$G(PSXPRECK)=1
- S SZIP=$P(TNODE,U,5) I $L(SZIP)>5 S SZIP=$E(SZIP,1,5)_"-"_$E(SZIP,6,9)
- S PSXORD("A")="NTE|1||"_SITE_"\S\"_$P(TNODE,U,1)_"\S\"_PSXFAC_"\F\"_$P(TNODE,U,2)_"\S\\S\"_$P(TNODE,U,7)_"\S\"_$P(^DIC(5,STATE,0),U,2)_"\S\"_SZIP_"\F\"_"("_$P(TNODE,U,3)_") "_$P(TNODE,U,4)
- K SZIP
- ORD ;
- S DIWL=1,DIWR=45,DIWF="C45"
- F NODE=6,7,4 K ^UTILITY($J,"W") S (RECL,REC)=0 F S REC=$O(^PS(59,PSOSITE,NODE,REC)) Q:REC'>0 S X=^(REC,0),NODE=NODE D
- . I REC'>7 S Y=X D STRIP^PSXBLD S X=Y D ^DIWP,SET I 1
- . E S WARN(NODE)=REC
- D:$D(WARN) WARN
- K DIWF,DIWL,DIWR,I,NODE,STATE,SITE,TNODE,NUM,REC,Y,Y,X,Z,^UTILITY($J,"W")
- Q
- WARN ;send msg
- S XMSUB=">>WARNING<< CMOP Pharmacy Site Prescription Instructions"
- ;N TXT,XT
- S XT(6)="NARRATIVE REFILLABLE RX"
- S XT(7)="NARRATIVE NON REFILLABLE RX"
- S XT(4)="NARRATIVE FOR COPAY DOCUMENT"
- S TXT(1)="The following Pharmacy Site instruction(s) exceed seven lines."
- S TXT(2)="This exceeds CMOP limits."
- S TXT(3)="Lines beyond seven are not being sent to the CMOP."
- S TXT(4)=" ",TXT(5)="Pharmacy Site: "_$$GET1^DIQ(59,PSOSITE,.01),L=5
- F NODE=6,7,4 I $DATA(WARN(NODE)) S L=L+1,TXT(L)=XT(NODE)_" "_WARN(NODE)_" lines"
- S XMTEXT="TXT("
- D GRP1^PSXNOTE
- S XMY(DUZ)=""
- D ^XMD
- Q
- SET ;
- K PSXORDD S NUM=0
- F S NUM=$O(^UTILITY($J,"W",1,NUM)) Q:NUM'>0 S PSXORDD(NUM)=$G(^UTILITY($J,"W",1,NUM,0)) S PSXORDD(NUM)=$S(NODE=4:"NTE|4||"_PSXORDD(NUM),NODE=6:"NTE|2||"_PSXORDD(NUM),NODE=7:"NTE|3||"_PSXORDD(NUM),1:0)
- ;F CNT=1:2 S CNT=$O(PSXORDD(CNT)) Q:CNT="" S XX=$L(PSXORDD(CNT)),PSXORDD(CNT-1)=PSXORDD(CNT-1)_"\R\"_$E(PSXORDD(CNT),8,XX) K PSXORDD(CNT)
- S %X="PSXORDD(",%Y=$S(NODE=4:"PSXORD(""D"",",NODE=6:"PSXORD(""B"",",NODE=7:"PSXORD(""C"",",1:0) D %XY^%RCR K %X,%Y,TEMP
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSXBLD1 5256 printed Jan 18, 2025@02:44:43 Page 2
- PSXBLD1 ;BIR/BAB,HTW,WPB-Document Data for Transmission ;10/15/98 10:38 AM
- +1 ;;2.0;CMOP;**3,18,19,42,41,49,57,64,75**;11 Apr 97;Build 5
- +2 ;Reference to ^PSRX( supported by DBIA #1977
- +3 ;Reference to ^PSDRUG( supported by DBIA #1983
- +4 ;Reference to ^PS(55, supported by DBIA #2228
- +5 ;Reference to ^PS(59.7, supported by DBIA #694
- +6 ;Reference to ^PS(59, supported by DBIA #1976
- +7 ;Reference to PROD2^PSNAPIS supported by DBIA #2531
- MRX ;Multi rx
- +1 if '$PIECE(PSOPAR,"^",18)
- GOTO SUS
- +2 NEW RX
- FOR ZZ=0:0
- SET ZZ=$ORDER(^PS(55,DFN,"P",ZZ))
- if 'ZZ
- QUIT
- SET NBR=0
- DO RZX
- BUILD ;
- +1 FOR PSA=0:0
- SET PSA=$ORDER(RX(PSA))
- if 'PSA
- QUIT
- DO SCRNEW
- +2 KILL NAME,REFILL,PSDT2,NBR,PSRX,PSA,TN,AMC,PSRFL,X1,X2,PSRXX,RXNUM,ZZ
- +3 GOTO SUS
- SCRNEW ;
- +1 SET IEN50=+$PIECE(^PSRX(PSA,0),U,6)
- SET NAME=$PIECE(^PSDRUG(IEN50,0),U)
- +2 IF '$DATA(^PSDRUG(IEN50,"ND"))
- GOTO S1
- +3 SET IENDF=$PIECE($GET(^PSDRUG(IEN50,"ND")),U)
- SET ZD1=$PIECE($GET(^("ND")),U,3)
- +4 IF $GET(IENDF)
- IF ($GET(ZD1))
- SET ZX=$$PROD2^PSNAPIS(IENDF,ZD1)
- SET ZNDF=$PIECE($GET(ZX),"^")
- S1 SET ZPRT=$SELECT($GET(ZNDF):ZNDF,1:NAME)
- KILL ZNDF,IENDF,NAME,IEN50,ZD1
- +1 SET ZPRT=$EXTRACT(ZPRT,1,30)
- +2 SET REFILL=$PIECE(RX(PSA),"^",2)
- +3 SET PSDT2=$PIECE(RX(PSA),"^",1)
- SET PSDT2=PSDT2+17000000
- +4 SET RXNUM=$PIECE($GET(^PSRX(PSA,0)),"^")
- +5 SET NBR=NBR+1
- SET PSXORD("M",NBR)="NTE|5||"_RXNUM_"\F\"_ZPRT_"\F\"_REFILL_"\F\"_PSDT2_$SELECT($PIECE(PSOPAR,"^",19):"\F\"_PSOINST_"-"_PSA,1:"")
- +6 QUIT
- REFILL FOR AMC=0:0
- SET AMC=$ORDER(^PSRX(PSRXX,1,AMC))
- if 'AMC
- QUIT
- SET PSRFL=PSRFL-1
- +1 IF PSRFL>0
- SET X1=DT
- SET X2=$PIECE(^PSRX(PSRXX,0),"^",8)-10
- DO C^%DTC
- IF X'<$PIECE(^(2),"^",6)
- SET PSRFL=0
- +2 QUIT
- RZX SET PSRXX=+^PS(55,DFN,"P",ZZ,0)
- IF $DATA(^PSRX(PSRXX,0))
- SET PSRFL=$PIECE(^(0),"^",9)
- if $DATA(^(1))&PSRFL
- DO REFILL
- IF PSRFL>0
- IF $PIECE(^PSRX(PSRXX,"STA"),"^",1)<10
- IF 13456'[$EXTRACT($PIECE(^("STA"),"^",1))
- IF $PIECE(^(2),"^",6)>DT
- SET RX(PSRXX)=$PIECE(^(2),"^",6)_"^"_PSRFL
- +1 QUIT
- SUS ;Susp Notif-(PSXDTRG-last date transmitted)
- +1 if '$GET(DFN)!('$GET(PSXDTRG))
- QUIT
- +2 SET CT=1
- +3 FOR I=PSXDTRG:0
- SET I=$ORDER(^PS(55,DFN,"P","A",I))
- if 'I
- QUIT
- Begin DoDot:1
- +4 FOR J=0:0
- SET J=$ORDER(^PS(55,DFN,"P","A",I,J))
- if 'J
- QUIT
- SET JJ=J
- if $DATA(JJ)
- Begin DoDot:2
- +5 SET NODE=$GET(^PSRX(JJ,0))
- if NODE']""
- QUIT
- +6 SET STATUS=+$PIECE(^PSRX(JJ,"STA"),"^",1)
- if STATUS'=5!(STATUS>10)
- QUIT
- +7 ;built in PSXRPPL PSX*2*42
- if $DATA(^PSX(550.2,PSXBAT,15,"B",JJ))
- QUIT
- +8 SET ERX=$PIECE(NODE,U)
- +9 SET IEN50=$PIECE(NODE,"^",6)
- SET NAME=$PIECE(^PSDRUG(IEN50,0),U)
- +10 IF '$DATA(^PSDRUG(IEN50,"ND"))
- GOTO S2
- +11 SET IENDF=$PIECE($GET(^PSDRUG(IEN50,"ND")),U)
- SET ZD1=$PIECE($GET(^("ND")),U,3)
- +12 IF $GET(IENDF)
- IF ($GET(ZD1))
- SET ZX=$$PROD2^PSNAPIS(IENDF,ZD1)
- SET ZNDF=$PIECE($GET(ZX),"^")
- S2 SET ZPRT=$SELECT($GET(ZNDF):ZNDF,1:NAME)
- +1 SET ZPRT=$EXTRACT(ZPRT,1,30)
- +2 SET PSXORD("E",CT)="NTE|6||"_ERX_"\F\"_ZPRT
- +3 KILL NODE,STATUS,ERX,IEN50,IENDF,ZD1,ZNDF,ZPRT,NAME,ZX
- End DoDot:2
- SET CT=CT+1
- End DoDot:1
- +4 KILL I,J,NODE,STATUS,JJ,ZPRT,NAME,IENDF,IEN50,CT,RX
- +5 QUIT
- DIV ;NTE|1||Site #\S\Div Name\S\Facility #\F\Street Add 1\S\Street Add 2\S\City\S\State Abbrev\S\Zip Code\F\Area Code & Phone #
- +1 SET PSXERFLG=0
- SET PSXER=3
- +2 SET TNODE=$GET(^PS(59,PSOSITE,0))
- +3 ;Set site address to refill div if selected in system parameters
- +4 IF $PIECE($GET(^PS(59.7,1,40.1)),"^",4)
- SET REFDIV=$PIECE(^(40.1),"^",4)
- Begin DoDot:1
- +5 SET TNODE1=$GET(^PS(59,REFDIV,0))
- SET TNODE=TNODE1
- KILL TNODE1
- End DoDot:1
- +6 SET PSXFAC=$PIECE($GET(PSXSYS),U,2)
- +7 SET STATE=$PIECE(TNODE,"^",8)
- SET SITE=$PIECE(TNODE,U,6)
- SET (TEMP,Y)=TNODE
- +8 if STATE=""
- SET PSXER=PSXER_"^"_1
- SET PSXERFLG=1
- +9 if SITE=""
- SET PSXER=PSXER_"^"_2
- SET PSXERFLG=1
- +10 if $PIECE(TNODE,U,1)=""
- SET PSXER=PSXER_"^"_3
- SET PSXERFLG=1
- +11 if $PIECE(TNODE,U,2)=""
- SET PSXER=PSXER_"^"_4
- SET PSXERFLG=1
- +12 if $PIECE(TNODE,U,7)=""
- SET PSXER=PSXER_"^"_5
- SET PSXERFLG=1
- +13 if $PIECE(TNODE,U,5)=""
- SET PSXER=PSXER_"^"_6
- SET PSXERFLG=1
- +14 if $PIECE(TNODE,U,3)=""
- SET PSXER=PSXER_"^"_7
- SET PSXERFLG=1
- +15 if $PIECE(TNODE,U,4)=""
- SET PSXER=PSXER_"^"_8
- SET PSXERFLG=1
- +16 ;VMP OIFO BAY PINES;ELR;PSX*2*57 SET PSXERFLG=0 NEXT LINE AND LINE AFTER THAT
- +17 IF PSXERFLG=1
- DO ER1^PSXERR
- SET PSXERFLG=0
- SET PSXDIVER=1
- QUIT
- +18 if $GET(PSXPRECK)=1
- QUIT
- +19 SET SZIP=$PIECE(TNODE,U,5)
- IF $LENGTH(SZIP)>5
- SET SZIP=$EXTRACT(SZIP,1,5)_"-"_$EXTRACT(SZIP,6,9)
- +20 SET PSXORD("A")="NTE|1||"_SITE_"\S\"_$PIECE(TNODE,U,1)_"\S\"_PSXFAC_"\F\"_$PIECE(TNODE,U,2)_"\S\\S\"_$PIECE(TNODE,U,7)_"\S\"_$PIECE(^DIC(5,STATE,0),U,2)_"\S\"_SZIP_"\F\"_"("_$PIECE(TNODE,U,3)_") "_$PIECE(TNODE,U,4)
- +21 KILL SZIP
- ORD ;
- +1 SET DIWL=1
- SET DIWR=45
- SET DIWF="C45"
- +2 FOR NODE=6,7,4
- KILL ^UTILITY($JOB,"W")
- SET (RECL,REC)=0
- FOR
- SET REC=$ORDER(^PS(59,PSOSITE,NODE,REC))
- if REC'>0
- QUIT
- SET X=^(REC,0)
- SET NODE=NODE
- Begin DoDot:1
- +3 IF REC'>7
- SET Y=X
- DO STRIP^PSXBLD
- SET X=Y
- DO ^DIWP
- DO SET
- IF 1
- +4 IF '$TEST
- SET WARN(NODE)=REC
- End DoDot:1
- +5 if $DATA(WARN)
- DO WARN
- +6 KILL DIWF,DIWL,DIWR,I,NODE,STATE,SITE,TNODE,NUM,REC,Y,Y,X,Z,^UTILITY($JOB,"W")
- +7 QUIT
- WARN ;send msg
- +1 SET XMSUB=">>WARNING<< CMOP Pharmacy Site Prescription Instructions"
- +2 ;N TXT,XT
- +3 SET XT(6)="NARRATIVE REFILLABLE RX"
- +4 SET XT(7)="NARRATIVE NON REFILLABLE RX"
- +5 SET XT(4)="NARRATIVE FOR COPAY DOCUMENT"
- +6 SET TXT(1)="The following Pharmacy Site instruction(s) exceed seven lines."
- +7 SET TXT(2)="This exceeds CMOP limits."
- +8 SET TXT(3)="Lines beyond seven are not being sent to the CMOP."
- +9 SET TXT(4)=" "
- SET TXT(5)="Pharmacy Site: "_$$GET1^DIQ(59,PSOSITE,.01)
- SET L=5
- +10 FOR NODE=6,7,4
- IF $DATA(WARN(NODE))
- SET L=L+1
- SET TXT(L)=XT(NODE)_" "_WARN(NODE)_" lines"
- +11 SET XMTEXT="TXT("
- +12 DO GRP1^PSXNOTE
- +13 SET XMY(DUZ)=""
- +14 DO ^XMD
- +15 QUIT
- SET ;
- +1 KILL PSXORDD
- SET NUM=0
- +2 FOR
- SET NUM=$ORDER(^UTILITY($JOB,"W",1,NUM))
- if NUM'>0
- QUIT
- SET PSXORDD(NUM)=$GET(^UTILITY($JOB,"W",1,NUM,0))
- SET PSXORDD(NUM)=$SELECT(NODE=4:"NTE|4||"_PSXORDD(NUM),NODE=6:"NTE|2||"_PSXORDD(NUM),NODE=7:"NTE|3||"_PSXORDD(NUM),1:0)
- +3 ;F CNT=1:2 S CNT=$O(PSXORDD(CNT)) Q:CNT="" S XX=$L(PSXORDD(CNT)),PSXORDD(CNT-1)=PSXORDD(CNT-1)_"\R\"_$E(PSXORDD(CNT),8,XX) K PSXORDD(CNT)
- +4 SET %X="PSXORDD("
- SET %Y=$SELECT(NODE=4:"PSXORD(""D"",",NODE=6:"PSXORD(""B"",",NODE=7:"PSXORD(""C"",",1:0)
- DO %XY^%RCR
- KILL %X,%Y,TEMP
- +5 QUIT