- 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 Apr 23, 2025@18:04:17 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 ;
