- PSSCPRS1 ;BIR/ASJ-API for CPRS ;09/07/00
- ;;1.0;PHARMACY DATA MANAGEMENT;**38**;9/30/97
- ;Reference to $$CPRS^PSNAPIS supported by DBIA 2531
- ;
- ;PSDD -Dispense Drug, PSOI-Orderable Item, PSPK-Package
- ;PSDOS-Dosage, PSDUD-Dispense Units per Dosage
- ;RESULT(1)=Dispense Drug^Dosage^Orderable Item^Dispense Units per Dosage
- ;RESULT(2)=ERROR DESCRIPTION
- ;
- G:+PSDUD>0 ND
- I 'PSSND1!('PSSND3) S RESULT(0)=-1,RESULT(2)="Problem in ND node!" Q
- S X=$$DFSU^PSNAPIS(PSSND1,PSSND3) I $P(X,U,4)="" D NNSI Q
- I $P(X,U)'="" D NNMI
- Q
- ND ; I/P to O/P Transfer Rules - Numeric Dosages
- ;
- FR541 I '$P($G(^PSDRUG(+PSDD,"I")),"^")!($P($G(^("I")),"^")'<DT),(PSUSE["O") S RESULT(0)=1,RESULT(1)=PSDD_"^"_PSDOS,RESULT(2)="FR541" Q
- ;
- ;
- FR542 S PSCORR=$P(PSNODE8,U,5) I PSCORR I '$P($G(^PSDRUG(PSCORR,"I")),"^")!($P($G(^("I")),"^")'<DT) S PSNODE2=$G(^PSDRUG(PSCORR,2)) D CP D
- .F PDS=0:0 S PDS=$O(^PSDRUG(PSCORR,"DOS1",PDS)) Q:'PDS D
- ..S PSDOS1=^PSDRUG(PSCORR,"DOS1",PDS,0),PDOS=$G(^PSDRUG(PSCORR,"DOS")),PSSTR=$P(PDOS,U),PSUNT=$P(PDOS,U,2)
- ..I PSDOS'="",($P(PSDOS1,U,2)=PSDOS),($P(PSNODE2,U,3)["O")&($P(PSDOS1,U,3)["O") D
- ...I $P(X,U,4)=$P(PSDOSN,U,2),$P(X,"^")=$P(X1,"^") S RESULT(0)=1,RESULT(1)=PSCORR_"^"_PSDOS,RESULT(2)="FR542" Q
- Q:RESULT(0)=1
- ;
- ;
- FR543 S AA=0 F S AA=$O(^PSDRUG("ASP",+PSOI,AA)) Q:'AA D
- .I $D(^PSDRUG(AA,"DOS1",0)) F PDS=0:0 S PDS=$O(^PSDRUG(AA,"DOS1",PDS)) Q:'PDS D
- ..S BB=^PSDRUG(AA,"DOS1",PDS,0),PSNODE2=$G(^PSDRUG(AA,2))
- ..I PSDOS'="",($P(BB,U,2)=PSDOS)&($P(PSNODE2,U,3)["O")&($P(BB,U,3)["O") S FLAG=1,PSLI(AA)=""
- ;
- I FLAG S AA=0 F S AA=$O(PSLI(AA)) Q:'AA F PDS=0:0 S PDS=$O(^PSDRUG(AA,"DOS1",PDS)) Q:'PDS D
- .S POSDOS=^PSDRUG(AA,"DOS1",PDS,0) S PSDPD=+$P(POSDOS,U)
- .I '$D(PSDUPD)!(PSDPD<PSDUPD) S PSDUPD=PSDPD
- I FLAG S RESULT(0)=1,RESULT(1)=AA_"^"_$P(POSDOS,U,2),RESULT(2)="FR543",FLAG=0 Q
- ;
- ;
- FR544 S PSCORR=$P(PSNODE8,U,5) I PSCORR I '$P($G(^PSDRUG(PSCORR,"I")),"^")!($P($G(^("I")),"^")'<DT) D CP D
- .I $P(X,U,4)=$P(PSDOSN,U,2),$P(X,"^")=$P(X1,"^") S RESULT(0)=1,RESULT(1)=PSDD
- Q:RESULT(0)=1
- ;
- ;
- FR545 S RESULT(0)=-1,RESULT(2)="All Numeric Dosage Rules failed!"
- Q
- ;
- ;
- NNSI ; I/P to O/P Transfer Rules- NON-NUMERIC Single Ingredient
- ;
- FR551 I '$P($G(^PSDRUG(+PSDD,"I")),"^")!($P($G(^("I")),"^")'<DT),(PSUSE["U")&(PSUSE["O") S RESULT(0)=1,RESULT(1)=PSDD_"^"_PSDOS_"^"_PSOI_"^"_PSDUD Q
- ;
- ;
- FR552 I PSUSE'["U",(PSUSE'["O") S PSCORR=$P(PSNODE8,U,5) I PSCORR I '$P($G(^PSDRUG(PSCORR,"I")),"^")!($P($G(^("I")),"^")'<DT) D CP D Q:RESULT(0)=1
- .S PDOS=$G(^PSDRUG(PSCORR,"DOS")),PSSTR=$P(PDOS,U),PSUNT=$P(PDOS,U,2)
- .I (PSSTR'="")&(PSUNT'=""),(PSSTR=PSNDSTR)&(PSUNT=PSNDUN) D
- ..I $P(X,U,4)=$P(PSDOSN,U,2),$P(X,"^")=$P(X1,"^") S RESULT(0)=1,RESULT(1)=PSCORR_"^"_PSDOS_"^"_PSOI_"^"_PSDUD
- ;
- ;
- FR553 S AA=0 F S AA=$O(^PSDRUG("ASP",+PSOI,AA)) Q:'AA D
- .S PSSTR=$P($G(^PSDRUG(AA,"DOS")),U),PSUNT=$P($G(^("DOS")),U,2)
- .S X=$$CPRS^PSNAPIS(PSSND1,PSSND3)
- .S PSNDSTR=$P(X,U,3),PSNDUN=$P(X,U,4)
- .I (PSSTR'="")&(PSUNT'=""),(PSSTR=PSNDSTR)&(PSUNT=PSNDUN) S RESULT(0)=1,RESULT(1)=AA_"^"_PSDOS_"^"_PSOI_"^"_PSDUD
- Q:RESULT(0)=1
- ;
- FR554 S RESULT(0)=-1
- Q
- ;
- NNMI ; I/P to O/P Transfer Rules- Multi-Ingredient
- ;
- FR561 I '$P($G(^PSDRUG(+PSDD,"I")),"^")!($P($G(^("I")),"^")'<DT),(PSUSE["U")&(PSUSE["O") S RESULT(0)=1,RESULT(1)=PSDD_"^"_PSDOS_"^"_PSOI_"^"_PSDUD Q
- ;
- ;
- FR562 I PSUSE'["U",(PSUSE'["O") S PSCORR=$P(PSNODE8,U,5) I PSCORR I '$P($G(^PSDRUG(PSCORR,"I")),"^")!($P($G(^("I")),"^")'<DT) D CP D
- .I $P(X,U,4)=$P(PSDOSN,U,2),$P(X,"^")=$P(X1,"^") S RESULT(0)=1,RESULT(1)=PSCORR_"^"_PSOD_"^"_PSSOP_"^"_PSDUD
- Q
- CP ;
- S PSND=$G(^PSDRUG(PSCORR,"ND")) S X=$$CPRS^PSNAPIS($P(PSND,"^"),$P(PSND,"^",3)),PSNDSTR=$P(X,U,3),PSNDUN=$P(X,U,4)
- S PSDOSN=$G(^PSDRUG(PSDD,"DOS")),X1=$$CPRS^PSNAPIS(PSSND1,PSSND3)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSSCPRS1 3819 printed Feb 18, 2025@23:56:36 Page 2
- PSSCPRS1 ;BIR/ASJ-API for CPRS ;09/07/00
- +1 ;;1.0;PHARMACY DATA MANAGEMENT;**38**;9/30/97
- +2 ;Reference to $$CPRS^PSNAPIS supported by DBIA 2531
- +3 ;
- +4 ;PSDD -Dispense Drug, PSOI-Orderable Item, PSPK-Package
- +5 ;PSDOS-Dosage, PSDUD-Dispense Units per Dosage
- +6 ;RESULT(1)=Dispense Drug^Dosage^Orderable Item^Dispense Units per Dosage
- +7 ;RESULT(2)=ERROR DESCRIPTION
- +8 ;
- +9 if +PSDUD>0
- GOTO ND
- +10 IF 'PSSND1!('PSSND3)
- SET RESULT(0)=-1
- SET RESULT(2)="Problem in ND node!"
- QUIT
- +11 SET X=$$DFSU^PSNAPIS(PSSND1,PSSND3)
- IF $PIECE(X,U,4)=""
- DO NNSI
- QUIT
- +12 IF $PIECE(X,U)'=""
- DO NNMI
- +13 QUIT
- ND ; I/P to O/P Transfer Rules - Numeric Dosages
- +1 ;
- FR541 IF '$PIECE($GET(^PSDRUG(+PSDD,"I")),"^")!($PIECE($GET(^("I")),"^")'<DT)
- IF (PSUSE["O")
- SET RESULT(0)=1
- SET RESULT(1)=PSDD_"^"_PSDOS
- SET RESULT(2)="FR541"
- QUIT
- +1 ;
- +2 ;
- FR542 SET PSCORR=$PIECE(PSNODE8,U,5)
- IF PSCORR
- IF '$PIECE($GET(^PSDRUG(PSCORR,"I")),"^")!($PIECE($GET(^("I")),"^")'<DT)
- SET PSNODE2=$GET(^PSDRUG(PSCORR,2))
- DO CP
- Begin DoDot:1
- +1 FOR PDS=0:0
- SET PDS=$ORDER(^PSDRUG(PSCORR,"DOS1",PDS))
- if 'PDS
- QUIT
- Begin DoDot:2
- +2 SET PSDOS1=^PSDRUG(PSCORR,"DOS1",PDS,0)
- SET PDOS=$GET(^PSDRUG(PSCORR,"DOS"))
- SET PSSTR=$PIECE(PDOS,U)
- SET PSUNT=$PIECE(PDOS,U,2)
- +3 IF PSDOS'=""
- IF ($PIECE(PSDOS1,U,2)=PSDOS)
- IF ($PIECE(PSNODE2,U,3)["O")&($PIECE(PSDOS1,U,3)["O")
- Begin DoDot:3
- +4 IF $PIECE(X,U,4)=$PIECE(PSDOSN,U,2)
- IF $PIECE(X,"^")=$PIECE(X1,"^")
- SET RESULT(0)=1
- SET RESULT(1)=PSCORR_"^"_PSDOS
- SET RESULT(2)="FR542"
- QUIT
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +5 if RESULT(0)=1
- QUIT
- +6 ;
- +7 ;
- FR543 SET AA=0
- FOR
- SET AA=$ORDER(^PSDRUG("ASP",+PSOI,AA))
- if 'AA
- QUIT
- Begin DoDot:1
- +1 IF $DATA(^PSDRUG(AA,"DOS1",0))
- FOR PDS=0:0
- SET PDS=$ORDER(^PSDRUG(AA,"DOS1",PDS))
- if 'PDS
- QUIT
- Begin DoDot:2
- +2 SET BB=^PSDRUG(AA,"DOS1",PDS,0)
- SET PSNODE2=$GET(^PSDRUG(AA,2))
- +3 IF PSDOS'=""
- IF ($PIECE(BB,U,2)=PSDOS)&($PIECE(PSNODE2,U,3)["O")&($PIECE(BB,U,3)["O")
- SET FLAG=1
- SET PSLI(AA)=""
- End DoDot:2
- End DoDot:1
- +4 ;
- +5 IF FLAG
- SET AA=0
- FOR
- SET AA=$ORDER(PSLI(AA))
- if 'AA
- QUIT
- FOR PDS=0:0
- SET PDS=$ORDER(^PSDRUG(AA,"DOS1",PDS))
- if 'PDS
- QUIT
- Begin DoDot:1
- +6 SET POSDOS=^PSDRUG(AA,"DOS1",PDS,0)
- SET PSDPD=+$PIECE(POSDOS,U)
- +7 IF '$DATA(PSDUPD)!(PSDPD<PSDUPD)
- SET PSDUPD=PSDPD
- End DoDot:1
- +8 IF FLAG
- SET RESULT(0)=1
- SET RESULT(1)=AA_"^"_$PIECE(POSDOS,U,2)
- SET RESULT(2)="FR543"
- SET FLAG=0
- QUIT
- +9 ;
- +10 ;
- FR544 SET PSCORR=$PIECE(PSNODE8,U,5)
- IF PSCORR
- IF '$PIECE($GET(^PSDRUG(PSCORR,"I")),"^")!($PIECE($GET(^("I")),"^")'<DT)
- DO CP
- Begin DoDot:1
- +1 IF $PIECE(X,U,4)=$PIECE(PSDOSN,U,2)
- IF $PIECE(X,"^")=$PIECE(X1,"^")
- SET RESULT(0)=1
- SET RESULT(1)=PSDD
- End DoDot:1
- +2 if RESULT(0)=1
- QUIT
- +3 ;
- +4 ;
- FR545 SET RESULT(0)=-1
- SET RESULT(2)="All Numeric Dosage Rules failed!"
- +1 QUIT
- +2 ;
- +3 ;
- NNSI ; I/P to O/P Transfer Rules- NON-NUMERIC Single Ingredient
- +1 ;
- FR551 IF '$PIECE($GET(^PSDRUG(+PSDD,"I")),"^")!($PIECE($GET(^("I")),"^")'<DT)
- IF (PSUSE["U")&(PSUSE["O")
- SET RESULT(0)=1
- SET RESULT(1)=PSDD_"^"_PSDOS_"^"_PSOI_"^"_PSDUD
- QUIT
- +1 ;
- +2 ;
- FR552 IF PSUSE'["U"
- IF (PSUSE'["O")
- SET PSCORR=$PIECE(PSNODE8,U,5)
- IF PSCORR
- IF '$PIECE($GET(^PSDRUG(PSCORR,"I")),"^")!($PIECE($GET(^("I")),"^")'<DT)
- DO CP
- Begin DoDot:1
- +1 SET PDOS=$GET(^PSDRUG(PSCORR,"DOS"))
- SET PSSTR=$PIECE(PDOS,U)
- SET PSUNT=$PIECE(PDOS,U,2)
- +2 IF (PSSTR'="")&(PSUNT'="")
- IF (PSSTR=PSNDSTR)&(PSUNT=PSNDUN)
- Begin DoDot:2
- +3 IF $PIECE(X,U,4)=$PIECE(PSDOSN,U,2)
- IF $PIECE(X,"^")=$PIECE(X1,"^")
- SET RESULT(0)=1
- SET RESULT(1)=PSCORR_"^"_PSDOS_"^"_PSOI_"^"_PSDUD
- End DoDot:2
- End DoDot:1
- if RESULT(0)=1
- QUIT
- +4 ;
- +5 ;
- FR553 SET AA=0
- FOR
- SET AA=$ORDER(^PSDRUG("ASP",+PSOI,AA))
- if 'AA
- QUIT
- Begin DoDot:1
- +1 SET PSSTR=$PIECE($GET(^PSDRUG(AA,"DOS")),U)
- SET PSUNT=$PIECE($GET(^("DOS")),U,2)
- +2 SET X=$$CPRS^PSNAPIS(PSSND1,PSSND3)
- +3 SET PSNDSTR=$PIECE(X,U,3)
- SET PSNDUN=$PIECE(X,U,4)
- +4 IF (PSSTR'="")&(PSUNT'="")
- IF (PSSTR=PSNDSTR)&(PSUNT=PSNDUN)
- SET RESULT(0)=1
- SET RESULT(1)=AA_"^"_PSDOS_"^"_PSOI_"^"_PSDUD
- End DoDot:1
- +5 if RESULT(0)=1
- QUIT
- +6 ;
- FR554 SET RESULT(0)=-1
- +1 QUIT
- +2 ;
- NNMI ; I/P to O/P Transfer Rules- Multi-Ingredient
- +1 ;
- FR561 IF '$PIECE($GET(^PSDRUG(+PSDD,"I")),"^")!($PIECE($GET(^("I")),"^")'<DT)
- IF (PSUSE["U")&(PSUSE["O")
- SET RESULT(0)=1
- SET RESULT(1)=PSDD_"^"_PSDOS_"^"_PSOI_"^"_PSDUD
- QUIT
- +1 ;
- +2 ;
- FR562 IF PSUSE'["U"
- IF (PSUSE'["O")
- SET PSCORR=$PIECE(PSNODE8,U,5)
- IF PSCORR
- IF '$PIECE($GET(^PSDRUG(PSCORR,"I")),"^")!($PIECE($GET(^("I")),"^")'<DT)
- DO CP
- Begin DoDot:1
- +1 IF $PIECE(X,U,4)=$PIECE(PSDOSN,U,2)
- IF $PIECE(X,"^")=$PIECE(X1,"^")
- SET RESULT(0)=1
- SET RESULT(1)=PSCORR_"^"_PSOD_"^"_PSSOP_"^"_PSDUD
- End DoDot:1
- +2 QUIT
- CP ;
- +1 SET PSND=$GET(^PSDRUG(PSCORR,"ND"))
- SET X=$$CPRS^PSNAPIS($PIECE(PSND,"^"),$PIECE(PSND,"^",3))
- SET PSNDSTR=$PIECE(X,U,3)
- SET PSNDUN=$PIECE(X,U,4)
- +2 SET PSDOSN=$GET(^PSDRUG(PSDD,"DOS"))
- SET X1=$$CPRS^PSNAPIS(PSSND1,PSSND3)
- +3 QUIT