PXRMV2ID ; SLC/PKR - Version 2.0 init routine (dates). ;07/01/2003
;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
;
Q
;
;===============================================================
CEDATE ;Find all reminder and term findings that have an ending date.
;Ask the user if it should be moved to a beginning date.
N BDATE,DIR,DIROUT,DTOUT,DUOUT,EDATE,IEN,IND,FINDING,FNAME
N RNAME,TEMP,TEXT,X,Y
W !,"Checking reminder definitions for ending dates."
S IEN=0
F S IEN=+$O(^PXD(811.9,IEN)) Q:IEN=0 D
. S RNAME=$P(^PXD(811.9,IEN,0),U,1)
. S IND=0
. F S IND=+$O(^PXD(811.9,IEN,20,IND)) Q:IND=0 D
.. S TEMP=^PXD(811.9,IEN,20,IND,0)
.. S EDATE=$P(TEMP,U,11)
.. I EDATE'="" D
... S BDATE=$P(TEMP,U,8)
... S FINDING=$P(TEMP,U,1)
... S TEMP="^"_$P(FINDING,";",2)_$P(FINDING,";",1)_",0)"
... S FNAME=$P(@TEMP,U,1)
... W !!,"Reminder ",RNAME
... W !," Finding ",FNAME," has an ending date."
... W !," The ending date is ",EDATE
... S TEXT=$S(BDATE="":"NULL",1:BDATE)
... W !," The beginning date is ",TEXT
... W !," Move the ending date to the beginning date and delete the ending date?"
... S DIR(0)="Y"_U_"AO",DIR("B")="NO"
... D ^DIR
... I Y D
.... S $P(^PXD(811.9,IEN,20,IND,0),U,8)=$$COTN^PXRMDATE(EDATE)
.... S $P(^PXD(811.9,IEN,20,IND,0),U,11)=""
;
W !!,"Checking reminder terms for ending dates."
S IEN=0
F S IEN=+$O(^PXRMD(811.5,IEN)) Q:IEN=0 D
. S RNAME=$P(^PXRMD(811.5,IEN,0),U,1)
. S IND=0
. F S IND=+$O(^PXRMD(811.5,IEN,20,IND)) Q:IND=0 D
.. S TEMP=^PXRMD(811.5,IEN,20,IND,0)
.. S EDATE=$P(TEMP,U,11)
.. I EDATE'="" D
... S BDATE=$P(TEMP,U,8)
... S FINDING=$P(TEMP,U,1)
... S TEMP="^"_$P(FINDING,";",2)_$P(FINDING,";",1)_",0)"
... S FNAME=$P(@TEMP,U,1)
... W !!,"Reminder ",RNAME
... W !," Finding ",FNAME," has an ending date."
... W !," The ending date is ",EDATE
... S TEXT=$S(BDATE="":"NULL",1:BDATE)
... W !," The beginning date is ",TEXT
... W !," Move the ending date to the beginning date and delete the ending date?"
... S DIR(0)="Y"_U_"AO",DIR("B")="NO"
... D ^DIR
... I Y D
.... S $P(^PXRMD(811.5,IEN,20,IND,0),U,8)=$$COTN^PXRMDATE(EDATE)
.... S $P(^PXRMD(811.5,IEN,20,IND,0),U,11)=""
W !," DONE"
Q
;
;===============================================================
CEFFDATE ;Convert effective dates to beginning dates.
N EDATE,IEN,IND,FINDING,FNAME,RNAME,TEMP,TEXT
;Only do this once.
I $$VERSION^XPDUTL("PXRM")["2.0" Q
D BMES^XPDUTL("Converting Effective Dates to Beginning Dates")
S IEN=0
F S IEN=+$O(^PXD(811.9,IEN)) Q:IEN=0 D
. S RNAME=$P(^PXD(811.9,IEN,0),U,1)
. S TEXT=" Working on reminder "_IEN
. D BMES^XPDUTL(TEXT)
. S IND=0
. F S IND=+$O(^PXD(811.9,IEN,20,IND)) Q:IND=0 D
.. S TEMP=^PXD(811.9,IEN,20,IND,0)
.. S EDATE=$P(TEMP,U,11)
.. I EDATE'="" D
... S FINDING=$P(TEMP,U,1)
... S TEMP="^"_$P(FINDING,";",2)_$P(FINDING,";",1)_",0)"
... S FNAME=$P(@TEMP,U,1)
... S TEXT="Moving Effective Date to Beginning Date for reminder "_RNAME
... D BMES^XPDUTL(TEXT)
... S TEXT=" finding "_FNAME
... D BMES^XPDUTL(TEXT)
... S $P(^PXD(811.9,IEN,20,IND,0),U,8)=$$COTN^PXRMDATE(EDATE)
... S $P(^PXD(811.9,IEN,20,IND,0),U,11)=""
;
S IEN=0
F S IEN=+$O(^PXRMD(811.5,IEN)) Q:IEN=0 D
. S TEXT=" Working on term "_IEN
. D BMES^XPDUTL(TEXT)
. S RNAME=$P(^PXRMD(811.5,IEN,0),U,1)
. S IND=0
. F S IND=+$O(^PXRMD(811.5,IEN,20,IND)) Q:IND=0 D
.. S TEMP=^PXRMD(811.5,IEN,20,IND,0)
.. S EDATE=$P(TEMP,U,11)
.. I EDATE'="" D
... S FINDING=$P(TEMP,U,1)
... S TEMP="^"_$P(FINDING,";",2)_$P(FINDING,";",1)_",0)"
... S FNAME=$P(@TEMP,U,1)
... S TEXT="Moving Effective Date to Beginning Date for term "_RNAME
... D BMES^XPDUTL(TEXT)
... S TEXT=" finding "_FNAME
... D BMES^XPDUTL(TEXT)
... S $P(^PXRMD(811.5,IEN,20,IND,0),U,8)=$$COTN^PXRMDATE(EDATE)
... S $P(^PXRMD(811.5,IEN,20,IND,0),U,11)=""
D BMES^XPDUTL(" DONE")
Q
;
;===============================================================
CFDATE ;Convert the beginning and ending dates in the finding multiple
;to the new format.
N IEN,IND,NEWDATE,OLDDATE,TEMP,TEXT
D BMES^XPDUTL("Setting finding dates to new format.")
S IEN=0
F S IEN=+$O(^PXD(811.9,IEN)) Q:IEN=0 D
. S TEXT=" Working on reminder "_IEN
. D BMES^XPDUTL(TEXT)
. S IND=0
. F S IND=+$O(^PXD(811.9,IEN,20,IND)) Q:IND=0 D
.. S TEMP=^PXD(811.9,IEN,20,IND,0)
.. S OLDDATE=$P(TEMP,U,8)
.. I OLDDATE'="" D
... S NEWDATE=$$COTN^PXRMDATE(OLDDATE)
... S $P(^PXD(811.9,IEN,20,IND,0),U,8)=NEWDATE
.. S OLDDATE=$P(TEMP,U,11)
.. I OLDDATE'="" D
... S NEWDATE=$$COTN^PXRMDATE(OLDDATE)
... S $P(^PXD(811.9,IEN,20,IND,0),U,11)=NEWDATE
;
S IEN=0
F S IEN=+$O(^PXRMD(811.5,IEN)) Q:IEN=0 D
. S TEXT=" Working on term "_IEN
. D BMES^XPDUTL(TEXT)
. S IND=0
. F S IND=+$O(^PXRMD(811.5,IEN,20,IND)) Q:IND=0 D
.. S TEMP=^PXRMD(811.5,IEN,20,IND,0)
.. S OLDDATE=$P(TEMP,U,8)
.. I OLDDATE'="" D
... S NEWDATE=$$COTN^PXRMDATE(OLDDATE)
... S $P(^PXRMD(811.5,IEN,20,IND,0),U,8)=NEWDATE
.. S OLDDATE=$P(TEMP,U,11)
.. I OLDDATE'="" D
... S NEWDATE=$$COTN^PXRMDATE(OLDDATE)
... S $P(^PXRMD(811.5,IEN,20,IND,0),U,11)=NEWDATE
D BMES^XPDUTL(" DONE")
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMV2ID 5229 printed Dec 13, 2024@01:49:50 Page 2
PXRMV2ID ; SLC/PKR - Version 2.0 init routine (dates). ;07/01/2003
+1 ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+2 ;
+3 QUIT
+4 ;
+5 ;===============================================================
CEDATE ;Find all reminder and term findings that have an ending date.
+1 ;Ask the user if it should be moved to a beginning date.
+2 NEW BDATE,DIR,DIROUT,DTOUT,DUOUT,EDATE,IEN,IND,FINDING,FNAME
+3 NEW RNAME,TEMP,TEXT,X,Y
+4 WRITE !,"Checking reminder definitions for ending dates."
+5 SET IEN=0
+6 FOR
SET IEN=+$ORDER(^PXD(811.9,IEN))
if IEN=0
QUIT
Begin DoDot:1
+7 SET RNAME=$PIECE(^PXD(811.9,IEN,0),U,1)
+8 SET IND=0
+9 FOR
SET IND=+$ORDER(^PXD(811.9,IEN,20,IND))
if IND=0
QUIT
Begin DoDot:2
+10 SET TEMP=^PXD(811.9,IEN,20,IND,0)
+11 SET EDATE=$PIECE(TEMP,U,11)
+12 IF EDATE'=""
Begin DoDot:3
+13 SET BDATE=$PIECE(TEMP,U,8)
+14 SET FINDING=$PIECE(TEMP,U,1)
+15 SET TEMP="^"_$PIECE(FINDING,";",2)_$PIECE(FINDING,";",1)_",0)"
+16 SET FNAME=$PIECE(@TEMP,U,1)
+17 WRITE !!,"Reminder ",RNAME
+18 WRITE !," Finding ",FNAME," has an ending date."
+19 WRITE !," The ending date is ",EDATE
+20 SET TEXT=$SELECT(BDATE="":"NULL",1:BDATE)
+21 WRITE !," The beginning date is ",TEXT
+22 WRITE !," Move the ending date to the beginning date and delete the ending date?"
+23 SET DIR(0)="Y"_U_"AO"
SET DIR("B")="NO"
+24 DO ^DIR
+25 IF Y
Begin DoDot:4
+26 SET $PIECE(^PXD(811.9,IEN,20,IND,0),U,8)=$$COTN^PXRMDATE(EDATE)
+27 SET $PIECE(^PXD(811.9,IEN,20,IND,0),U,11)=""
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+28 ;
+29 WRITE !!,"Checking reminder terms for ending dates."
+30 SET IEN=0
+31 FOR
SET IEN=+$ORDER(^PXRMD(811.5,IEN))
if IEN=0
QUIT
Begin DoDot:1
+32 SET RNAME=$PIECE(^PXRMD(811.5,IEN,0),U,1)
+33 SET IND=0
+34 FOR
SET IND=+$ORDER(^PXRMD(811.5,IEN,20,IND))
if IND=0
QUIT
Begin DoDot:2
+35 SET TEMP=^PXRMD(811.5,IEN,20,IND,0)
+36 SET EDATE=$PIECE(TEMP,U,11)
+37 IF EDATE'=""
Begin DoDot:3
+38 SET BDATE=$PIECE(TEMP,U,8)
+39 SET FINDING=$PIECE(TEMP,U,1)
+40 SET TEMP="^"_$PIECE(FINDING,";",2)_$PIECE(FINDING,";",1)_",0)"
+41 SET FNAME=$PIECE(@TEMP,U,1)
+42 WRITE !!,"Reminder ",RNAME
+43 WRITE !," Finding ",FNAME," has an ending date."
+44 WRITE !," The ending date is ",EDATE
+45 SET TEXT=$SELECT(BDATE="":"NULL",1:BDATE)
+46 WRITE !," The beginning date is ",TEXT
+47 WRITE !," Move the ending date to the beginning date and delete the ending date?"
+48 SET DIR(0)="Y"_U_"AO"
SET DIR("B")="NO"
+49 DO ^DIR
+50 IF Y
Begin DoDot:4
+51 SET $PIECE(^PXRMD(811.5,IEN,20,IND,0),U,8)=$$COTN^PXRMDATE(EDATE)
+52 SET $PIECE(^PXRMD(811.5,IEN,20,IND,0),U,11)=""
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+53 WRITE !," DONE"
+54 QUIT
+55 ;
+56 ;===============================================================
CEFFDATE ;Convert effective dates to beginning dates.
+1 NEW EDATE,IEN,IND,FINDING,FNAME,RNAME,TEMP,TEXT
+2 ;Only do this once.
+3 IF $$VERSION^XPDUTL("PXRM")["2.0"
QUIT
+4 DO BMES^XPDUTL("Converting Effective Dates to Beginning Dates")
+5 SET IEN=0
+6 FOR
SET IEN=+$ORDER(^PXD(811.9,IEN))
if IEN=0
QUIT
Begin DoDot:1
+7 SET RNAME=$PIECE(^PXD(811.9,IEN,0),U,1)
+8 SET TEXT=" Working on reminder "_IEN
+9 DO BMES^XPDUTL(TEXT)
+10 SET IND=0
+11 FOR
SET IND=+$ORDER(^PXD(811.9,IEN,20,IND))
if IND=0
QUIT
Begin DoDot:2
+12 SET TEMP=^PXD(811.9,IEN,20,IND,0)
+13 SET EDATE=$PIECE(TEMP,U,11)
+14 IF EDATE'=""
Begin DoDot:3
+15 SET FINDING=$PIECE(TEMP,U,1)
+16 SET TEMP="^"_$PIECE(FINDING,";",2)_$PIECE(FINDING,";",1)_",0)"
+17 SET FNAME=$PIECE(@TEMP,U,1)
+18 SET TEXT="Moving Effective Date to Beginning Date for reminder "_RNAME
+19 DO BMES^XPDUTL(TEXT)
+20 SET TEXT=" finding "_FNAME
+21 DO BMES^XPDUTL(TEXT)
+22 SET $PIECE(^PXD(811.9,IEN,20,IND,0),U,8)=$$COTN^PXRMDATE(EDATE)
+23 SET $PIECE(^PXD(811.9,IEN,20,IND,0),U,11)=""
End DoDot:3
End DoDot:2
End DoDot:1
+24 ;
+25 SET IEN=0
+26 FOR
SET IEN=+$ORDER(^PXRMD(811.5,IEN))
if IEN=0
QUIT
Begin DoDot:1
+27 SET TEXT=" Working on term "_IEN
+28 DO BMES^XPDUTL(TEXT)
+29 SET RNAME=$PIECE(^PXRMD(811.5,IEN,0),U,1)
+30 SET IND=0
+31 FOR
SET IND=+$ORDER(^PXRMD(811.5,IEN,20,IND))
if IND=0
QUIT
Begin DoDot:2
+32 SET TEMP=^PXRMD(811.5,IEN,20,IND,0)
+33 SET EDATE=$PIECE(TEMP,U,11)
+34 IF EDATE'=""
Begin DoDot:3
+35 SET FINDING=$PIECE(TEMP,U,1)
+36 SET TEMP="^"_$PIECE(FINDING,";",2)_$PIECE(FINDING,";",1)_",0)"
+37 SET FNAME=$PIECE(@TEMP,U,1)
+38 SET TEXT="Moving Effective Date to Beginning Date for term "_RNAME
+39 DO BMES^XPDUTL(TEXT)
+40 SET TEXT=" finding "_FNAME
+41 DO BMES^XPDUTL(TEXT)
+42 SET $PIECE(^PXRMD(811.5,IEN,20,IND,0),U,8)=$$COTN^PXRMDATE(EDATE)
+43 SET $PIECE(^PXRMD(811.5,IEN,20,IND,0),U,11)=""
End DoDot:3
End DoDot:2
End DoDot:1
+44 DO BMES^XPDUTL(" DONE")
+45 QUIT
+46 ;
+47 ;===============================================================
CFDATE ;Convert the beginning and ending dates in the finding multiple
+1 ;to the new format.
+2 NEW IEN,IND,NEWDATE,OLDDATE,TEMP,TEXT
+3 DO BMES^XPDUTL("Setting finding dates to new format.")
+4 SET IEN=0
+5 FOR
SET IEN=+$ORDER(^PXD(811.9,IEN))
if IEN=0
QUIT
Begin DoDot:1
+6 SET TEXT=" Working on reminder "_IEN
+7 DO BMES^XPDUTL(TEXT)
+8 SET IND=0
+9 FOR
SET IND=+$ORDER(^PXD(811.9,IEN,20,IND))
if IND=0
QUIT
Begin DoDot:2
+10 SET TEMP=^PXD(811.9,IEN,20,IND,0)
+11 SET OLDDATE=$PIECE(TEMP,U,8)
+12 IF OLDDATE'=""
Begin DoDot:3
+13 SET NEWDATE=$$COTN^PXRMDATE(OLDDATE)
+14 SET $PIECE(^PXD(811.9,IEN,20,IND,0),U,8)=NEWDATE
End DoDot:3
+15 SET OLDDATE=$PIECE(TEMP,U,11)
+16 IF OLDDATE'=""
Begin DoDot:3
+17 SET NEWDATE=$$COTN^PXRMDATE(OLDDATE)
+18 SET $PIECE(^PXD(811.9,IEN,20,IND,0),U,11)=NEWDATE
End DoDot:3
End DoDot:2
End DoDot:1
+19 ;
+20 SET IEN=0
+21 FOR
SET IEN=+$ORDER(^PXRMD(811.5,IEN))
if IEN=0
QUIT
Begin DoDot:1
+22 SET TEXT=" Working on term "_IEN
+23 DO BMES^XPDUTL(TEXT)
+24 SET IND=0
+25 FOR
SET IND=+$ORDER(^PXRMD(811.5,IEN,20,IND))
if IND=0
QUIT
Begin DoDot:2
+26 SET TEMP=^PXRMD(811.5,IEN,20,IND,0)
+27 SET OLDDATE=$PIECE(TEMP,U,8)
+28 IF OLDDATE'=""
Begin DoDot:3
+29 SET NEWDATE=$$COTN^PXRMDATE(OLDDATE)
+30 SET $PIECE(^PXRMD(811.5,IEN,20,IND,0),U,8)=NEWDATE
End DoDot:3
+31 SET OLDDATE=$PIECE(TEMP,U,11)
+32 IF OLDDATE'=""
Begin DoDot:3
+33 SET NEWDATE=$$COTN^PXRMDATE(OLDDATE)
+34 SET $PIECE(^PXRMD(811.5,IEN,20,IND,0),U,11)=NEWDATE
End DoDot:3
End DoDot:2
End DoDot:1
+35 DO BMES^XPDUTL(" DONE")
+36 QUIT
+37 ;
