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

APSPPCCU.m

Go to the documentation of this file. 
  1. APSPPCCU ;IHS/CIA/DKM/PLS - Utilities for PCC Hook for Pharmacy Package ;30-Aug-2005 13:07;SM
  1.  ;;7.0;IHS PHARMACY MODIFICATIONS;**1003**;DEC 11, 2003
  1.  ; Search for bad PSRX-->VMED link
  1. BADP2V ;EP
  1.  N PSRX,REF,VMED,CNT,F1
  1.  W "Searching for bad PSRX-->VMED links...",!!
  1.  S F1=$$ASK^CIAU("Repair bad links")
  1.  Q:'$L(F1)
  1.  R "Starting PSRX: ",PSRX,!!
  1.  Q:PSRX[U
  1.  S:PSRX PSRX=PSRX-1
  1.  S CNT=0
  1.  F  S PSRX=$O(^PSRX(PSRX)) Q:'PSRX  D
  1.  .S VMED=$G(^PSRX(PSRX,999999911)),REF=0
  1.  .D BADP2VX
  1.  .F  S REF=$O(^PSRX(PSRX,1,REF)) Q:'REF  D
  1.  ..S VMED=$G(^PSRX(PSRX,1,REF,999999911))
  1.  ..D BADP2VX
  1.  .W:$X !
  1.  W !!,"Bad links found: ",CNT,!!
  1.  Q
  1.  ; Check VMED
  1. BADP2VX ;EP
  1.  I VMED,'$D(^AUPNVMED(VMED)) D
  1.  .W $S($X:",",1:PSRX_": "),REF
  1.  .S CNT=CNT+1
  1.  .I F1 D
  1.  ..N X
  1.  ..S X=$$PROCESS^APSPPCC(PSRX,REF)
  1.  ..W:X "  ",$P(X,U,2),!
  1.  Q
  1.  ; Search for bad VMED-->PSRX link
  1. BADV2P ;EP
  1.  N VMED,CNT,F1
  1.  W "Searching for bad VMED-->PSRX link...",!!
  1.  S F1=$$ASK^CIAU("Remove orphaned VMED entries")
  1.  Q:'$L(F1)
  1.  R "Starting VMED: ",VMED,!!
  1.  Q:VMED[U
  1.  S:VMED VMED=VMED-1
  1.  S CNT=0
  1.  F  S VMED=$O(^AUPNVMED(VMED)) Q:'VMED  D:'$D(^PSRX("APCC",VMED))
  1.  .S CNT=CNT+1
  1.  .W VMED,!
  1.  .I F1 D
  1.  ..N DIK,DA
  1.  ..S DIK="^AUPNVMED(",DA=VMED
  1.  ..D ^DIK
  1.  W !!,"Bad links found: ",CNT,!!
  1.  Q
  1.  ; Search for scripts without VMED links
  1. NOVMED ;EP
  1.  N PSRX,F1
  1.  W "Searching for Rx's w/o PCC linkage...",!!
  1.  S F1=$$ASK^CIAU("Create entries for unlinked Rx's")
  1.  Q:'$L(F1)
  1.  R "Starting PSRX: ",PSRX,!!
  1.  Q:PSRX[U
  1.  F  S PSRX=$O(^PSRX(PSRX)) Q:'PSRX  D
  1.  .S $X=1
  1.  .D CHECK(PSRX)
  1.  .I '$X,F1 D
  1.  ..N X
  1.  ..S X=$$PROCESS^APSPPCC(PSRX)
  1.  ..W:X ?5,$P(X,U,2),!
  1.  Q
  1.  ; Search message log for missing PCC links
  1. MSG ;EP
  1.  W "Searching message log for missing PCC links...",!!
  1.  N I1,I2,I3,Z,F1,F2
  1.  S F1=$$ASK^CIAU("Purge linked messages")
  1.  S F2=$$ASK^CIAU("Reprocess unlinked Rx's")
  1.  S I3=$O(^XTMP("APSPPCC",$C(1)),-1)
  1.  F I1=0:0:I3 S I1=$O(^XTMP("APSPPCC",I1)) Q:'I1  D
  1.  .W *13,I1,?10
  1.  .F I2=0:0 S I2=$O(^XTMP("APSPPCC",I1,"MSG",I2)) Q:'I2  D  Q:I2<0
  1.  ..S Z=^XTMP("APSPPCC",I1,"MSG",I2)
  1.  ..Q:$E(Z,1,3)'="ORC"
  1.  ..S Z=$P(Z,"|",4)
  1.  ..Q:$P(Z,U,2)'="PS"
  1.  ..S Z=$P(Z,U)
  1.  ..D:Z=+Z CHECK(Z)
  1.  ..S:'$X I2=-1
  1.  .I F1,'I2 K ^XTMP("APSPPCC",I1)
  1.  .I F2,I2 D REP(I1)
  1.  W *13,?20,!!
  1.  Q
  1.  ; Check VMED link for a script
  1. CHECK(PSRX) ;EP
  1.  N REF,STA
  1.  S STA=+$G(^PSRX(PSRX,"STA"))
  1.  Q:STA=3!(STA=13)!(STA=16)
  1.  S REF=$O(^PSRX(PSRX,1,$C(1)),-1)
  1.  I REF D  Q
  1.  .I $G(^PSRX(PSRX,1,REF,999999911)),$D(^AUPNVMED(^(999999911))) Q
  1.  .W:$P(^PSRX(PSRX,1,REF,0),U,18) PSRX,":",REF,!
  1.  I $G(^PSRX(PSRX,999999911)),$D(^AUPNVMED(^(999999911))) Q
  1.  W:$P($G(^PSRX(PSRX,2)),U,2) PSRX,!
  1.  Q
  1. REPROC ;EP
  1.  N MSG
  1.  R "Message # to reprocess: ",MSG,!! Q:'MSG
  1.  D REP(MSG)
  1.  Q
  1. REP(MSG) D EN^APSPPCC($NA(^XTMP("APSPPCC",MSG,"MSG")),MSG)
  1.  Q
  1.  ; Fix V PROVIDER entries of 0
  1. BADPRV ;EP
  1.  N VPRV,VIS,VMED,PSRX
  1.  F VPRV=0:0 S VPRV=$O(^AUPNVPRV("B",0,VPRV)) Q:'VPRV  D
  1.  .S VIS=$P(^AUPNVPRV(VPRV,0),U,3)
  1.  .F VMED=0:0 S VMED=$O(^AUPNVMED("AD",VIS,VMED)) Q:'VMED  D
  1.  ..S PSRX=$O(^PSRX("APCC",VMED,0))
  1.  ..Q:'PSRX
  1.  ..W VMED,!
  1.  ..D PROCESS^APSPPCC(PSRX)
  1.  .K DIE,DA,DR
  1.  .S DIE="^AUPNVPRV(",DA=VPRV,DR=".01///@"
  1.  .D ^DIE
  1.  Q
  1.  ; Purge message logs
  1. MSGPRG K:$$ASK^CIAU("Really purge all message logs") ^XTMP("APSPPCC")
  1.  Q
  1.  ; Find all messages for a given script IEN
  1. FNDMSG(IEN,REPROC) ;EP
  1.  N MSG,X
  1.  S IEN="|"_IEN_"^PS|",REPROC=+$G(REPROC)
  1.  F MSG=0:0 S MSG=$O(^XTMP("APSPPCC",MSG)) Q:'MSG  D
  1.  .F X=0:0 S X=$O(^XTMP("APSPPCC",MSG,X)) Q:'X  I ^(X)[IEN D  Q
  1.  ..W MSG,!
  1.  ..D:REPROC REP(MSG)
  1.  Q