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

APSDALV.m

Go to the documentation of this file. 
  1. APSDALV ;IHS/DSD/ENM/JCM ; FIX PHARM LINKS TO VMED FILE; [ 03/13/2001  8:07 AM ]
  1.  ;;V6.0;IHS PHARMACY MODIFICATIONS;**1,3**;09/03/97
  1.  ;;V5.06;APSP;MAY 07, 1990
  1.  ; This routine will go through the prescription file beginning
  1.  ; between a site manager specified date interval.  It will check
  1.  ; to see the prescriptions have links to the PCC VMED file and if
  1.  ; not it will create an entry.  If no visit has been made for that
  1.  ; date a visit with the time stamp of noon will be created, otherwise
  1.  ; it will attach the V MED entry to the first visit encountered that
  1.  ; day.  TaskMan must be running to use this utility.
  1.  ;
  1.  ;------------------------------------------------------------------
  1. START ;
  1.  D ^XBKSET
  1.  D ASK
  1.  G:'$D(ED) END
  1.  D DATE
  1. END D EOJ
  1.  Q
  1.  ;-------------------------------------------------------------------
  1. ASK ;
  1.  S APSDALV("DUZ(0)")=DUZ(0)
  1.  S DUZ(0)="MPp"
  1.  S %DT("A")="PLEASE ENTER BEGINNING DATE: "
  1.  S %DT="AE"
  1.  D ^%DT
  1.  I Y=-1 G ASKX
  1.  S BD=Y
  1.  S %DT("A")="PLEASE ENTER ENDING DATE: "
  1.  D ^%DT
  1.  I Y=-1 G:X="" ASK G ASKX
  1.  S ED=Y
  1. TYPE ;
  1.  S DIR(0)="9000010,.03"
  1.  S DIR("A")="TYPE OF VISIT TO CREATE"
  1.  D ^DIR
  1.  K DIR I $D(DIRUT) K DIRUT,DTOUT,DUOUT,BD,ED G ASK
  1.  S APSDALV("APCDTYPE")=Y K X,Y
  1. CAT ;
  1.  S DIR(0)="Y"
  1.  S DIR("A")="DO YOU WANT TO CREATE HISTORICAL VISITS"
  1.  D ^DIR
  1.  K DIR I $D(DIRUT) K DIRUT,DTOUT,DUOUT,BD,ED G TYPE
  1.  I Y S APSDALV("APCDCAT")="E"
  1.  K X,Y
  1. ASKX ;
  1.  Q
  1. DATE ;
  1.  W !
  1.  F DATE=(BD-1):0 S DATE=$O(^PSRX("AD",DATE)) Q:(DATE>ED)!(DATE="")  D RX
  1.  S DUZ(0)=APSDALV("DUZ(0)")
  1.  W !!,"All done ..."
  1.  Q
  1. RX ;
  1.  ;IRXN IS THE SUBSCRIPT PRESCRIPTION NUMBER
  1.  F IRXN=0:0 S IRXN=$O(^PSRX("AD",DATE,IRXN)) Q:IRXN=""  S RFN=$O(^(IRXN,"")) D CHECK
  1.  Q
  1. CHECK ;
  1.  Q:$P(^PSRX(IRXN,0),"^",15)=13  ;THIS RX HAS BEEN MARKED DELTED DUMBO IHS/OKCAO/POC 11/30/2000
  1.  I RFN>0,$S('$D(^PSRX(IRXN,1,RFN,999999911)):1,^(999999911)=""!(^(999999911)=" "):1,1:0) D
  1.  . S APCDALVR("APCDCAT")=$S($D(APSDALV("APCDCAT")):"E",$P(^PSRX(IRXN,0),U,3)'=1:"I",1:"A")
  1.  . S APSRX=IRXN,APSRCT=RFN
  1.  . S APCDALVR("APCDPAT")=$P(^PSRX(IRXN,0),U,2)
  1.  . S APCDALVR("APCDLOC")=DUZ(2)
  1.  . S APCDALVR("APCDTYPE")=APSDALV("APCDTYPE")
  1.  . S APC("PRV")=$P(^PSRX(IRXN,0),U,4)
  1.  . S APSPDOC1=$P($G(^VA(200,APC("PRV"),0)),U,16),APCDALVR("APCDTPRV")=$S($P($G(^AUTTSITE(1,0)),U,22):APC("PRV"),1:APSPDOC1) ;IHS/DSD/ENM 09/03/97
  1.  . S APCDALVR("APCDDATE")=$P(^PSRX(IRXN,1,RFN,0),U,1)
  1.  . D ^APSDALVR
  1.  . W "."
  1.  ;
  1.  I RFN=0,$S('$D(^PSRX(IRXN,999999911)):1,^(999999911)=""!(^(999999911)=" "):1,1:0) D
  1.  . S APSRX0=^PSRX(IRXN,0)
  1.  . S APCDALVR("APCDLOC")=DUZ(2)
  1.  . S APCDALVR("APCDTYPE")=APSDALV("APCDTYPE")
  1.  . S APCDALVR("APCDPAT")=$P(APSRX0,U,2)
  1.  . S APSRX=IRXN,APCDALVR("APCDDATE")=$P(APSRX0,U,13)
  1.  . S APC("PRV")=$P(^PSRX(IRXN,0),U,4)
  1.  . S APSPDOC1=$P($G(^VA(200,APC("PRV"),0)),U,16),APCDALVR("APCDTPRV")=$S($P($G(^AUTTSITE(1,0)),U,22):APC("PRV"),1:APSPDOC1) ;IHS/DSD/ENM 09/03/97
  1.  . S APCDALVR("APCDCAT")=$S($D(APSDALV("APCDCAT")):"E",$P(APSRX0,U,3)'=1:"I",1:"A")
  1.  . D ^APSDALVN
  1.  . W "."
  1.  K RFN,APSRX,APSRCT,APSRX0,APCDALVR
  1.  Q
  1. EOJ ;
  1.  K BD,ED,IRXN,DATE,APSDALV
  1.  Q
  1.  ;NEXT PART FIXES (TRIES) TO DELETE V MED ENTRIES WITH STATUS MARKED DELETED IN THE PRESCRIPTION FILE...WHAT A MESS IHS/OKCAO/POC 11/30/2000
  1. DEL ;
  1.  S APSDALV("DUZ(0)")=DUZ(0)
  1.  S DUZ(0)="MPp"
  1.  S %DT("A")="PLEASE ENTER BEGINNING DATE: "
  1.  S %DT="AE"
  1.  D ^%DT
  1.  I Y=-1 G ASKX
  1.  S BD=Y
  1.  S %DT("A")="PLEASE ENTER ENDING DATE: "
  1.  D ^%DT
  1.  I Y=-1 G:X="" ASK G ASKX
  1.  S ED=Y
  1.  ;
  1.  ;
  1.  W !
  1.  F DATE=(BD-1):0 S DATE=$O(^PSRX("AD",DATE)) Q:(DATE>ED)!(DATE="")  D RXDEL
  1.  S DUZ(0)=APSDALV("DUZ(0)")
  1.  W !!,"All done ..."
  1.  Q
  1. RXDEL ;
  1.  ;IRXN IS THE SUBSCRIPT PRESCRIPTION NUMBER
  1.  F IRXN=0:0 S IRXN=$O(^PSRX("AD",DATE,IRXN)) Q:IRXN=""  S RFN=$O(^(IRXN,"")) D CHECKDEL
  1.  Q
  1. CHECKDEL ;
  1.  ;I RFN>0,$S('$D(^PSRX(IRXN,1,RFN,999999911)):1,^(999999911)=""!(^(999999911)=" "):1,1:0) D
  1.  I RFN>0 Q  ;SHOULDN'T BE A PROBLEM WITH REFILLS
  1.  ;
  1.  I RFN=0 D
  1.  .Q:$P(^PSRX(IRXN,0),"^",15)'=13  ;STOP IF THIS IS NOT MARKED DELETED
  1.  .S APSRX=IRXN
  1.  .S APSRM=+$G(^PSRX(IRXN,999999911))
  1.  .Q:'APSRM  ;GOT NOTHING TO TRY TO DELETE IN VMED
  1.  .S ^AZOPAT("DEL",IRXN,APSRM)="" ;THIS IS DA OF RX, DA OF V MED FILE
  1.  .S DIE="^PSRX(",DR="9999999.11///@",DA=IRXN D ^DIE
  1.  .D ^APSPCCD
  1.  .W "."
  1.  K RFN,APSRX,APSRCT,APSRX0,APCDALVR
  1.  Q
  1. EOJD ;